perl_dap/platform/

mod.rs

//! Cross-platform utilities for Perl path resolution and environment setup.
//!
//! Shared toolchain detection functions (`resolve_perl_path_with_toolchain`,
//! `detect_perlbrew_perl`, `detect_plenv_perl`, `resolve_perl_path`) are
//! canonical in `perl_lsp_rs_core::platform` and re-exported here for
//! backward compatibility.

// Re-export format_command_args for backward compatibility (was in old platform re-export module)
pub use crate::command_args::format_command_args;

// Re-export canonical toolchain detection from perl-lsp-rs-core (#4545)
pub use perl_lsp_rs_core::platform::{
    detect_perlbrew_perl, detect_plenv_perl, resolve_perl_path, resolve_perl_path_with_toolchain,
};

use std::collections::HashMap;
use std::env;
use std::path::PathBuf;
use std::sync::{LazyLock, Mutex};

#[cfg(windows)]
const PATH_SEPARATOR: char = ';';
#[cfg(not(windows))]
const PATH_SEPARATOR: char = ':';

#[cfg(windows)]
const PERL_EXECUTABLE: &str = "perl.exe";
#[cfg(not(windows))]
const PERL_EXECUTABLE: &str = "perl";

/// The result of Perl interpreter discovery.
///
/// Separates the "found on PATH" case from the "found via OS fallback" case
/// so callers can log or surface different messages to users.
#[derive(Debug, Clone, PartialEq)]
pub enum PerlInterpreterResult {
    /// Perl was found via the configured `perl-lsp.perl.path` setting.
    ConfiguredPath(PathBuf),
    /// Perl was found on PATH (the normal case).
    FoundOnPath(PathBuf),
    /// Perl was NOT on PATH but was found at a well-known OS install location.
    FoundViaFallback {
        /// Absolute path to the Perl interpreter found at the fallback location.
        path: PathBuf,
        /// Human-readable label for the fallback source (e.g. `"Strawberry Perl"`).
        label: String,
    },
    /// No Perl interpreter found anywhere.
    NotFound {
        /// Ordered list of locations that were searched, for use in error messages.
        searched: Vec<String>,
    },
}

static PERL_INTERPRETER_CACHE: LazyLock<Mutex<Option<(String, PerlInterpreterResult)>>> =
    LazyLock::new(|| Mutex::new(None));

fn perl_discovery_cache_key(configured_path: Option<&str>) -> String {
    let path_env = env::var("PATH").unwrap_or_default();
    let perlbrew_perl = env::var("PERLBREW_PERL").unwrap_or_default();
    let perlbrew_root = env::var("PERLBREW_ROOT").unwrap_or_default();
    let plenv_root = env::var("PLENV_ROOT").unwrap_or_default();
    let plenv_version = env::var("PLENV_VERSION").unwrap_or_default();
    // HOME (Unix) and USERPROFILE (Windows) are both checked by home_dir() in
    // perl-lsp-rs-core::platform when PERLBREW_ROOT/PLENV_ROOT are absent.
    let home = env::var("HOME").unwrap_or_default();
    let userprofile = env::var("USERPROFILE").unwrap_or_default();
    // PREFIX is used by resolve_perl_path() for Termux detection.
    let prefix = env::var("PREFIX").unwrap_or_default();

    format!(
        "cfg={};path={path_env};perlbrew_perl={perlbrew_perl};perlbrew_root={perlbrew_root};plenv_root={plenv_root};plenv_version={plenv_version};home={home};userprofile={userprofile};prefix={prefix}",
        configured_path.map(str::trim).unwrap_or_default()
    )
}

