File Coverage

blib/lib/Hypersonic/JIT/Util.pm

Criterion	Covered	Total	%
statement	109	241	45.2
branch	38	100	38.0
condition	13	74	17.5
subroutine	14	29	48.2
pod	10	21	47.6
total	184	465	39.5

package Hypersonic::JIT::Util;
use strict;
use warnings;

use Config;
use Carp qw(croak);

our $VERSION = '0.18';

# =============================================================================
# Cache Directory Management
# =============================================================================

# Base cache directory
our $CACHE_BASE = '_hypersonic_cache';

# Get cache directory for a module
sub cache_dir {
    my ($class, $subdir) = @_;
    return $subdir ? "$CACHE_BASE/$subdir" : $CACHE_BASE;
}

# Subdirectory constants
sub cache_dir_core     { shift->cache_dir('core') }
sub cache_dir_socket   { shift->cache_dir('socket') }
sub cache_dir_request  { shift->cache_dir('request') }
sub cache_dir_response { shift->cache_dir('response') }
sub cache_dir_session  { shift->cache_dir('session') }
sub cache_dir_tls      { shift->cache_dir('tls') }
sub cache_dir_future   { shift->cache_dir('future') }

# =============================================================================
# Fork Detection
# =============================================================================

sub can_fork {
    return $Config{d_fork} && eval {
        my $pid = fork();
        if (defined $pid && $pid == 0) {
            exit(0);  # Child exits immediately
        }
        waitpid($pid, 0) if defined $pid;
        1;
    };
}

# =============================================================================
# Parallel Compilation
# =============================================================================

# Standalone modules that can compile independently
our @STANDALONE_MODULES = qw(
    Hypersonic::Socket
    Hypersonic::Response
    Hypersonic::Session
    Hypersonic::TLS
);

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

    my @modules = $opts{modules} // @STANDALONE_MODULES;
    my $parallel = $opts{parallel} // 1;

    # Load modules
    for my $mod (@modules) {
        eval "require $mod" or do {
            warn "Failed to load $mod: $@";
            return 0;
        };
    }

    if ($parallel && $class->can_fork) {
        return $class->_compile_parallel(\@modules, \%opts);
    } else {
        return $class->_compile_sequential(\@modules, \%opts);
    }
}

sub _compile_parallel {
    my ($class, $modules, $opts) = @_;

    my @pids;
    my %child_to_mod;

    for my $mod (@$modules) {
        my $pid = fork();

        if (!defined $pid) {
            warn "Fork failed for $mod: $!";
            # Fallback to sequential for this module
            eval { $mod->compile(%$opts) };
            warn "Compile failed for $mod: $@" if $@;
        } elsif ($pid == 0) {
            # Child process
            eval { $mod->compile(%$opts) };
            exit($@ ? 1 : 0);
        } else {
            # Parent
            push @pids, $pid;
            $child_to_mod{$pid} = $mod;
        }
    }

    # Wait for all children
    my $all_ok = 1;
    for my $pid (@pids) {
        waitpid($pid, 0);
        if ($? != 0) {
            my $mod = $child_to_mod{$pid};
            warn "Compilation failed for $mod (exit code: " . ($? >> 8) . ")";
            $all_ok = 0;
        }
    }

    # After fork compilation, parent must load the compiled modules
    # (children wrote to cache, but parent needs to load)
    for my $mod (@$modules) {
        eval { $mod->compile(%$opts) };  # Will load from cache
        if ($@) {
            warn "Failed to load compiled $mod: $@";
            $all_ok = 0;
        }
    }

    return $all_ok;
}

sub _compile_sequential {
    my ($class, $modules, $opts) = @_;

    my $all_ok = 1;
    for my $mod (@$modules) {
        eval { $mod->compile(%$opts) };
        if ($@) {
            warn "Compile failed for $mod: $@";
            $all_ok = 0;
        }
    }

    return $all_ok;
}

# =============================================================================
# Common Include Patterns
# =============================================================================

