File Coverage

blib/lib/ExtUtils/XSOne.pm

Criterion	Covered	Total	%
statement	199	201	99.0
branch	70	82	85.3
condition	23	34	67.6
subroutine	22	22	100.0
pod	2	2	100.0
total	316	341	92.6

package ExtUtils::XSOne;

use 5.008003;
use strict;
use warnings;

use File::Spec;
use File::Basename qw(dirname basename);
use File::Path qw(make_path);
use File::Find qw(find);
use Carp qw(croak);

our $VERSION = '0.03';

sub combine {
    my ($class, %opts) = @_;

    my $src_dir   = $opts{src_dir} or croak "src_dir is required";
    my $output    = $opts{output}  or croak "output is required";
    my $order     = $opts{order};
    my $verbose   = $opts{verbose} || 0;
    my $dedup     = exists $opts{deduplicate} ? $opts{deduplicate} : 1;
    my $recursive = $opts{recursive} || 0;

    my @sorted;
    if ($recursive) {
        @sorted = $class->_find_xs_files_recursive($src_dir);
    } else {
        my @xs_files = $class->_find_xs_files($src_dir);
        @sorted = $class->_sort_files(\@xs_files, $order);
    }

    if ($verbose) {
        warn "ExtUtils::XSOne: Processing files in order:\n";
        warn "  $_\n" for @sorted;
    }

    # Read all files and extract/deduplicate C preamble
    my @file_contents;
    my %seen_includes;
    my %seen_defines;
    my @collected_includes;
    my @collected_defines;
    my @collected_c_code;
    my @header_c_code;  # C code from _header.xs files (processed first)

    for my $file (@sorted) {
        # In recursive mode, $file is already a relative path from src_dir
        # In non-recursive mode, $file is just the filename
        my $path = File::Spec->catfile($src_dir, $file);
        my $display_file = $recursive ? $file : basename($file);
        warn "ExtUtils::XSOne: Reading $path\n" if $verbose;

        my $content = $class->_read_file($path);
        my $filename = basename($file);
        my $is_header = ($filename eq '_header.xs');

        if ($dedup) {
            # Parse and extract C preamble (before MODULE =)
            my ($preamble, $xs_part) = $class->_split_preamble($content);

            # For _header.xs files without MODULE, the entire content is in xs_part
            # We need to treat it as preamble C code
            my $c_content = $preamble;
            if ($is_header && $preamble eq '' && $xs_part =~ /\S/) {
                $c_content = $xs_part;
                $xs_part = '';
            }

            # Extract includes, defines, and other C code from preamble
            my ($includes, $defines, $other_c) = $class->_parse_preamble($c_content);

            # Deduplicate includes
            for my $inc (@$includes) {
                my $normalized = $class->_normalize_include($inc);
                unless ($seen_includes{$normalized}++) {
                    push @collected_includes, $inc;
                }
            }

            # Deduplicate defines (by macro name)
            for my $def (@$defines) {
                my $name = $class->_extract_define_name($def);
                unless ($seen_defines{$name}++) {
                    push @collected_defines, $def;
                }
            }

            # Collect other C code (functions, structs, etc.)
            # _header.xs code goes first to ensure definitions are available
            if ($other_c =~ /\S/) {
                if ($is_header) {
                    push @header_c_code, { file => $file, path => $path, code => $other_c };
                } else {
                    push @collected_c_code, { file => $file, path => $path, code => $other_c };
                }
            }

            # Store just the XS part (empty for pure _header.xs files)
            push @file_contents, { file => $file, path => $path, content => $xs_part }
                if $xs_part =~ /\S/;
        } else {
            push @file_contents, { file => $file, path => $path, content => $content };
        }
    }

    # Merge header C code first, then other C code
    @collected_c_code = (@header_c_code, @collected_c_code);

    # Build combined content
    my $combined = $class->_build_header($src_dir, \@sorted);

    if ($dedup && (@collected_includes || @collected_defines || @collected_c_code)) {
        # Add deduplicated preamble
        $combined .= "/* ========== COMBINED C PREAMBLE ========== */\n\n";

        # Includes first
        if (@collected_includes) {
            $combined .= join("\n", @collected_includes) . "\n\n";
        }

        # Then defines
        if (@collected_defines) {
            $combined .= join("\n", @collected_defines) . "\n\n";
        }

        # Then other C code with source markers
        for my $c_block (@collected_c_code) {
            $combined .= "/* C code from: $c_block->{file} */\n";
            $combined .= "#line 1 \"$c_block->{path}\"\n";
            $combined .= $c_block->{code} . "\n";
        }

        $combined .= "/* ========== END COMBINED C PREAMBLE ========== */\n";
    }

    # Add XS parts
    for my $fc (@file_contents) {
        $combined .= $class->_wrap_file($fc->{file}, $fc->{path}, $fc->{content});
    }

    # Write output
    $class->_write_file($output, $combined, $verbose);

    warn "ExtUtils::XSOne: Generated $output from " . scalar(@sorted) . " files\n"
        if $verbose;

    return scalar(@sorted);
}