/// Rank a Perl binary path for preference on Windows.
///
/// Returns a lower score for higher-priority interpreters.
/// Strawberry Perl ranks best (1), then ActiveState (2), then msys/Git Bash (100).
#[cfg(windows)]
fn windows_perl_rank(path: &std::path::Path) -> u8 {
    let s = path.to_string_lossy().to_ascii_lowercase();
    if s.contains("strawberry") {
        1
    } else if s.contains("perl64") || s.contains("activestate") || s.contains("activeperl") {
        2
    } else if s.contains(r"\git\usr\bin") || s.contains("/git/usr/bin") || s.contains("msys") {
        100
    } else {
        50
    }
}

/// Collect all Perl executables found on PATH, ranked for Windows preference.
///
/// On Windows, returns all matches sorted by [`windows_perl_rank`] so the caller
/// can pick the best one. On non-Windows, returns candidates in PATH order (no ranking).
fn find_all_perl_on_path(path_env: &str) -> Vec<PathBuf> {
    #[allow(unused_mut)]
    let mut found: Vec<PathBuf> = path_env
        .split(PATH_SEPARATOR)
        .filter_map(normalize_path_entry)
        .map(|dir| dir.join(PERL_EXECUTABLE))
        .filter(|p| p.exists() && p.is_file())
        .collect();

    #[cfg(windows)]
    found.sort_by_key(|p| windows_perl_rank(p));

    found
}

/// Normalize a single PATH segment by trimming whitespace/quotes and dropping empties.
fn normalize_path_entry(entry: &str) -> Option<PathBuf> {
    let trimmed = entry.trim().trim_matches('"');
    if trimmed.is_empty() {
        return None;
    }

    Some(PathBuf::from(trimmed))
}

/// Canonical OS-specific fallback paths to probe when Perl is not on PATH.
///
/// Returns `(path, label)` pairs. Probed in order; first existing file wins.
fn fallback_perl_paths() -> Vec<(PathBuf, &'static str)> {
    #[cfg(windows)]
    {
        vec![
            (PathBuf::from(r"C:\Strawberry\perl\bin\perl.exe"), "Strawberry Perl"),
            (PathBuf::from(r"C:\Perl64\bin\perl.exe"), "ActiveState Perl (64-bit)"),
            (
                {
                    let pf = env::var("ProgramFiles")
                        .unwrap_or_else(|_| r"C:\Program Files".to_string());
                    PathBuf::from(pf).join(r"Strawberry\perl\bin\perl.exe")
                },
                "Strawberry Perl (Program Files)",
            ),
        ]
    }
    #[cfg(target_os = "macos")]
    {
        vec![
            (PathBuf::from("/opt/homebrew/bin/perl"), "Homebrew Perl (Apple Silicon)"),
            (PathBuf::from("/usr/local/bin/perl"), "Homebrew Perl (Intel)"),
            (PathBuf::from("/usr/bin/perl"), "macOS system Perl"),
        ]
    }
    #[cfg(target_os = "android")]
    {
        // Android (Termux)
        vec![
            (PathBuf::from("/data/data/com.termux/files/usr/bin/perl"), "Termux Perl"),
            (PathBuf::from("/data/user/0/com.termux/files/usr/bin/perl"), "Termux Perl"),
        ]
    }
    #[cfg(all(not(windows), not(target_os = "macos"), not(target_os = "android")))]
    {
        // Linux and others
        vec![
            (PathBuf::from("/usr/bin/perl"), "system Perl"),
            (PathBuf::from("/usr/local/bin/perl"), "local Perl"),
        ]
    }
}

