curl/tests/pathhelp.pm
Dan Fandrich 64936919b9 tests: Fix Windows test helper tool search & use it for handle64
The checkcmd() and checktestcmd() functions would not have worked on
Windows due to hard-coding the UNIX PATH separator character and not
adding .exe file extension. This meant that tools like stunnel, valgrind
and nghttpx would not have been found and used on Windows, and
inspection of previous test runs show none of those being found in pure
Windows CI builds.

With this fixed, they can be used to detect the handle64.exe program
before attempting to use it. When handle64.exe was called
unconditionally without it existing, it caused perl to abort the test
run with the error

    The running command stopped because the preference variable
    "ErrorActionPreference" or common parameter is set to Stop:
    sh: handle64.exe: command not found

Closes #12115
2023-10-17 12:27:21 -07:00

796 lines
26 KiB
Perl

###########################################################################
# _ _ ____ _
# Project ___| | | | _ \| |
# / __| | | | |_) | |
# | (__| |_| | _ <| |___
# \___|\___/|_| \_\_____|
#
# Copyright (C) Evgeny Grin (Karlson2k), <k2k@narod.ru>.
#
# This software is licensed as described in the file COPYING, which
# you should have received as part of this distribution. The terms
# are also available at https://curl.se/docs/copyright.html.
#
# You may opt to use, copy, modify, merge, publish, distribute and/or sell
# copies of the Software, and permit persons to whom the Software is
# furnished to do so, under the terms of the COPYING file.
#
# This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY
# KIND, either express or implied.
#
# SPDX-License-Identifier: curl
#
###########################################################################
# This Perl package helps with path transforming when running curl tests on
# Win32 platform with Msys or Cygwin.
# Three main functions 'sys_native_abs_path', 'sys_native_path' and
# 'build_sys_abs_path' autodetect format of given pathnames. Following formats
# are supported:
# (1) /some/path - absolute path in Unix-style
# (2) D:/some/path - absolute path in Win32-style
# (3) some/path - relative path
# (4) D:some/path - path relative to current directory on Win32 drive (paths
# like 'D:' are treated as 'D:./') (*)
# (5) \some/path - path from root directory on current Win32 drive (*)
# All forward '/' and back '\' slashes are treated identically except leading
# slash in forms (1) and (5).
# Forward slashes are simpler processed in Perl, do not require extra escaping
# for shell (unlike back slashes) and accepted by Win32 native programs, so
# all functions return paths with only forward slashes except
# 'sys_native_path' which returns paths with first forward slash for form (5).
# All returned paths don't contain any duplicated slashes, only single slashes
# are used as directory separators on output.
# On non-Windows platforms functions acts as transparent wrappers for similar
# Perl's functions or return unmodified string (depending on functionality),
# so all functions can be unconditionally used on all platforms.
#
# (*) CAUTION! Forms (4) and (5) are not recommended to use as they can be
# interpreted incorrectly in Perl and Msys/Cygwin environment have low
# control on Win32 current drive and Win32 current path on specific drive.
package pathhelp;
use strict;
use warnings;
use Cwd 'abs_path';
BEGIN {
use base qw(Exporter);
our @EXPORT_OK = qw(
os_is_win
exe_ext
sys_native_abs_path
sys_native_current_path
build_sys_abs_path
normalize_path
should_use_cygpath
drives_mounted_on_cygdrive
);
}
#######################################################################
# Block for cached static variables
#
{
# Cached static variable, Perl 5.0-compatible.
my $is_win = $^O eq 'MSWin32'
|| $^O eq 'cygwin'
|| $^O eq 'msys';
# Returns boolean true if OS is any form of Windows.
sub os_is_win {
return $is_win;
}
# Cached static variable, Perl 5.0-compatible.
my $cygdrive_present;
# Returns boolean true if Win32 drives mounted with '/cygdrive/' prefix.
sub drives_mounted_on_cygdrive {
return $cygdrive_present if defined $cygdrive_present;
$cygdrive_present = ((-e '/cygdrive/') && (-d '/cygdrive/')) ? 1 : 0;
return $cygdrive_present;
}
}
my $use_cygpath; # Only for Win32:
# undef - autodetect
# 0 - do not use cygpath
# 1 - use cygpath
# Returns boolean true if 'cygpath' utility should be used for path conversion.
sub should_use_cygpath {
return $use_cygpath if defined $use_cygpath;
if(os_is_win()) {
$use_cygpath = (qx{cygpath -u '.\\' 2>/dev/null} eq "./\n" && $? == 0);
} else {
$use_cygpath = 0;
}
return $use_cygpath;
}
#######################################################################
# Performs path "normalization": all slashes converted to forward
# slashes (except leading slash), all duplicated slashes are replaced
# with single slashes, all relative directories ('./' and '../') are
# resolved if possible.
# Path processed as string, directories are not checked for presence so
# path for not yet existing directory can be "normalized".
#
sub normalize_path;
#######################################################################
# Returns current working directory in Win32 format on Windows.
#
sub sys_native_current_path {
return Cwd::getcwd() if !os_is_win();
my $cur_dir;
if($^O eq 'msys') {
# MSys shell has built-in command.
chomp($cur_dir = `bash -c 'pwd -W'`);
if($? != 0) {
warn "Can't determine Win32 current directory.\n";
return undef;
}
# Add final slash if required.
$cur_dir .= '/' if length($cur_dir) > 3;
}
else {
# Do not use 'cygpath' - it falsely succeed on paths like '/cygdrive'.
$cur_dir = `cmd "/c;" echo %__CD__%`;
if($? != 0 || substr($cur_dir, 0, 1) eq '%') {
warn "Can't determine Win32 current directory.\n";
return undef;
}
# Remove both '\r' and '\n'.
$cur_dir =~ s{\n|\r}{}g;
# Replace back slashes with forward slashes.
$cur_dir =~ s{\\}{/}g;
}
return $cur_dir;
}
#######################################################################
# Returns Win32 current drive letter with colon.
#
sub get_win32_current_drive {
# Notice parameter "/c;" - it's required to turn off Msys's
# transformation of '/c' and compatible with Cygwin.
my $drive_letter = `cmd "/c;" echo %__CD__:~0,2%`;
if($? != 0 || substr($drive_letter, 1, 1) ne ':') {
warn "Can't determine current Win32 drive letter.\n";
return undef;
}
return substr($drive_letter, 0, 2);
}
# Internal function. Converts path by using Msys's built-in transformation.
# Returned path may contain duplicated and back slashes.
sub do_msys_transform;
# Internal function. Gets two parameters: first parameter must be single
# drive letter ('c'), second optional parameter is path relative to drive's
# current working directory. Returns Win32 absolute normalized path.
sub get_abs_path_on_win32_drive;
# Internal function. Tries to find or guess Win32 version of given
# absolute Unix-style path. Other types of paths are not supported.
# Returned paths contain only single forward slashes (no back and
# duplicated slashes).
# Last resort. Used only when other transformations are not available.
sub do_dumb_guessed_transform;
#######################################################################
# Converts given path to system native format, i.e. to Win32 format on
# Windows platform. Relative paths converted to relative, absolute
# paths converted to absolute.
#
sub sys_native_path {
my ($path) = @_;
# Return untouched on non-Windows platforms.
return $path if (!os_is_win());
# Do not process empty path.
return $path if ($path eq '');
if($path =~ s{^([a-zA-Z]):$}{\u$1:}) {
# Path is single drive with colon. (C:)
# This type of paths is not processed correctly by 'cygpath'.
# WARNING!
# Be careful, this relative path can be accidentally transformed
# into wrong absolute path by adding to it some '/dirname' with
# slash at font.
return $path;
}
elsif($path =~ m{^\\} || $path =~ m{^[a-zA-Z]:[^/\\]}) {
# Path is a directory or filename on Win32 current drive or relative
# path on current directory on specific Win32 drive.
# ('\path' or 'D:path')
# First type of paths is not processed by Msys transformation and
# resolved to absolute path by 'cygpath'.
# Second type is not processed by Msys transformation and may be
# incorrectly processed by 'cygpath' (for paths like 'D:..\../.\')
my $first_char = ucfirst(substr($path, 0, 1));
# Replace any back and duplicated slashes with single forward slashes.
$path =~ s{[\\/]+}{/}g;
# Convert leading slash back to forward slash to indicate
# directory on Win32 current drive or capitalize drive letter.
substr($path, 0, 1, $first_char);
return $path;
}
elsif(should_use_cygpath()) {
# 'cygpath' is available - use it.
# Remove leading duplicated forward and back slashes, as they may
# prevent transforming and may be not processed.
$path =~ s{^([\\/])[\\/]+}{$1}g;
my $has_final_slash = ($path =~ m{[/\\]$});
# Use 'cygpath', '-m' means Win32 path with forward slashes.
chomp($path = `cygpath -m '$path'`);
if ($? != 0) {
warn "Can't convert path by \"cygpath\".\n";
return undef;
}
# 'cygpath' may remove last slash for existing directories.
$path .= '/' if($has_final_slash);
# Remove any duplicated forward slashes (added by 'cygpath' for root
# directories)
$path =~ s{//+}{/}g;
return $path;
}
elsif($^O eq 'msys') {
# Msys transforms automatically path to Windows native form in staring
# program parameters if program is not Msys-based.
$path = do_msys_transform($path);
return undef if !defined $path;
# Capitalize drive letter for Win32 paths.
$path =~ s{^([a-z]:)}{\u$1};
# Replace any back and duplicated slashes with single forward slashes.
$path =~ s{[\\/]+}{/}g;
return $path;
}
elsif($path =~ s{^([a-zA-Z]):[/\\]}{\u$1:/}) {
# Path is already in Win32 form. ('C:\path')
# Replace any back and duplicated slashes with single forward slashes.
$path =~ s{[\\/]+}{/}g;
return $path;
}
elsif($path !~ m{^/}) {
# Path is in relative form. ('path/name', './path' or '../path')
# Replace any back and duplicated slashes with single forward slashes.
$path =~ s{[\\/]+}{/}g;
return $path;
}
# OS is Windows, but not Msys, path is absolute, path is not in Win32
# form and 'cygpath' is not available.
return do_dumb_guessed_transform($path);
}
#######################################################################
# Converts given path to system native absolute path, i.e. to Win32
# absolute format on Windows platform. Both relative and absolute
# formats are supported for input.
#
sub sys_native_abs_path {
my ($path) = @_;
if(!os_is_win()) {
# Convert path to absolute form.
$path = Cwd::abs_path($path);
# Do not process further on non-Windows platforms.
return $path;
}
if($path =~ m{^([a-zA-Z]):($|[^/\\].*$)}) {
# Path is single drive with colon or relative path on Win32 drive.
# ('C:' or 'C:path')
# This kind of relative path is not processed correctly by 'cygpath'.
# Get specified drive letter
return get_abs_path_on_win32_drive($1, $2);
}
elsif($path eq '') {
# Path is empty string. Return current directory.
# Empty string processed correctly by 'cygpath'.
return sys_native_current_path();
}
elsif(should_use_cygpath()) {
# 'cygpath' is available - use it.
my $has_final_slash = ($path =~ m{[\\/]$});
# Remove leading duplicated forward and back slashes, as they may
# prevent transforming and may be not processed.
$path =~ s{^([\\/])[\\/]+}{$1}g;
print "Inter result: \"$path\"\n";
# Use 'cygpath', '-m' means Win32 path with forward slashes,
# '-a' means absolute path
chomp($path = `cygpath -m -a '$path'`);
if($? != 0) {
warn "Can't resolve path by usung \"cygpath\".\n";
return undef;
}
# 'cygpath' may remove last slash for existing directories.
$path .= '/' if($has_final_slash);
# Remove any duplicated forward slashes (added by 'cygpath' for root
# directories)
$path =~ s{//+}{/}g;
return $path
}
elsif($path =~ s{^([a-zA-Z]):[/\\]}{\u$1:/}) {
# Path is already in Win32 form. ('C:\path')
# Replace any possible back slashes with forward slashes,
# remove any duplicated slashes, resolve relative dirs.
return normalize_path($path);
}
elsif(substr($path, 0, 1) eq '\\' ) {
# Path is directory or filename on Win32 current drive. ('\Windows')
my $w32drive = get_win32_current_drive();
return undef if !defined $w32drive;
# Combine drive and path.
# Replace any possible back slashes with forward slashes,
# remove any duplicated slashes, resolve relative dirs.
return normalize_path($w32drive . $path);
}
if(substr($path, 0, 1) ne '/') {
# Path is in relative form. Resolve relative directories in Unix form
# *BEFORE* converting to Win32 form otherwise paths like
# '../../../cygdrive/c/windows' will not be resolved.
my $cur_dir;
# MSys shell has built-in command.
if($^O eq 'msys') {
$cur_dir = `bash -c 'pwd -L'`;
}
else {
$cur_dir = `pwd -L`;
}
if($? != 0) {
warn "Can't determine current working directory.\n";
return undef;
}
chomp($cur_dir);
$path = $cur_dir . '/' . $path;
}
# Resolve relative dirs.
$path = normalize_path($path);
return undef unless defined $path;
if($^O eq 'msys') {
# Msys transforms automatically path to Windows native form in staring
# program parameters if program is not Msys-based.
$path = do_msys_transform($path);
return undef if !defined $path;
# Replace any back and duplicated slashes with single forward slashes.
$path =~ s{[\\/]+}{/}g;
return $path;
}
# OS is Windows, but not Msys, path is absolute, path is not in Win32
# form and 'cygpath' is not available.
return do_dumb_guessed_transform($path);
}
# Internal function. Converts given Unix-style absolute path to Win32 format.
sub simple_transform_win32_to_unix;
#######################################################################
# Converts given path to build system format absolute path, i.e. to
# Msys/Cygwin Unix-style absolute format on Windows platform. Both
# relative and absolute formats are supported for input.
#
sub build_sys_abs_path {
my ($path) = @_;
if(!os_is_win()) {
# Convert path to absolute form.
$path = Cwd::abs_path($path);
# Do not process further on non-Windows platforms.
return $path;
}
if($path =~ m{^([a-zA-Z]):($|[^/\\].*$)}) {
# Path is single drive with colon or relative path on Win32 drive.
# ('C:' or 'C:path')
# This kind of relative path is not processed correctly by 'cygpath'.
# Get specified drive letter
# Resolve relative dirs in Win32-style path or paths like 'D:/../c/'
# will be resolved incorrectly.
# Replace any possible back slashes with forward slashes,
# remove any duplicated slashes.
$path = get_abs_path_on_win32_drive($1, $2);
return undef if !defined $path;
return simple_transform_win32_to_unix($path);
}
elsif($path eq '') {
# Path is empty string. Return current directory.
# Empty string processed correctly by 'cygpath'.
# MSys shell has built-in command.
if($^O eq 'msys') {
chomp($path = `bash -c 'pwd -L'`);
}
else {
chomp($path = `pwd -L`);
}
if($? != 0) {
warn "Can't determine Unix-style current working directory.\n";
return undef;
}
# Add final slash if not at root dir.
$path .= '/' if length($path) > 2;
return $path;
}
elsif(should_use_cygpath()) {
# 'cygpath' is available - use it.
my $has_final_slash = ($path =~ m{[\\/]$});
# Resolve relative directories, as they may be not resolved for
# Unix-style paths.
# Remove duplicated slashes, as they may be not processed.
$path = normalize_path($path);
return undef if !defined $path;
# Use 'cygpath', '-u' means Unix-stile path,
# '-a' means absolute path
chomp($path = `cygpath -u -a '$path'`);
if($? != 0) {
warn "Can't resolve path by usung \"cygpath\".\n";
return undef;
}
# 'cygpath' removes last slash if path is root dir on Win32 drive.
# Restore it.
$path .= '/' if($has_final_slash &&
substr($path, length($path) - 1, 1) ne '/');
return $path
}
elsif($path =~ m{^[a-zA-Z]:[/\\]}) {
# Path is already in Win32 form. ('C:\path')
# Resolve relative dirs in Win32-style path otherwise paths
# like 'D:/../c/' will be resolved incorrectly.
# Replace any possible back slashes with forward slashes,
# remove any duplicated slashes.
$path = normalize_path($path);
return undef if !defined $path;
return simple_transform_win32_to_unix($path);
}
elsif(substr($path, 0, 1) eq '\\') {
# Path is directory or filename on Win32 current drive. ('\Windows')
my $w32drive = get_win32_current_drive();
return undef if !defined $w32drive;
# Combine drive and path.
# Resolve relative dirs in Win32-style path or paths like 'D:/../c/'
# will be resolved incorrectly.
# Replace any possible back slashes with forward slashes,
# remove any duplicated slashes.
$path = normalize_path($w32drive . $path);
return undef if !defined $path;
return simple_transform_win32_to_unix($path);
}
# Path is not in any Win32 form.
if(substr($path, 0, 1) ne '/') {
# Path in relative form. Resolve relative directories in Unix form
# *BEFORE* converting to Win32 form otherwise paths like
# '../../../cygdrive/c/windows' will not be resolved.
my $cur_dir;
# MSys shell has built-in command.
if($^O eq 'msys') {
$cur_dir = `bash -c 'pwd -L'`;
}
else {
$cur_dir = `pwd -L`;
}
if($? != 0) {
warn "Can't determine current working directory.\n";
return undef;
}
chomp($cur_dir);
$path = $cur_dir . '/' . $path;
}
return normalize_path($path);
}
#######################################################################
# Performs path "normalization": all slashes converted to forward
# slashes (except leading slash), all duplicated slashes are replaced
# with single slashes, all relative directories ('./' and '../') are
# resolved if possible.
# Path processed as string, directories are not checked for presence so
# path for not yet existing directory can be "normalized".
#
sub normalize_path {
my ($path) = @_;
# Don't process empty paths.
return $path if $path eq '';
if($path !~ m{(?:^|\\|/)\.{1,2}(?:\\|/|$)}) {
# Speed up processing of simple paths.
my $first_char = substr($path, 0, 1);
$path =~ s{[\\/]+}{/}g;
# Restore starting backslash if any.
substr($path, 0, 1, $first_char);
return $path;
}
my @arr;
my $prefix;
my $have_root = 0;
# Check whether path starts from Win32 drive. ('C:path' or 'C:\path')
if($path =~ m{^([a-zA-Z]:(/|\\)?)(.*$)}) {
$prefix = $1;
$have_root = 1 if defined $2;
# Process path separately from drive letter.
@arr = split(m{\/|\\}, $3);
# Replace backslash with forward slash if required.
substr($prefix, 2, 1, '/') if $have_root;
}
else {
if($path =~ m{^(\/|\\)}) {
$have_root = 1;
$prefix = $1;
}
else {
$prefix = '';
}
@arr = split(m{\/|\\}, $path);
}
my $p = 0;
my @res;
for my $el (@arr) {
if(length($el) == 0 || $el eq '.') {
next;
}
elsif($el eq '..' && @res > 0 && $res[-1] ne '..') {
pop @res;
next;
}
push @res, $el;
}
if($have_root && @res > 0 && $res[0] eq '..') {
warn "Error processing path \"$path\": " .
"Parent directory of root directory does not exist!\n";
return undef;
}
my $ret = $prefix . join('/', @res);
$ret .= '/' if($path =~ m{\\$|/$} && scalar @res > 0);
return $ret;
}
# Internal function. Converts path by using Msys's built-in
# transformation.
sub do_msys_transform {
my ($path) = @_;
return undef if $^O ne 'msys';
return $path if $path eq '';
# Remove leading double forward slashes, as they turn off Msys
# transforming.
$path =~ s{^/[/\\]+}{/};
# Msys transforms automatically path to Windows native form in staring
# program parameters if program is not Msys-based.
# Note: already checked that $path is non-empty.
$path = `cmd //c echo '$path'`;
if($? != 0) {
warn "Can't transform path into Win32 form by using Msys" .
"internal transformation.\n";
return undef;
}
# Remove double quotes, they are added for paths with spaces,
# remove both '\r' and '\n'.
$path =~ s{^\"|\"$|\"\r|\n|\r}{}g;
return $path;
}
# Internal function. Gets two parameters: first parameter must be single
# drive letter ('c'), second optional parameter is path relative to drive's
# current working directory. Returns Win32 absolute normalized path.
sub get_abs_path_on_win32_drive {
my ($drv, $rel_path) = @_;
my $res;
# Get current directory on specified drive.
# "/c;" is compatible with both Msys and Cygwin.
my $cur_dir_on_drv = `cmd "/c;" echo %=$drv:%`;
if($? != 0) {
warn "Can't determine Win32 current directory on drive $drv:.\n";
return undef;
}
if($cur_dir_on_drv =~ m{^[%]}) {
# Current directory on drive is not set, default is
# root directory.
$res = ucfirst($drv) . ':/';
}
else {
# Current directory on drive was set.
# Remove both '\r' and '\n'.
$cur_dir_on_drv =~ s{\n|\r}{}g;
# Append relative path part.
$res = $cur_dir_on_drv . '/';
}
$res .= $rel_path if defined $rel_path;
# Replace any possible back slashes with forward slashes,
# remove any duplicated slashes, resolve relative dirs.
return normalize_path($res);
}
# Internal function. Tries to find or guess Win32 version of given
# absolute Unix-style path. Other types of paths are not supported.
# Returned paths contain only single forward slashes (no back and
# duplicated slashes).
# Last resort. Used only when other transformations are not available.
sub do_dumb_guessed_transform {
my ($path) = @_;
# Replace any possible back slashes and duplicated forward slashes
# with single forward slashes.
$path =~ s{[/\\]+}{/}g;
# Empty path is not valid.
return undef if (length($path) == 0);
# RE to find Win32 drive letter
my $drv_ltr_re = drives_mounted_on_cygdrive() ?
qr{^/cygdrive/([a-zA-Z])($|/.*$)} :
qr{^/([a-zA-Z])($|/.*$)};
# Check path whether path is Win32 directly mapped drive and try to
# transform it assuming that drive letter is matched to Win32 drive letter.
if($path =~ m{$drv_ltr_re}) {
return ucfirst($1) . ':/' if(length($2) == 0);
return ucfirst($1) . ':' . $2;
}
# This may be some custom mapped path. ('/mymount/path')
# Must check longest possible path component as subdir can be mapped to
# different directory. For example '/usr/bin/' can be mapped to '/bin/' or
# '/bin/' can be mapped to '/usr/bin/'.
my $check_path = $path;
my $path_tail = '';
while(1) {
if(-d $check_path) {
my $res =
`(cd "$check_path" && cmd /c "echo %__CD__%") 2>/dev/null`;
if($? == 0 && substr($path, 0, 1) ne '%') {
# Remove both '\r' and '\n'.
$res =~ s{\n|\r}{}g;
# Replace all back slashes with forward slashes.
$res =~ s{\\}{/}g;
if(length($path_tail) > 0) {
return $res . $path_tail;
}
else {
$res =~ s{/$}{} if $check_path !~ m{/$};
return $res;
}
}
}
if($check_path =~ m{(^.*/)([^/]+/*)}) {
$check_path = $1;
$path_tail = $2 . $path_tail;
}
else {
# Shouldn't happens as root '/' directory should always
# be resolvable.
warn "Can't determine Win32 directory for path \"$path\".\n";
return undef;
}
}
}
# Internal function. Converts given Unix-style absolute path to Win32 format.
sub simple_transform_win32_to_unix {
my ($path) = @_;
if(should_use_cygpath()) {
# 'cygpath' gives precise result.
my $res;
chomp($res = `cygpath -a -u '$path'`);
if($? != 0) {
warn "Can't determine Unix-style directory for Win32 " .
"directory \"$path\".\n";
return undef;
}
# 'cygpath' removes last slash if path is root dir on Win32 drive.
$res .= '/' if(substr($res, length($res) - 1, 1) ne '/' &&
$path =~ m{[/\\]$});
return $res;
}
# 'cygpath' is not available, use guessed transformation.
if($path !~ s{^([a-zA-Z]):(?:/|\\)}{/\l$1/}) {
warn "Can't determine Unix-style directory for Win32 " .
"directory \"$path\".\n";
return undef;
}
$path = '/cygdrive' . $path if(drives_mounted_on_cygdrive());
return $path;
}
#
#***************************************************************************
# Return file extension for executable files on this operating system
#
sub exe_ext {
my ($component, @arr) = @_;
if ($ENV{'CURL_TEST_EXE_EXT'}) {
return $ENV{'CURL_TEST_EXE_EXT'};
}
if ($ENV{'CURL_TEST_EXE_EXT_'.$component}) {
return $ENV{'CURL_TEST_EXE_EXT_'.$component};
}
if ($^O eq 'MSWin32' || $^O eq 'cygwin' || $^O eq 'msys' ||
$^O eq 'dos' || $^O eq 'os2') {
return '.exe';
}
return '';
}
1; # End of module