view release on metacpan or  search on metacpan

lib/BATsh/Env.pm  view on Meta::CPAN

        if ($star eq '*') {
            my $pos = index(lc($val), lc($str1));
            if ($pos >= 0) {
                return $str2 . substr($val, $pos + length($str1));
            }
            return $val;
        }
        else {
            my $lval  = lc($val);
            my $lstr1 = lc($str1);
            my $pos   = index($lval, $lstr1);
            if ($pos >= 0) {
                return substr($val, 0, $pos) . $str2
                     . substr($val, $pos + length($str1));
            }
            return $val;
        }
    }

    # Unrecognised modifier: return as-is
    return '%' . $varname . ':' . $modifier . '%';
}

# Uses File::Spec (platform-aware) and a hand-rolled path splitter so
# that Windows-style paths work correctly on Windows and Unix-style
# paths work on Unix without requiring Win32-specific modules.
# ----------------------------------------------------------------
sub _expand_tilde_param {
    my ($mods, $n) = @_;
    my $key = "%$n";
    my $val = exists($STORE{$key}) ? $STORE{$key} : '';

    # Always strip surrounding double-quotes first
    $val =~ s/\A"//;
    $val =~ s/"\z//;

    # With no recognised modifiers, just return the dequoted value
    return $val unless $mods =~ /[fdpnx]/;

    # --- Normalise: extract drive letter first, then convert \ to / ---
    # Extracting the drive before splitting avoids "C:" being treated as
    # a path component and re-attached incorrectly.
    my $drv  = '';        # e.g. "C:" on Windows, "" on Unix
    my $path = $val;
    $path =~ s{\\}{/}g;  # normalise separators
    if ($path =~ s{\A([A-Za-z]:)}{}) { $drv = $1 }

    # --- resolve to absolute path when f/d/p requested ---
    if ($mods =~ /[fdp]/) {
        unless ($path =~ m{\A/} || $drv ne '') {
            # relative Unix path: prepend cwd
            my $cwd = BATsh::MB::enc(defined(&Cwd::cwd) ? Cwd::cwd() : '.');
            $cwd =~ s{\\}{/}g;
            $cwd =~ s{/+\z}{};
            $path = "$cwd/$path";
        }
        # Ensure exactly one leading slash
        $path = "/$path" unless $path =~ m{\A/};
        # Collapse . and ..
        my @segs;
        for my $p (split m{/+}, $path) {
            next if $p eq '' || $p eq '.';
            if ($p eq '..') { pop @segs if @segs }
            else             { push @segs, $p }
        }
        $path = '/' . join('/', @segs);
        $path = '/' if $path eq '/';
    }

    # --- split path into directory and filename ---
    my ($dirs, $file) = ('', '');
    if ($path =~ m{\A(.*/)([^/]*)\z}) {
        ($dirs, $file) = ($1, $2);
    }
    else {
        $file = $path;
    }

    # --- split filename into base and extension ---
    my ($base, $ext) = ('', '');
    if ($file =~ m{\A(.+)(\.[^.]+)\z}) {
        ($base, $ext) = ($1, $2);
    }
    else {
        $base = $file;
    }

    # --- build result ---
    if ($mods =~ /f/) {
        # Full absolute path: drive + dirs + file
        # dirs already ends with / when non-root
        return $drv . $dirs . $file;
    }

    my $result = '';
    $result .= $drv  if $mods =~ /d/;
    $result .= $dirs if $mods =~ /p/;
    $result .= $base if $mods =~ /n/;
    $result .= $ext  if $mods =~ /x/;
    return $result;
}

# ----------------------------------------------------------------
# expand_sh: $VAR and ${VAR} (SH mode)
# ----------------------------------------------------------------
sub expand_sh {
    my ($class, $str) = @_;
    return '' unless defined $str;
    $str =~ s/\$\{([A-Za-z_][A-Za-z0-9_]*)\}/
        do { my $k=$1; defined($STORE{$k}) ? $STORE{$k} : defined($STORE{uc($k)}) ? $STORE{uc($k)} : '' }
    /ge;
    $str =~ s/\$([A-Za-z_][A-Za-z0-9_]*)/
        do { my $k=$1; defined($STORE{$k}) ? $STORE{$k} : defined($STORE{uc($k)}) ? $STORE{uc($k)} : '' }
    /ge;
    return $str;
}

1;

__END__