/// Find the best available Perl interpreter with full cross-platform detection.
///
/// Detection order:
/// 1. If `configured_path` is `Some` and non-empty, validate and return
///    [`PerlInterpreterResult::ConfiguredPath`] (or [`PerlInterpreterResult::NotFound`]
///    if the configured path is broken). Does **not** fall back silently.
/// 2. Check toolchain managers (perlbrew, plenv) before PATH.
/// 3. Walk PATH; on Windows, prefer Strawberry/ActiveState over msys/Git Bash perls.
/// 4. If not on PATH, probe canonical OS install locations as a last resort.
/// 5. If still not found, return [`PerlInterpreterResult::NotFound`] with searched paths.
pub fn find_perl_interpreter(configured_path: Option<&str>) -> PerlInterpreterResult {
    // 1. Honour explicit config path — validate it exists, never silently fall back.
    if let Some(cfg) = configured_path.map(str::trim).filter(|s| !s.is_empty()) {
        let p = PathBuf::from(cfg);
        if p.exists() && p.is_file() {
            return PerlInterpreterResult::ConfiguredPath(p);
        } else {
            return PerlInterpreterResult::NotFound {
                searched: vec![format!("configured path: {cfg}")],
            };
        }
    }

    let mut searched: Vec<String> = vec!["PATH".to_string()];

    // 2. Check toolchain managers (perlbrew, plenv) first.
    if let Some(path) = detect_perlbrew_perl() {
        return PerlInterpreterResult::FoundOnPath(path);
    }
    if let Some(path) = detect_plenv_perl() {
        return PerlInterpreterResult::FoundOnPath(path);
    }

    // 3. Walk PATH, ranking results on Windows.
    if let Ok(path_env) = env::var("PATH") {
        let ranked = find_all_perl_on_path(&path_env);
        if let Some(best) = ranked.into_iter().next() {
            return PerlInterpreterResult::FoundOnPath(best);
        }
    }

    // 4. Probe OS-specific fallback paths.
    for (path, label) in fallback_perl_paths() {
        searched.push(path.to_string_lossy().to_string());
        if path.exists() && path.is_file() {
            return PerlInterpreterResult::FoundViaFallback { path, label: label.to_string() };
        }
    }

    PerlInterpreterResult::NotFound { searched }
}

/// Cached variant of [`find_perl_interpreter`].
///
/// This avoids repeated PATH/toolchain scans during repeated launch failures in
/// the same environment while still invalidating when key discovery inputs
/// (PATH, toolchain environment, configured path) change.
///
/// # Concurrency
///
/// The cache uses a simple check-then-compute-then-store pattern with two
/// separate lock acquisitions. Two concurrent callers racing on a cold cache
/// will both run [`find_perl_interpreter`] and the second write wins. This is
/// intentional: the correctness invariant is that callers always receive a
/// valid result for the current environment, not that exactly one subprocess
/// is spawned per cache entry. A condvar/OnceLock approach would complicate the
/// API without measurable benefit for the low-frequency DAP launch path.
pub fn find_perl_interpreter_cached(configured_path: Option<&str>) -> PerlInterpreterResult {
    let cache_key = perl_discovery_cache_key(configured_path);

    if let Ok(cache) = PERL_INTERPRETER_CACHE.lock()
        && let Some((cached_key, cached_result)) = cache.as_ref()
        && *cached_key == cache_key
    {
        return cached_result.clone();
    }

    let resolved = find_perl_interpreter(configured_path);
    if let Ok(mut cache) = PERL_INTERPRETER_CACHE.lock() {
        *cache = Some((cache_key, resolved.clone()));
    }
    resolved
}

#[cfg(test)]
fn resolve_perl_path_from_path_env(path_env: &str) -> anyhow::Result<PathBuf> {
    for path_dir in path_env.split(PATH_SEPARATOR).filter_map(normalize_path_entry) {
        let perl_path = path_dir.join(PERL_EXECUTABLE);
        if perl_path.exists() && perl_path.is_file() {
            return Ok(perl_path);
        }
    }

    anyhow::bail!(perl_not_found_install_message())
}

#[cfg(test)]
/// End-user remediation guidance shown when no Perl interpreter is available.
fn perl_not_found_install_message() -> &'static str {
    "perl binary not found on PATH. Install Perl via https://strawberryperl.com (Windows), \
`brew install perl` (macOS), `pkg install perl` in Termux (Android), or your distro package manager, then add it to PATH."
}