sub files_in_order {
    my ($class, $src_dir, $order) = @_;

    my @xs_files = $class->_find_xs_files($src_dir);
    return $class->_sort_files(\@xs_files, $order);
}

#
# Internal methods
#

sub _find_xs_files {
    my ($class, $src_dir) = @_;

    croak "Source directory '$src_dir' does not exist" unless -d $src_dir;

    opendir(my $dh, $src_dir) or croak "Cannot open $src_dir: $!";
    my @xs_files = grep { /\.xs$/ } readdir($dh);
    closedir($dh);

    croak "No .xs files found in $src_dir" unless @xs_files;

    return @xs_files;
}

sub _find_xs_files_recursive {
    my ($class, $src_dir) = @_;

    croak "Source directory '$src_dir' does not exist" unless -d $src_dir;

    my @headers;   # { path => relative_path, depth => N }
    my @footers;   # { path => relative_path, depth => N }
    my @packages;  # relative paths to package XS files

    # Normalize src_dir for consistent path handling
    $src_dir = File::Spec->canonpath($src_dir);
    my $src_dir_len = length($src_dir);

    find({
        wanted => sub {
            return unless -f && /\.xs$/;

            my $full_path = $File::Find::name;
            my $dir = $File::Find::dir;

            # Get path relative to src_dir
            my $rel_path = substr($full_path, $src_dir_len);
            $rel_path =~ s{^[/\\]}{};  # Remove leading separator

            # Calculate depth (number of directory separators)
            my $depth = ($rel_path =~ tr!/\\!!);

            my $filename = basename($full_path);

            if ($filename eq '_header.xs') {
                push @headers, { path => $rel_path, depth => $depth };
            } elsif ($filename eq '_footer.xs') {
                push @footers, { path => $rel_path, depth => $depth };
            } else {
                push @packages, $rel_path;
            }
        },
        no_chdir => 1,
    }, $src_dir);

    croak "No .xs files found in $src_dir" unless @headers || @footers || @packages;

    # Sort headers by depth (shallow first), then alphabetically
    @headers = map { $_->{path} }
               sort { $a->{depth} <=> $b->{depth} || $a->{path} cmp $b->{path} }
               @headers;

    # Sort footers by depth (deep first - reverse of headers), then alphabetically
    @footers = map { $_->{path} }
               sort { $b->{depth} <=> $a->{depth} || $a->{path} cmp $b->{path} }
               @footers;

    # Sort package files alphabetically
    @packages = sort @packages;

    return (@headers, @packages, @footers);
}