sub add_standard_includes {
    my ($class, $builder, @features) = @_;

    my %features = map { $_ => 1 } @features;

    # Always needed
    $builder->line('#include ')
            ->line('#include ')
            ->line('#include ');

    if ($features{stdio}) {
        $builder->line('#include ');
    }

    # On Windows, unistd / fcntl / netinet don't exist. Winsock provides
    # the socket API but with different headers + a stub `close()`. We
    # also define `hs_set_nonblocking(fd)` here so callers don't need
    # platform-specific fcntl vs ioctlsocket dances.
    if ($features{unistd} || $features{fcntl} || $features{socket}) {
        $builder->raw(<<'C');
#ifdef _WIN32
#  define WIN32_LEAN_AND_MEAN
#  include
#  include
#  include
#  ifndef close
#    define close(fd) closesocket(fd)
#  endif
#  ifndef MSG_NOSIGNAL
#    define MSG_NOSIGNAL 0
#  endif
#  ifndef hs_set_nonblocking
#    define hs_set_nonblocking(fd) do { u_long _m = 1; ioctlsocket((fd), FIONBIO, &_m); } while(0)
#  endif
#else
C
        $builder->line('#include ') if $features{unistd};
        $builder->line('#include ')  if $features{fcntl};
        if ($features{socket}) {
            $builder->line('#include ')
                    ->line('#include ')
                    ->line('#include ')
                    ->line('#include ')
                    ->line('#include ')
                    ->line('#include ');
        }
        $builder->raw(<<'C');
#  ifndef hs_set_nonblocking
#    define hs_set_nonblocking(fd) do { int _f = fcntl((fd), F_GETFL, 0); fcntl((fd), F_SETFL, _f | O_NONBLOCK); } while(0)
#  endif
#endif
C
    }

    if ($features{threading}) {
        $builder->line('#ifndef _WIN32')
                ->line('#include ')
                ->line('#endif');
    }

    if ($features{eventfd}) {
        $builder->line('#ifdef __linux__')
                ->line('#include ')
                ->line('#endif');
    }

    if ($features{time}) {
        $builder->line('#include ');
    }

    if ($features{signal}) {
        $builder->line('#include ');
    }

    if ($features{openssl}) {
        $builder->line('#include ')
                ->line('#include ')
                ->line('#include ');
    }

    $builder->blank;

    return $builder;
}

# =============================================================================
# Platform Detection Helpers
# =============================================================================

sub add_platform_eventfd {
    my ($class, $builder) = @_;

    $builder->line('#ifndef _WIN32')
            ->line('#ifdef __linux__')
            ->line('#include ')
            ->line('#define USE_EVENTFD 1')
            ->line('#else')
            ->line('#define USE_EVENTFD 0')
            ->line('#endif')
            ->line('#endif /* !_WIN32 */')
            ->blank;

    return $builder;
}

sub add_platform_detection {
    my ($class, $builder) = @_;

    $builder->line('/* Platform detection */')
            ->line('#if defined(__APPLE__)')
            ->line('#define HYPERSONIC_MACOS 1')
            ->line('#elif defined(__linux__)')
            ->line('#define HYPERSONIC_LINUX 1')
            ->line('#elif defined(_WIN32)')
            ->line('#define HYPERSONIC_WINDOWS 1')
            ->line('#elif defined(__FreeBSD__) || defined(__NetBSD__) || defined(__OpenBSD__)')
            ->line('#define HYPERSONIC_BSD 1')
            ->line('#endif')
            ->blank;

    return $builder;
}

# =============================================================================
# Library Detection
# =============================================================================

# Check if Devel::CheckLib is available (CPAN standard for library detection)
my $HAS_DEVEL_CHECKLIB;
sub _has_devel_checklib {
    return $HAS_DEVEL_CHECKLIB if defined $HAS_DEVEL_CHECKLIB;
    $HAS_DEVEL_CHECKLIB = eval { require Devel::CheckLib; 1 } ? 1 : 0;
    return $HAS_DEVEL_CHECKLIB;
}

# Check if ExtUtils::PkgConfig is available
my $HAS_EXTUTILS_PKGCONFIG;
sub _has_extutils_pkgconfig {
    return $HAS_EXTUTILS_PKGCONFIG if defined $HAS_EXTUTILS_PKGCONFIG;
    $HAS_EXTUTILS_PKGCONFIG = eval { require ExtUtils::PkgConfig; 1 } ? 1 : 0;
    return $HAS_EXTUTILS_PKGCONFIG;
}