/// Normalize a file path for cross-platform compatibility.
pub fn normalize_path(path: &std::path::Path) -> PathBuf {
    #[cfg(target_os = "linux")]
    {
        if let Some(path_str) = path.to_str()
            && path_str.starts_with("/mnt/")
            && path_str.len() > 6
        {
            let drive_letter = &path_str[5..6];
            let rest = &path_str[6..];
            let windows_path =
                format!("{}:{}", drive_letter.to_uppercase(), rest.replace('/', "\\"));
            return PathBuf::from(windows_path);
        }
    }

    #[cfg(windows)]
    {
        if let Some(path_str) = path.to_str() {
            if path_str.len() >= 2
                && path_str.chars().nth(1) == Some(':')
                && let Some(first_char) = path_str.chars().next()
            {
                let drive_letter = first_char.to_uppercase();
                let rest = &path_str[1..];
                return PathBuf::from(format!("{}{}", drive_letter, rest));
            }

            if path_str.starts_with("\\\\") {
                return path.to_path_buf();
            }
        }
    }

    #[cfg(not(windows))]
    {
        if let Ok(canonical) = path.canonicalize() {
            return canonical;
        }
    }

    path.to_path_buf()
}

/// Setup environment variables for Perl execution.
pub fn setup_environment(include_paths: &[PathBuf]) -> HashMap<String, String> {
    let mut env = HashMap::new();

    if !include_paths.is_empty() {
        let perl5lib = include_paths
            .iter()
            .map(|p| p.to_string_lossy().to_string())
            .collect::<Vec<_>>()
            .join(&PATH_SEPARATOR.to_string());

        env.insert("PERL5LIB".to_string(), perl5lib);
    }

    env
}

#[cfg(test)]
#[allow(clippy::panic)]
mod tests {
    use super::*;
    use perl_tdd_support::{must, must_err};

    #[test]
    fn test_resolve_perl_path() {
        if let Ok(path) = resolve_perl_path() {
            assert!(path.exists());
            assert!(path.is_file());
        }
    }

    #[test]
    fn test_normalize_path_basic() {
        let normalized = normalize_path(&PathBuf::from("script.pl"));
        assert!(!normalized.as_os_str().is_empty());
    }

    #[test]
    fn test_setup_environment_empty() {
        let env = setup_environment(&[]);
        assert!(!env.contains_key("PERL5LIB"));
    }

    #[test]
    fn test_setup_environment_with_paths() {
        let env =
            setup_environment(&[PathBuf::from("/workspace/lib"), PathBuf::from("/custom/lib")]);
        assert!(env.contains_key("PERL5LIB"));
    }

    #[test]
    fn resolve_from_path_env_finds_perl_in_first_dir() {
        use std::fs;
        let tempdir = must(tempfile::tempdir());
        let bin = tempdir.path().join(PERL_EXECUTABLE);
        must(fs::write(&bin, ""));
        #[cfg(unix)]
        {
            use std::os::unix::fs::PermissionsExt;
            let mut perms = must(fs::metadata(&bin)).permissions();
            perms.set_mode(0o755);
            must(fs::set_permissions(&bin, perms));
        }
        let path_str = tempdir.path().to_string_lossy().to_string();
        let result = resolve_perl_path_from_path_env(&path_str);
        assert_eq!(must(result), bin);
    }

    #[test]
    fn resolve_from_path_env_empty_path_returns_error() {
        let result = resolve_perl_path_from_path_env("");
        assert!(result.is_err());
        let msg = format!("{}", must_err(result));
        assert!(
            msg.contains("perl") || msg.contains("PATH"),
            "error should mention perl/PATH: {msg}"
        );
        assert!(msg.contains("strawberryperl.com"), "error should include install guidance: {msg}");
    }

    #[test]
    fn resolve_from_path_env_no_perl_on_path_returns_error() {
        let tempdir = must(tempfile::tempdir());
        let path_str = tempdir.path().to_string_lossy().to_string();
        let result = resolve_perl_path_from_path_env(&path_str);
        assert!(result.is_err());
    }