sub _sort_files {
    my ($class, $files, $order) = @_;

    if ($order && @$order) {
        # Use explicit order
        my %available = map { $_ => 1 } @$files;
        my @sorted;

        for my $name (@$order) {
            my $file = "$name.xs";
            if ($available{$file}) {
                push @sorted, $file;
                delete $available{$file};
            }
        }

        # Append any remaining files
        push @sorted, sort keys %available;
        return @sorted;
    }

    # Default ordering: _header first, _footer last, others alphabetically
    my @header = grep { /^_header\.xs$/ } @$files;
    my @footer = grep { /^_footer\.xs$/ } @$files;
    my @middle = sort grep { !/^_/ } @$files;
    my @other_underscore = sort grep { /^_/ && !/^_(header|footer)\.xs$/ } @$files;

    return (@header, @middle, @other_underscore, @footer);
}

sub _split_preamble {
    my ($class, $content) = @_;

    # Find the first MODULE = declaration
    if ($content =~ /^(.*?)(^MODULE\s*=\s*.+)$/ms) {
        return ($1, $2);
    }

    # No MODULE found - entire content is C preamble (e.g., _header.xs)
    return ('', $content);
}

sub _parse_preamble {
    my ($class, $preamble) = @_;

    my @includes;
    my @defines;
    my @other_lines;

    for my $line (split /\n/, $preamble) {
        if ($line =~ /^\s*#\s*include\s/) {
            push @includes, $line;
        } elsif ($line =~ /^\s*#\s*define\s/) {
            push @defines, $line;
        } else {
            push @other_lines, $line;
        }
    }

    my $other_c = join("\n", @other_lines);

    # Remove leading/trailing whitespace
    $other_c =~ s/^\s+//;
    $other_c =~ s/\s+$//;

    return (\@includes, \@defines, $other_c);
}

sub _normalize_include {
    my ($class, $include) = @_;

    # Extract the actual include path/name
    if ($include =~ /#\s*include\s*[<"]([^>"]+)[>"]/) {
        return $1;
    }
    return $include;
}

sub _extract_define_name {
    my ($class, $define) = @_;

    if ($define =~ /#\s*define\s+(\w+)/) {
        return $1;
    }
    return $define;
}

sub _build_header {
    my ($class, $src_dir, $files) = @_;

    my $header = <<"HEADER";
/*
 * THIS FILE IS AUTO-GENERATED BY ExtUtils::XSOne
 * DO NOT EDIT DIRECTLY - edit files in $src_dir/ instead
 *
 * Generated from:
HEADER

    $header .= " *   $_\n" for @$files;
    $header .= " */\n\n";

    return $header;
}

# Note: xsubpp cannot handle comments or #line directives between MODULE
# declarations - they cause parsing errors. We only add markers for pure
# C code sections (like _header.xs without MODULE), not for XS sections.
sub _wrap_file {
    my ($class, $file, $path, $content) = @_;

    my $wrapped = "\n";

    # Check if content starts with MODULE declaration (XS code)
    if ($content =~ /^\s*MODULE\s*=/m) {
        # For XS content, don't add any comments or #line directives
        # xsubpp can't handle them between MODULE sections
        $wrapped .= $content;
    } else {
        # For non-MODULE content (like _header.xs or pure C preamble),
        # add a marker comment and #line directive for debugging
        $wrapped .= "/* ========== BEGIN: $file ========== */\n";
        $wrapped .= "#line 1 \"$path\"\n";
        $wrapped .= $content;
    }

    $wrapped .= "\n";

    return $wrapped;
}

sub _read_file {
    my ($class, $path) = @_;

    open(my $fh, '<', $path) or croak "Cannot read $path: $!";
    local $/;
    my $content = <$fh>;
    close($fh);

    return $content;
}

sub _write_file {
    my ($class, $path, $content, $verbose) = @_;

    # Create directory if needed
    my $dir = dirname($path);
    if ($dir && $dir ne '.' && !-d $dir) {
        make_path($dir);  # throws on failure
    }

    warn "ExtUtils::XSOne: Writing $path\n" if $verbose;

    open(my $fh, '>', $path) or croak "Cannot write $path: $!";
    print $fh $content;
    close($fh);
}

1;

__END__