# Check if a library can actually be linked (compile+link test)
# Uses Devel::CheckLib when available (CPAN standard), falls back to manual test
sub can_link {
    my ($class, $cflags, $ldflags, $test_symbol, $extra_includes) = @_;
    $cflags //= '';
    $ldflags //= '';
    $extra_includes //= '';

    # Extract header names from include directives for Devel::CheckLib
    # e.g., '#include ' -> 'math.h'
    my @headers;
    if ($extra_includes) {
        @headers = ($extra_includes =~ /#include\s*[<"]([^>"]+)[>"]/g);
    }

    # Use Devel::CheckLib if available - it's the CPAN standard and handles
    # edge cases (different compilers, platforms, error handling) better
    if ($class->_has_devel_checklib()) {
        # Take address of symbol and store in volatile to force linker resolution
        # The void* cast works for both functions and variables
        my $function = "void *p = (void*)$test_symbol; volatile void *vp = p; return vp ? 0 : 1;";
        my %args = (
            INC      => $cflags,
            LIBS     => $ldflags,
            function => $function,
        );
        $args{header} = \@headers if @headers;
        return Devel::CheckLib::check_lib(%args);
    }

    # Fallback: manual compile+link test
    require File::Temp;

    # Generate test code that forces the linker to resolve the symbol
    # Take address and store in volatile to prevent optimization
    my $test_code = <<"C";
$extra_includes
int main(void) {
    void *p = (void*)$test_symbol;
    volatile void *vp = p;
    return vp ? 0 : 1;
}
C

    my $src = File::Temp->new(SUFFIX => '.c', UNLINK => 1);
    my $src_path = $src->filename;
    print $src $test_code;
    close $src;

    my $out = File::Temp->new(SUFFIX => '', UNLINK => 1);
    my $out_path = $out->filename;
    close $out;

    my $cc = $ENV{CC} || $Config{cc} || 'cc';
    my $result = system("$cc $cflags -o $out_path $src_path $ldflags 2>/dev/null");

    unlink $out_path if -f $out_path;

    return $result == 0;
}

## Compile a tiny C program and run it. Returns 1 if the program
## compiles, links, AND exits 0; 0 otherwise. Use this when "linkable"
## isn't enough — e.g. probing whether a syscall actually works on the
## current kernel (io_uring on RHEL9 with kernel.io_uring_disabled=2
## links fine but io_uring_setup() returns EINVAL at runtime).
sub can_run {
    my ($class, $cflags, $ldflags, $body, $extra_includes) = @_;
    $cflags          //= '';
    $ldflags         //= '';
    $extra_includes  //= '';

    require File::Temp;

    my $src_code = <<"C";
$extra_includes
int main(void) {
$body
}
C

    my $src = File::Temp->new(SUFFIX => '.c', UNLINK => 1);
    print $src $src_code;
    close $src;

    my $out = File::Temp->new(SUFFIX => '', UNLINK => 1);
    my $out_path = $out->filename;
    close $out;

    my $cc = $ENV{CC} || $Config{cc} || 'cc';
    my $compile_rc = system("$cc $cflags -o $out_path " . $src->filename
                          . " $ldflags >/dev/null 2>&1");
    if ($compile_rc != 0 || !-x $out_path) {
        unlink $out_path if -f $out_path;
        return 0;
    }

    my $run_rc = system("$out_path >/dev/null 2>&1");
    unlink $out_path if -f $out_path;
    return $run_rc == 0;
}

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

    my $result = {
        available => 0,
        cflags    => '',
        ldflags   => '',
    };

    my $test_symbol = $opts{test_symbol};
    my $test_include = $opts{test_include} // '';

    # Try Alien module first
    my $alien_module = $opts{alien} // "Alien::\u$lib_name";
    if (eval "require $alien_module; 1") {
        my $cflags = $alien_module->cflags // '';
        my $ldflags = $alien_module->libs // '';

        # Verify it actually links if test_symbol provided
        if (!$test_symbol || $class->can_link($cflags, $ldflags, $test_symbol, $test_include)) {
            $result->{available} = 1;
            $result->{cflags}  = $cflags;
            $result->{ldflags} = $ldflags;
            return $result;
        }
    }

    # Try pkg-config (prefer ExtUtils::PkgConfig if available - CPAN standard)
    my $pkg_name = $opts{pkg_config} // $lib_name;
    my ($cflags, $ldflags);

    # ExtUtils::PkgConfig only grew the ->exists() class method in
    # later releases (it's not in the 1.16 shipped with some
    # vendor perls). Older versions die with
    #   method 'exists' not implemented at ... line 424
    # which is exactly what the CPAN tester report for Hypersonic
    # 0.17 on perl 5.20 showed. Probe with ->find() inside an eval
    # when the class can't ->exists, and treat any failure as
    # "not available via pkg-config" so we fall through to the
    # command-line pkg-config branch below.
    if ($class->_has_extutils_pkgconfig()) {
        my $is_available = eval {
            if (ExtUtils::PkgConfig->can('exists')) {
                ExtUtils::PkgConfig->exists($pkg_name) ? 1 : 0;
            } else {
                # Older API: ->find dies if the package is missing,
                # returns a key/value list (cflags/libs/modversion) on
                # success. Either outcome is fine here - we just want
                # a 1/0 answer.
                my %info = ExtUtils::PkgConfig->find($pkg_name);
                ($info{cflags} || $info{libs} || $info{modversion}) ? 1 : 0;
            }
        };
        # If the probe died OR returned a false value, fall back to
        # the shell pkg-config below; never propagate the die.
        if ($is_available) {
            eval {
                my %pkg_info = ExtUtils::PkgConfig->find($pkg_name);
                $cflags = $pkg_info{cflags} // '';
                $ldflags = $pkg_info{libs} // '';
            };
            # Same defensive eval - some old versions of
            # ExtUtils::PkgConfig die on find() in odd corner cases
            # (e.g. when the .pc file references an unresolvable
            # Requires:). Swallow and fall through to shell pkg-config.
        }
    }

    # Fallback to command-line pkg-config
    if (!$ldflags) {
        $cflags = `pkg-config --cflags $pkg_name 2>/dev/null`;
        $ldflags = `pkg-config --libs $pkg_name 2>/dev/null`;
        if ($? == 0) {
            chomp($cflags);
            chomp($ldflags);
        } else {
            $cflags = $ldflags = '';
        }
    }

    if ($ldflags) {
        # Verify it actually links if test_symbol provided
        if (!$test_symbol || $class->can_link($cflags, $ldflags, $test_symbol, $test_include)) {
            $result->{available} = 1;
            $result->{cflags}  = $cflags;
            $result->{ldflags} = $ldflags;
            return $result;
        }
    }

    # Try common paths (with additional Homebrew versioned paths for OpenSSL)
    my @search_paths = @{$opts{paths} // [
        # macOS Homebrew (Apple Silicon) - versioned first
        '/opt/homebrew/opt/openssl@3',
        '/opt/homebrew/opt/openssl',
        '/opt/homebrew',
        # macOS Homebrew (Intel) - versioned first
        '/usr/local/opt/openssl@3',
        '/usr/local/opt/openssl',
        '/usr/local',
        # Linux standard locations
        '/usr',
        '/opt/local',
    ]};

    my $header = $opts{header};
    my $lib = $opts{lib} // "lib$lib_name";

    for my $prefix (@search_paths) {
        my $inc_dir = "$prefix/include";
        my $lib_dir = "$prefix/lib";

        # Check for header if specified
        if ($header && !-f "$inc_dir/$header") {
            next;
        }

        # Check for library file
        my $found_lib = 0;
        for my $ext (qw(.dylib .so .a)) {
            if (-f "$lib_dir/$lib$ext") {
                $found_lib = 1;
                last;
            }
        }

        if ($found_lib) {
            my $try_cflags = "-I$inc_dir";
            my $try_ldflags = "-L$lib_dir -l$lib_name";

            # Verify it actually links if test_symbol provided
            if (!$test_symbol || $class->can_link($try_cflags, $try_ldflags, $test_symbol, $test_include)) {
                $result->{available} = 1;
                $result->{cflags}  = $try_cflags;
                $result->{ldflags} = $try_ldflags;
                return $result;
            }
        }
    }

    return $result;
}