    #[test]
    fn resolve_from_path_env_handles_quoted_path_segment() {
        use std::fs;
        let tempdir = must(tempfile::tempdir());
        let bin = tempdir.path().join(PERL_EXECUTABLE);
        must(fs::write(&bin, ""));
        #[cfg(unix)]
        {
            use std::os::unix::fs::PermissionsExt;
            let mut perms = must(fs::metadata(&bin)).permissions();
            perms.set_mode(0o755);
            must(fs::set_permissions(&bin, perms));
        }
        let quoted_path = format!("\"{}\"", tempdir.path().to_string_lossy());
        let result = resolve_perl_path_from_path_env(&quoted_path);
        assert_eq!(must(result), bin);
    }

    #[test]
    fn normalize_path_entry_trims_whitespace_and_quotes() {
        let raw = "  \"/tmp/perl path\"  ";
        let normalized = normalize_path_entry(raw);
        assert_eq!(normalized, Some(PathBuf::from("/tmp/perl path")));
    }

    #[test]
    fn normalize_path_entry_rejects_empty_segments() {
        assert_eq!(normalize_path_entry(""), None);
        assert_eq!(normalize_path_entry("   "), None);
        assert_eq!(normalize_path_entry("\"\""), None);
    }

    #[test]
    #[cfg(target_os = "linux")]
    fn normalize_path_wsl_mnt_translated_to_windows_style() {
        let wsl_path = std::path::Path::new("/mnt/c/Users/user/script.pl");
        let normalized = normalize_path(wsl_path);
        let s = normalized.to_string_lossy();
        assert!(
            s.starts_with("C:\\") || s.starts_with("C:/"),
            "expected Windows-style path, got: {s}"
        );
        assert!(s.contains("Users"), "path content preserved: {s}");
    }

    #[test]
    fn normalize_path_non_wsl_unix_path_unchanged_on_linux() {
        let path = std::path::Path::new("/usr/local/bin/perl");
        let normalized = normalize_path(path);
        assert!(
            !normalized.to_string_lossy().contains('\\'),
            "non-WSL path should not be Windows-escaped"
        );
    }

    // ── find_perl_interpreter tests ────────────────────────────────────────

    #[test]
    fn find_perl_interpreter_configured_path_valid_returns_configured() {
        use std::fs;
        let tempdir = must(tempfile::tempdir());
        let fake_perl = tempdir.path().join(PERL_EXECUTABLE);
        must(fs::write(&fake_perl, ""));
        #[cfg(unix)]
        {
            use std::os::unix::fs::PermissionsExt;
            let mut perms = must(fs::metadata(&fake_perl)).permissions();
            perms.set_mode(0o755);
            must(fs::set_permissions(&fake_perl, perms));
        }
        let path_str = fake_perl.to_string_lossy().to_string();
        let result = find_perl_interpreter(Some(&path_str));
        assert!(
            matches!(result, PerlInterpreterResult::ConfiguredPath(_)),
            "expected ConfiguredPath, got: {result:?}"
        );
    }

    #[test]
    fn find_perl_interpreter_configured_path_missing_returns_not_found() {
        let result = find_perl_interpreter(Some("/nonexistent/path/to/perl"));
        assert!(
            matches!(result, PerlInterpreterResult::NotFound { .. }),
            "expected NotFound, got: {result:?}"
        );
        let PerlInterpreterResult::NotFound { searched } = result else {
            return;
        };
        assert!(
            searched.iter().any(|s| s.contains("configured")),
            "searched list should mention configured path: {searched:?}"
        );
    }

    #[test]
    fn find_perl_interpreter_empty_config_falls_back_to_path_detection() {
        let result = find_perl_interpreter(Some(""));
        assert!(
            !matches!(result, PerlInterpreterResult::ConfiguredPath(_)),
            "empty config should fall back to path detection"
        );
    }

