pathhelp.pm (6243B)
1 ########################################################################### 2 # _ _ ____ _ 3 # Project ___| | | | _ \| | 4 # / __| | | | |_) | | 5 # | (__| |_| | _ <| |___ 6 # \___|\___/|_| \_\_____| 7 # 8 # Copyright (C) Evgeny Grin (Karlson2k), <k2k@narod.ru>. 9 # 10 # This software is licensed as described in the file COPYING, which 11 # you should have received as part of this distribution. The terms 12 # are also available at https://curl.se/docs/copyright.html. 13 # 14 # You may opt to use, copy, modify, merge, publish, distribute and/or sell 15 # copies of the Software, and permit persons to whom the Software is 16 # furnished to do so, under the terms of the COPYING file. 17 # 18 # This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY 19 # KIND, either express or implied. 20 # 21 # SPDX-License-Identifier: curl 22 # 23 ########################################################################### 24 25 # This Perl package helps with path transforming when running curl tests on 26 # native Windows and MSYS/Cygwin. 27 # Following input formats are supported (via built-in Perl functions): 28 # (1) /some/path - absolute path in POSIX-style 29 # (2) D:/some/path - absolute path in Windows-style 30 # (3) some/path - relative path 31 # (4) D:some/path - path relative to current directory on Windows drive 32 # (paths like 'D:' are treated as 'D:./') (*) 33 # (5) \some/path - path from root directory on current Windows drive (*) 34 # All forward '/' and back '\' slashes are treated identically except leading 35 # slash in forms (1) and (5). 36 # Forward slashes are simpler processed in Perl, do not require extra escaping 37 # for shell (unlike back slashes) and accepted by Windows native programs, so 38 # all functions return paths with only forward slashes. 39 # All returned paths don't contain any duplicated slashes, only single slashes 40 # are used as directory separators on output. 41 # On non-Windows platforms functions acts as transparent wrappers for similar 42 # Perl's functions or return unmodified string (depending on functionality), 43 # so all functions can be unconditionally used on all platforms. 44 # 45 # (*) CAUTION! Forms (4) and (5) are not recommended to use as they can be 46 # interpreted incorrectly in Perl and MSYS/Cygwin environment have low 47 # control on Windows current drive and Windows current path on specific 48 # drive. 49 50 package pathhelp; 51 52 use strict; 53 use warnings; 54 use File::Spec; 55 56 BEGIN { 57 use base qw(Exporter); 58 59 our @EXPORT_OK = qw( 60 os_is_win 61 exe_ext 62 dirsepadd 63 sys_native_abs_path 64 sys_native_current_path 65 build_sys_abs_path 66 ); 67 } 68 69 70 ####################################################################### 71 # Block for cached static variables 72 # 73 { 74 # Cached static variable, Perl 5.0-compatible. 75 my $is_win = $^O eq 'MSWin32' 76 || $^O eq 'cygwin' 77 || $^O eq 'msys'; 78 79 # Returns boolean true if OS is any form of Windows. 80 sub os_is_win { 81 return $is_win; 82 } 83 84 # Cached static variable, Perl 5.0-compatible. 85 my $cygdrive_present; 86 87 # Returns boolean true if Windows drives mounted with '/cygdrive/' prefix. 88 sub drives_mounted_on_cygdrive { 89 return $cygdrive_present if defined $cygdrive_present; 90 $cygdrive_present = ((-e '/cygdrive/') && (-d '/cygdrive/')) ? 1 : 0; 91 return $cygdrive_present; 92 } 93 } 94 95 ####################################################################### 96 # Returns current working directory in Windows format on Windows. 97 # 98 sub sys_native_current_path { 99 return Cwd::getcwd() if !os_is_win(); 100 101 my $cur_dir; 102 if($^O eq 'MSWin32') { 103 $cur_dir = Cwd::getcwd(); 104 } 105 else { 106 $cur_dir = Cygwin::posix_to_win_path(Cwd::getcwd()); 107 } 108 $cur_dir =~ s{[/\\]+}{/}g; 109 return $cur_dir; 110 } 111 112 ####################################################################### 113 # Converts given path to system native absolute path, i.e. to Windows 114 # absolute format on Windows platform. Both relative and absolute 115 # formats are supported for input. 116 # 117 sub sys_native_abs_path { 118 my ($path) = @_; 119 120 # Return untouched on non-Windows platforms. 121 return File::Spec->rel2abs($path) if !os_is_win(); 122 123 # Do not process empty path. 124 return $path if($path eq ''); 125 126 my $res; 127 if($^O eq 'msys' || $^O eq 'cygwin') { 128 $res = Cygwin::posix_to_win_path(File::Spec->rel2abs($path)); 129 } 130 elsif($path =~ m{^/(cygdrive/)?([a-z])/(.*)}) { 131 $res = uc($2) . ":/" . $3; 132 } 133 else { 134 $res = File::Spec->rel2abs($path); 135 } 136 137 $res =~ s{[/\\]+}{/}g; 138 return $res; 139 } 140 141 ####################################################################### 142 # Converts given path to build system format absolute path, i.e. to 143 # MSYS/Cygwin POSIX-style absolute format on Windows platform. Both 144 # relative and absolute formats are supported for input. 145 # 146 sub build_sys_abs_path { 147 my ($path) = @_; 148 149 # Return untouched on non-Windows platforms. 150 return File::Spec->rel2abs($path) if !os_is_win(); 151 152 my $res; 153 if($^O eq 'msys' || $^O eq 'cygwin') { 154 $res = Cygwin::win_to_posix_path($path, 1); 155 } 156 else { 157 $res = File::Spec->rel2abs($path); 158 159 if($res =~ m{^([A-Za-z]):(.*)}) { 160 $res = "/" . lc($1) . $2; 161 $res = '/cygdrive' . $res if(drives_mounted_on_cygdrive()); 162 } 163 } 164 165 return $res; 166 } 167 168 #*************************************************************************** 169 # Return file extension for executable files on this operating system 170 # 171 sub exe_ext { 172 my ($component, @arr) = @_; 173 if($ENV{'CURL_TEST_EXE_EXT'}) { 174 return $ENV{'CURL_TEST_EXE_EXT'}; 175 } 176 if($ENV{'CURL_TEST_EXE_EXT_'.$component}) { 177 return $ENV{'CURL_TEST_EXE_EXT_'.$component}; 178 } 179 if($^O eq 'MSWin32' || $^O eq 'cygwin' || $^O eq 'msys' || 180 $^O eq 'dos' || $^O eq 'os2') { 181 return '.exe'; 182 } 183 return ''; 184 } 185 186 #*************************************************************************** 187 # Add ending slash if missing 188 # 189 sub dirsepadd { 190 my ($dir) = @_; 191 $dir =~ s/\/$//; 192 return $dir . '/'; 193 } 194 195 1; # End of module