# Convenience methods for common libraries
sub detect_openssl {
    my ($class) = @_;
    return $class->detect_library('ssl',
        alien        => 'Alien::OpenSSL',
        pkg_config   => 'openssl',
        header       => 'openssl/ssl.h',
        lib          => 'libssl',
        test_symbol  => 'SSL_new',
        test_include => '#include ',
    );
}

sub detect_zlib {
    my ($class) = @_;
    return $class->detect_library('z',
        alien        => 'Alien::zlib',
        pkg_config   => 'zlib',
        header       => 'zlib.h',
        lib          => 'libz',
        test_symbol  => 'deflate',
        test_include => '#include ',
    );
}

sub detect_nghttp2 {
    my ($class) = @_;
    return $class->detect_library('nghttp2',
        pkg_config   => 'libnghttp2',
        header       => 'nghttp2/nghttp2.h',
        test_symbol  => 'nghttp2_session_client_new',
        test_include => '#include ',
    );
}

# =============================================================================
# C99 Detection
# =============================================================================

my $C99_SUPPORTED;

sub has_c99 {
    my ($class) = @_;
    return $C99_SUPPORTED if defined $C99_SUPPORTED;

    require File::Temp;

    # Test C99 features: inline keyword and for-loop declarations
    my $test_code = <<'C';
static inline int test_inline(void) { return 1; }
int main(void) {
    for (int i = 0; i < 1; i++) { }
    return test_inline();
}
C

    my $src = File::Temp->new(SUFFIX => '.c', UNLINK => 1);
    my $src_path = $src->filename;
    print $src $test_code;
    close $src;

    my $out = File::Temp->new(SUFFIX => '', UNLINK => 1);
    my $out_path = $out->filename;
    close $out;

    my $cc = $ENV{CC} || $Config{cc} || 'cc';
    my $result = system("$cc -o $out_path $src_path 2>/dev/null");

    unlink $out_path if -f $out_path;

    $C99_SUPPORTED = ($result == 0) ? 1 : 0;
    return $C99_SUPPORTED;
}

sub inline_keyword {
    my ($class) = @_;
    return $class->has_c99() ? 'inline' : '';
}


1;

__END__