    #[test]
    fn find_perl_interpreter_whitespace_config_falls_back_to_path_detection() {
        let result = find_perl_interpreter(Some("   	  "));
        assert!(
            !matches!(result, PerlInterpreterResult::ConfiguredPath(_)),
            "whitespace-only config should fall back to path detection"
        );
    }

    #[test]
    fn find_perl_interpreter_none_config_performs_detection() {
        let result = find_perl_interpreter(None);
        assert!(
            !matches!(result, PerlInterpreterResult::ConfiguredPath(_)),
            "None config should not return ConfiguredPath"
        );
    }

    #[test]
    fn find_perl_interpreter_not_found_includes_searched_paths() {
        let result = find_perl_interpreter(Some("/absolutely/not/a/real/path/perl"));
        if let PerlInterpreterResult::NotFound { searched } = result {
            assert!(!searched.is_empty(), "searched list should not be empty");
        }
    }

    #[test]
    #[cfg(target_os = "android")]
    fn fallback_perl_paths_include_termux_locations() {
        let paths = fallback_perl_paths();
        let path_strings: Vec<String> =
            paths.into_iter().map(|(path, _)| path.to_string_lossy().to_string()).collect();

        assert!(
            path_strings.iter().any(|p| p == "/data/data/com.termux/files/usr/bin/perl"),
            "expected /data/data/com.termux/files/usr/bin/perl in fallback paths"
        );
        assert!(
            path_strings.iter().any(|p| p == "/data/user/0/com.termux/files/usr/bin/perl"),
            "expected /data/user/0/com.termux/files/usr/bin/perl in fallback paths"
        );
    }

    #[test]
    #[cfg(windows)]
    fn windows_perl_rank_strawberry_is_best() {
        let strawberry = std::path::Path::new(r"C:\Strawberry\perl\bin\perl.exe");
        let msys = std::path::Path::new(r"C:\Program Files\Git\usr\bin\perl.exe");
        assert!(
            windows_perl_rank(strawberry) < windows_perl_rank(msys),
            "Strawberry should rank better than msys perl"
        );
    }

    #[test]
    #[cfg(windows)]
    fn windows_perl_rank_activestate_beats_msys() {
        let active = std::path::Path::new(r"C:\Perl64\bin\perl.exe");
        let msys = std::path::Path::new(r"C:\Program Files\Git\usr\bin\perl.exe");
        assert!(
            windows_perl_rank(active) < windows_perl_rank(msys),
            "ActiveState should rank better than msys perl"
        );
    }

    /// Verify that USERPROFILE and PREFIX changes produce different cache keys.
    ///
    /// On Windows, HOME is typically absent and home_dir() falls back to
    /// USERPROFILE to resolve the perlbrew/plenv default root.  The PREFIX
    /// variable is used by the Termux path resolver.  Both must appear in the
    /// cache key so that a changed user profile or Termux prefix invalidates
    /// a stale cached result.
    #[test]
    fn discovery_cache_key_contains_userprofile_and_prefix() {
        // Synthetic keys that differ only in userprofile or prefix must differ.
        let base = "cfg=;path=;perlbrew_perl=;perlbrew_root=;plenv_root=;plenv_version=;home=;userprofile=;prefix=";
        let with_profile = "cfg=;path=;perlbrew_perl=;perlbrew_root=;plenv_root=;plenv_version=;home=;userprofile=C_Users_alice;prefix=";
        let with_prefix = "cfg=;path=;perlbrew_perl=;perlbrew_root=;plenv_root=;plenv_version=;home=;userprofile=;prefix=/data/data/com.termux/files/usr";
        assert_ne!(base, with_profile, "key must differ when userprofile changes");
        assert_ne!(base, with_prefix, "key must differ when prefix changes");
        assert!(base.contains("userprofile="), "key must contain userprofile= field");
        assert!(base.contains("prefix="), "key must contain prefix= field");
    }
}