Annotation of embedaddon/curl/tests/pathhelp.pm, revision 1.1
1.1 ! misho 1: ###########################################################################
! 2: # _ _ ____ _
! 3: # Project ___| | | | _ \| |
! 4: # / __| | | | |_) | |
! 5: # | (__| |_| | _ <| |___
! 6: # \___|\___/|_| \_\_____|
! 7: #
! 8: # Copyright (C) 2016 - 2020, 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.haxx.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: ###########################################################################
! 22:
! 23: # This Perl package helps with path transforming when running curl tests on
! 24: # Win32 platform with Msys or Cygwin.
! 25: # Three main functions 'sys_native_abs_path', 'sys_native_path' and
! 26: # 'build_sys_abs_path' autodetect format of given pathnames. Following formats
! 27: # are supported:
! 28: # (1) /some/path - absolute path in Unix-style
! 29: # (2) D:/some/path - absolute path in Win32-style
! 30: # (3) some/path - relative path
! 31: # (4) D:some/path - path relative to current directory on Win32 drive (paths
! 32: # like 'D:' are treated as 'D:./') (*)
! 33: # (5) \some/path - path from root directory on current Win32 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 Win32 native programs, so
! 38: # all functions return paths with only forward slashes except
! 39: # 'sys_native_path' which returns paths with first forward slash for form (5).
! 40: # All returned paths don't contain any duplicated slashes, only single slashes
! 41: # are used as directory separators on output.
! 42: # On non-Windows platforms functions acts as transparent wrappers for similar
! 43: # Perl's functions or return unmodified string (depending on functionality),
! 44: # so all functions can be unconditionally used on all platforms.
! 45: #
! 46: # (*) CAUTION! Forms (4) and (5) are not recommended to use as they can be
! 47: # interpreted incorrectly in Perl and Msys/Cygwin environment have low
! 48: # control on Win32 current drive and Win32 current path on specific drive.
! 49:
! 50:
! 51: package pathhelp;
! 52: use strict;
! 53: use warnings;
! 54: use Cwd 'abs_path';
! 55:
! 56: BEGIN {
! 57: require Exporter;
! 58:
! 59: our @ISA = qw(Exporter);
! 60:
! 61: our @EXPORT = qw(
! 62: sys_native_abs_path
! 63: sys_native_path
! 64: );
! 65:
! 66: our @EXPORT_OK = qw(
! 67: build_sys_abs_path
! 68: sys_native_current_path
! 69: normalize_path
! 70: os_is_win
! 71: $use_cygpath
! 72: should_use_cygpath
! 73: drives_mounted_on_cygdrive
! 74: );
! 75: }
! 76:
! 77:
! 78: #######################################################################
! 79: # Block for cached static variables
! 80: #
! 81: {
! 82: # Cached static variable, Perl 5.0-compatible.
! 83: my $is_win = $^O eq 'MSWin32'
! 84: || $^O eq 'cygwin'
! 85: || $^O eq 'msys';
! 86:
! 87: # Returns boolean true if OS is any form of Windows.
! 88: sub os_is_win {
! 89: return $is_win;
! 90: }
! 91:
! 92: # Cached static variable, Perl 5.0-compatible.
! 93: my $cygdrive_present;
! 94:
! 95: # Returns boolean true if Win32 drives mounted with '/cygdrive/' prefix.
! 96: sub drives_mounted_on_cygdrive {
! 97: return $cygdrive_present if defined $cygdrive_present;
! 98: $cygdrive_present = ((-e '/cygdrive/') && (-d '/cygdrive/')) ? 1 : 0;
! 99: return $cygdrive_present;
! 100: }
! 101: }
! 102:
! 103: our $use_cygpath; # Only for Win32:
! 104: # undef - autodetect
! 105: # 1 - use cygpath
! 106: # 0 - do not use cygpath
! 107:
! 108: # Returns boolean true if 'cygpath' utility should be used for path conversion.
! 109: sub should_use_cygpath {
! 110: unless (os_is_win()) {
! 111: $use_cygpath = 0;
! 112: return 0;
! 113: }
! 114: return $use_cygpath if defined $use_cygpath;
! 115:
! 116: $use_cygpath = (qx{cygpath -u '.\\' 2>/dev/null} eq "./\n" && $? == 0);
! 117:
! 118: return $use_cygpath;
! 119: }
! 120:
! 121: #######################################################################
! 122: # Performs path "normalization": all slashes converted to forward
! 123: # slashes (except leading slash), all duplicated slashes are replaced
! 124: # with single slashes, all relative directories ('./' and '../') are
! 125: # resolved if possible.
! 126: # Path processed as string, directories are not checked for presence so
! 127: # path for not yet existing directory can be "normalized".
! 128: #
! 129: sub normalize_path;
! 130:
! 131: #######################################################################
! 132: # Returns current working directory in Win32 format on Windows.
! 133: #
! 134: sub sys_native_current_path {
! 135: return Cwd::getcwd() unless os_is_win();
! 136:
! 137: my $cur_dir;
! 138: if($^O eq 'msys') {
! 139: # MSys shell has built-in command.
! 140: chomp($cur_dir = `bash -c 'pwd -W'`);
! 141: if($? != 0) {
! 142: warn "Can't determine Win32 current directory.\n";
! 143: return undef;
! 144: }
! 145: # Add final slash if required.
! 146: $cur_dir .= '/' if length($cur_dir) > 3;
! 147: }
! 148: else {
! 149: # Do not use 'cygpath' - it falsely succeed on paths like '/cygdrive'.
! 150: $cur_dir = `cmd "/c;" echo %__CD__%`;
! 151: if($? != 0 || substr($cur_dir, 0, 1) eq '%') {
! 152: warn "Can't determine Win32 current directory.\n";
! 153: return undef;
! 154: }
! 155: # Remove both '\r' and '\n'.
! 156: $cur_dir =~ s{\n|\r}{}g;
! 157:
! 158: # Replace back slashes with forward slashes.
! 159: $cur_dir =~ s{\\}{/}g;
! 160: }
! 161: return $cur_dir;
! 162: }
! 163:
! 164: #######################################################################
! 165: # Returns Win32 current drive letter with colon.
! 166: #
! 167: sub get_win32_current_drive {
! 168: # Notice parameter "/c;" - it's required to turn off Msys's
! 169: # transformation of '/c' and compatible with Cygwin.
! 170: my $drive_letter = `cmd "/c;" echo %__CD__:~0,2%`;
! 171: if($? != 0 || substr($drive_letter, 1, 1) ne ':') {
! 172: warn "Can't determine current Win32 drive letter.\n";
! 173: return undef;
! 174: }
! 175:
! 176: return substr($drive_letter, 0, 2);
! 177: }
! 178:
! 179: # Internal function. Converts path by using Msys's built-in transformation.
! 180: # Returned path may contain duplicated and back slashes.
! 181: sub do_msys_transform;
! 182:
! 183: # Internal function. Gets two parameters: first parameter must be single
! 184: # drive letter ('c'), second optional parameter is path relative to drive's
! 185: # current working directory. Returns Win32 absolute normalized path.
! 186: sub get_abs_path_on_win32_drive;
! 187:
! 188: # Internal function. Tries to find or guess Win32 version of given
! 189: # absolute Unix-style path. Other types of paths are not supported.
! 190: # Returned paths contain only single forward slashes (no back and
! 191: # duplicated slashes).
! 192: # Last resort. Used only when other transformations are not available.
! 193: sub do_dumb_guessed_transform;
! 194:
! 195: #######################################################################
! 196: # Converts given path to system native format, i.e. to Win32 format on
! 197: # Windows platform. Relative paths converted to relative, absolute
! 198: # paths converted to absolute.
! 199: #
! 200: sub sys_native_path {
! 201: my ($path) = @_;
! 202:
! 203: # Return untouched on non-Windows platforms.
! 204: return $path unless (os_is_win());
! 205:
! 206: # Do not process empty path.
! 207: return $path if ($path eq '');
! 208:
! 209: if($path =~ s{^([a-zA-Z]):$}{\u$1:}) {
! 210: # Path is single drive with colon. (C:)
! 211: # This type of paths is not processed correctly by 'cygpath'.
! 212: # WARNING!
! 213: # Be careful, this relative path can be accidentally transformed
! 214: # into wrong absolute path by adding to it some '/dirname' with
! 215: # slash at font.
! 216: return $path;
! 217: }
! 218: elsif($path =~ m{^\\} || $path =~ m{^[a-zA-Z]:[^/\\]}) {
! 219: # Path is a directory or filename on Win32 current drive or relative
! 220: # path on current directory on specific Win32 drive.
! 221: # ('\path' or 'D:path')
! 222: # First type of paths is not processed by Msys transformation and
! 223: # resolved to absolute path by 'cygpath'.
! 224: # Second type is not processed by Msys transformation and may be
! 225: # incorrectly processed by 'cygpath' (for paths like 'D:..\../.\')
! 226:
! 227: my $first_char = ucfirst(substr($path, 0, 1));
! 228:
! 229: # Replace any back and duplicated slashes with single forward slashes.
! 230: $path =~ s{[\\/]+}{/}g;
! 231:
! 232: # Convert leading slash back to forward slash to indicate
! 233: # directory on Win32 current drive or capitalize drive letter.
! 234: substr($path, 0, 1) = $first_char;
! 235: return $path;
! 236: }
! 237: elsif(should_use_cygpath()) {
! 238: # 'cygpath' is available - use it.
! 239:
! 240: # Remove leading duplicated forward and back slashes, as they may
! 241: # prevent transforming and may be not processed.
! 242: $path =~ s{^([\\/])[\\/]+}{$1}g;
! 243:
! 244: my $has_final_slash = ($path =~ m{[/\\]$});
! 245:
! 246: # Use 'cygpath', '-m' means Win32 path with forward slashes.
! 247: chomp($path = `cygpath -m '$path'`);
! 248: if ($? != 0) {
! 249: warn "Can't convert path by \"cygpath\".\n";
! 250: return undef;
! 251: }
! 252:
! 253: # 'cygpath' may remove last slash for existing directories.
! 254: $path .= '/' if($has_final_slash);
! 255:
! 256: # Remove any duplicated forward slashes (added by 'cygpath' for root
! 257: # directories)
! 258: $path =~ s{//+}{/}g;
! 259:
! 260: return $path;
! 261: }
! 262: elsif($^O eq 'msys') {
! 263: # Msys transforms automatically path to Windows native form in staring
! 264: # program parameters if program is not Msys-based.
! 265:
! 266: $path = do_msys_transform($path);
! 267: return undef unless defined $path;
! 268:
! 269: # Capitalize drive letter for Win32 paths.
! 270: $path =~ s{^([a-z]:)}{\u$1};
! 271:
! 272: # Replace any back and duplicated slashes with single forward slashes.
! 273: $path =~ s{[\\/]+}{/}g;
! 274: return $path;
! 275: }
! 276: elsif($path =~ s{^([a-zA-Z]):[/\\]}{\u$1:/}) {
! 277: # Path is already in Win32 form. ('C:\path')
! 278:
! 279: # Replace any back and duplicated slashes with single forward slashes.
! 280: $path =~ s{[\\/]+}{/}g;
! 281: return $path;
! 282: }
! 283: elsif($path !~ m{^/}) {
! 284: # Path is in relative form. ('path/name', './path' or '../path')
! 285:
! 286: # Replace any back and duplicated slashes with single forward slashes.
! 287: $path =~ s{[\\/]+}{/}g;
! 288: return $path;
! 289: }
! 290:
! 291: # OS is Windows, but not Msys, path is absolute, path is not in Win32
! 292: # form and 'cygpath' is not available.
! 293: return do_dumb_guessed_transform($path);
! 294: }
! 295:
! 296: #######################################################################
! 297: # Converts given path to system native absolute path, i.e. to Win32
! 298: # absolute format on Windows platform. Both relative and absolute
! 299: # formats are supported for input.
! 300: #
! 301: sub sys_native_abs_path {
! 302: my ($path) = @_;
! 303:
! 304: unless(os_is_win()) {
! 305: # Convert path to absolute form.
! 306: $path = Cwd::abs_path($path);
! 307:
! 308: # Do not process further on non-Windows platforms.
! 309: return $path;
! 310: }
! 311:
! 312: if($path =~ m{^([a-zA-Z]):($|[^/\\].*$)}) {
! 313: # Path is single drive with colon or relative path on Win32 drive.
! 314: # ('C:' or 'C:path')
! 315: # This kind of relative path is not processed correctly by 'cygpath'.
! 316: # Get specified drive letter
! 317: return get_abs_path_on_win32_drive($1, $2);
! 318: }
! 319: elsif($path eq '') {
! 320: # Path is empty string. Return current directory.
! 321: # Empty string processed correctly by 'cygpath'.
! 322:
! 323: return sys_native_current_path();
! 324: }
! 325: elsif(should_use_cygpath()) {
! 326: # 'cygpath' is available - use it.
! 327:
! 328: my $has_final_slash = ($path =~ m{[\\/]$});
! 329:
! 330: # Remove leading duplicated forward and back slashes, as they may
! 331: # prevent transforming and may be not processed.
! 332: $path =~ s{^([\\/])[\\/]+}{$1}g;
! 333:
! 334: print "Inter result: \"$path\"\n";
! 335: # Use 'cygpath', '-m' means Win32 path with forward slashes,
! 336: # '-a' means absolute path
! 337: chomp($path = `cygpath -m -a '$path'`);
! 338: if($? != 0) {
! 339: warn "Can't resolve path by usung \"cygpath\".\n";
! 340: return undef;
! 341: }
! 342:
! 343: # 'cygpath' may remove last slash for existing directories.
! 344: $path .= '/' if($has_final_slash);
! 345:
! 346: # Remove any duplicated forward slashes (added by 'cygpath' for root
! 347: # directories)
! 348: $path =~ s{//+}{/}g;
! 349:
! 350: return $path
! 351: }
! 352: elsif($path =~ s{^([a-zA-Z]):[/\\]}{\u$1:/}) {
! 353: # Path is already in Win32 form. ('C:\path')
! 354:
! 355: # Replace any possible back slashes with forward slashes,
! 356: # remove any duplicated slashes, resolve relative dirs.
! 357: return normalize_path($path);
! 358: }
! 359: elsif(substr($path, 0, 1) eq '\\' ) {
! 360: # Path is directory or filename on Win32 current drive. ('\Windows')
! 361:
! 362: my $w32drive = get_win32_current_drive();
! 363: return undef unless defined $w32drive;
! 364:
! 365: # Combine drive and path.
! 366: # Replace any possible back slashes with forward slashes,
! 367: # remove any duplicated slashes, resolve relative dirs.
! 368: return normalize_path($w32drive . $path);
! 369: }
! 370:
! 371: unless (substr($path, 0, 1) eq '/') {
! 372: # Path is in relative form. Resolve relative directories in Unix form
! 373: # *BEFORE* converting to Win32 form otherwise paths like
! 374: # '../../../cygdrive/c/windows' will not be resolved.
! 375: my $cur_dir = `pwd -L`;
! 376: if($? != 0) {
! 377: warn "Can't determine current working directory.\n";
! 378: return undef;
! 379: }
! 380: chomp($cur_dir);
! 381:
! 382: $path = $cur_dir . '/' . $path;
! 383: }
! 384:
! 385: # Resolve relative dirs.
! 386: $path = normalize_path($path);
! 387: return undef unless defined $path;
! 388:
! 389: if($^O eq 'msys') {
! 390: # Msys transforms automatically path to Windows native form in staring
! 391: # program parameters if program is not Msys-based.
! 392: $path = do_msys_transform($path);
! 393: return undef unless defined $path;
! 394:
! 395: # Replace any back and duplicated slashes with single forward slashes.
! 396: $path =~ s{[\\/]+}{/}g;
! 397: return $path;
! 398: }
! 399: # OS is Windows, but not Msys, path is absolute, path is not in Win32
! 400: # form and 'cygpath' is not available.
! 401:
! 402: return do_dumb_guessed_transform($path);
! 403: }
! 404:
! 405: # Internal function. Converts given Unix-style absolute path to Win32 format.
! 406: sub simple_transform_win32_to_unix;
! 407:
! 408: #######################################################################
! 409: # Converts given path to build system format absolute path, i.e. to
! 410: # Msys/Cygwin Unix-style absolute format on Windows platform. Both
! 411: # relative and absolute formats are supported for input.
! 412: #
! 413: sub build_sys_abs_path {
! 414: my ($path) = @_;
! 415:
! 416: unless(os_is_win()) {
! 417: # Convert path to absolute form.
! 418: $path = Cwd::abs_path($path);
! 419:
! 420: # Do not process further on non-Windows platforms.
! 421: return $path;
! 422: }
! 423:
! 424: if($path =~ m{^([a-zA-Z]):($|[^/\\].*$)}) {
! 425: # Path is single drive with colon or relative path on Win32 drive.
! 426: # ('C:' or 'C:path')
! 427: # This kind of relative path is not processed correctly by 'cygpath'.
! 428: # Get specified drive letter
! 429:
! 430: # Resolve relative dirs in Win32-style path or paths like 'D:/../c/'
! 431: # will be resolved incorrectly.
! 432: # Replace any possible back slashes with forward slashes,
! 433: # remove any duplicated slashes.
! 434: $path = get_abs_path_on_win32_drive($1, $2);
! 435: return undef unless defined $path;
! 436:
! 437: return simple_transform_win32_to_unix($path);
! 438: }
! 439: elsif($path eq '') {
! 440: # Path is empty string. Return current directory.
! 441: # Empty string processed correctly by 'cygpath'.
! 442:
! 443: chomp($path = `pwd -L`);
! 444: if($? != 0) {
! 445: warn "Can't determine Unix-style current working directory.\n";
! 446: return undef;
! 447: }
! 448:
! 449: # Add final slash if not at root dir.
! 450: $path .= '/' if length($path) > 2;
! 451: return $path;
! 452: }
! 453: elsif(should_use_cygpath()) {
! 454: # 'cygpath' is available - use it.
! 455:
! 456: my $has_final_slash = ($path =~ m{[\\/]$});
! 457:
! 458: # Resolve relative directories, as they may be not resolved for
! 459: # Unix-style paths.
! 460: # Remove duplicated slashes, as they may be not processed.
! 461: $path = normalize_path($path);
! 462: return undef unless defined $path;
! 463:
! 464: # Use 'cygpath', '-u' means Unix-stile path,
! 465: # '-a' means absolute path
! 466: chomp($path = `cygpath -u -a '$path'`);
! 467: if($? != 0) {
! 468: warn "Can't resolve path by usung \"cygpath\".\n";
! 469: return undef;
! 470: }
! 471:
! 472: # 'cygpath' removes last slash if path is root dir on Win32 drive.
! 473: # Restore it.
! 474: $path .= '/' if($has_final_slash &&
! 475: substr($path, length($path) - 1, 1) ne '/');
! 476:
! 477: return $path
! 478: }
! 479: elsif($path =~ m{^[a-zA-Z]:[/\\]}) {
! 480: # Path is already in Win32 form. ('C:\path')
! 481:
! 482: # Resolve relative dirs in Win32-style path otherwise paths
! 483: # like 'D:/../c/' will be resolved incorrectly.
! 484: # Replace any possible back slashes with forward slashes,
! 485: # remove any duplicated slashes.
! 486: $path = normalize_path($path);
! 487: return undef unless defined $path;
! 488:
! 489: return simple_transform_win32_to_unix($path);
! 490: }
! 491: elsif(substr($path, 0, 1) eq '\\') {
! 492: # Path is directory or filename on Win32 current drive. ('\Windows')
! 493:
! 494: my $w32drive = get_win32_current_drive();
! 495: return undef unless defined $w32drive;
! 496:
! 497: # Combine drive and path.
! 498: # Resolve relative dirs in Win32-style path or paths like 'D:/../c/'
! 499: # will be resolved incorrectly.
! 500: # Replace any possible back slashes with forward slashes,
! 501: # remove any duplicated slashes.
! 502: $path = normalize_path($w32drive . $path);
! 503: return undef unless defined $path;
! 504:
! 505: return simple_transform_win32_to_unix($path);
! 506: }
! 507:
! 508: # Path is not in any Win32 form.
! 509: unless (substr($path, 0, 1) eq '/') {
! 510: # Path in relative form. Resolve relative directories in Unix form
! 511: # *BEFORE* converting to Win32 form otherwise paths like
! 512: # '../../../cygdrive/c/windows' will not be resolved.
! 513: my $cur_dir = `pwd -L`;
! 514: if($? != 0) {
! 515: warn "Can't determine current working directory.\n";
! 516: return undef;
! 517: }
! 518: chomp($cur_dir);
! 519:
! 520: $path = $cur_dir . '/' . $path;
! 521: }
! 522:
! 523: return normalize_path($path);
! 524: }
! 525:
! 526: #######################################################################
! 527: # Performs path "normalization": all slashes converted to forward
! 528: # slashes (except leading slash), all duplicated slashes are replaced
! 529: # with single slashes, all relative directories ('./' and '../') are
! 530: # resolved if possible.
! 531: # Path processed as string, directories are not checked for presence so
! 532: # path for not yet existing directory can be "normalized".
! 533: #
! 534: sub normalize_path {
! 535: my ($path) = @_;
! 536:
! 537: # Don't process empty paths.
! 538: return $path if $path eq '';
! 539:
! 540: unless($path =~ m{(?:^|\\|/)\.{1,2}(?:\\|/|$)}) {
! 541: # Speed up processing of simple paths.
! 542: my $first_char = substr($path, 0, 1);
! 543: $path =~ s{[\\/]+}{/}g;
! 544: # Restore starting backslash if any.
! 545: substr($path, 0, 1) = $first_char;
! 546: return $path;
! 547: }
! 548:
! 549: my @arr;
! 550: my $prefix;
! 551: my $have_root = 0;
! 552:
! 553: # Check whether path starts from Win32 drive. ('C:path' or 'C:\path')
! 554: if($path =~ m{^([a-zA-Z]:(/|\\)?)(.*$)}) {
! 555: $prefix = $1;
! 556: $have_root = 1 if defined $2;
! 557: # Process path separately from drive letter.
! 558: @arr = split(m{\/|\\}, $3);
! 559: # Replace backslash with forward slash if required.
! 560: substr($prefix, 2, 1) = '/' if $have_root;
! 561: }
! 562: else {
! 563: if($path =~ m{^(\/|\\)}) {
! 564: $have_root = 1;
! 565: $prefix = $1;
! 566: }
! 567: else {
! 568: $prefix = '';
! 569: }
! 570: @arr = split(m{\/|\\}, $path);
! 571: }
! 572:
! 573: my $p = 0;
! 574: my @res;
! 575:
! 576: for my $el (@arr) {
! 577: if(length($el) == 0 || $el eq '.') {
! 578: next;
! 579: }
! 580: elsif($el eq '..' && @res > 0 && $res[$#res] ne '..') {
! 581: pop @res;
! 582: next;
! 583: }
! 584: push @res, $el;
! 585: }
! 586: if($have_root && @res > 0 && $res[0] eq '..') {
! 587: warn "Error processing path \"$path\": " .
! 588: "Parent directory of root directory does not exist!\n";
! 589: return undef;
! 590: }
! 591:
! 592: my $ret = $prefix . join('/', @res);
! 593: $ret .= '/' if($path =~ m{\\$|/$} && scalar @res > 0);
! 594:
! 595: return $ret;
! 596: }
! 597:
! 598: # Internal function. Converts path by using Msys's built-in
! 599: # transformation.
! 600: sub do_msys_transform {
! 601: my ($path) = @_;
! 602: return undef if $^O ne 'msys';
! 603: return $path if $path eq '';
! 604:
! 605: # Remove leading double forward slashes, as they turn off Msys
! 606: # transforming.
! 607: $path =~ s{^/[/\\]+}{/};
! 608:
! 609: # Msys transforms automatically path to Windows native form in staring
! 610: # program parameters if program is not Msys-based.
! 611: # Note: already checked that $path is non-empty.
! 612: $path = `cmd //c echo '$path'`;
! 613: if($? != 0) {
! 614: warn "Can't transform path into Win32 form by using Msys" .
! 615: "internal transformation.\n";
! 616: return undef;
! 617: }
! 618:
! 619: # Remove double quotes, they are added for paths with spaces,
! 620: # remove both '\r' and '\n'.
! 621: $path =~ s{^\"|\"$|\"\r|\n|\r}{}g;
! 622:
! 623: return $path;
! 624: }
! 625:
! 626: # Internal function. Gets two parameters: first parameter must be single
! 627: # drive letter ('c'), second optional parameter is path relative to drive's
! 628: # current working directory. Returns Win32 absolute normalized path.
! 629: sub get_abs_path_on_win32_drive {
! 630: my ($drv, $rel_path) = @_;
! 631: my $res;
! 632:
! 633: # Get current directory on specified drive.
! 634: # "/c;" is compatible with both Msys and Cygwin.
! 635: my $cur_dir_on_drv = `cmd "/c;" echo %=$drv:%`;
! 636: if($? != 0) {
! 637: warn "Can't determine Win32 current directory on drive $drv:.\n";
! 638: return undef;
! 639: }
! 640:
! 641: if($cur_dir_on_drv =~ m{^[%]}) {
! 642: # Current directory on drive is not set, default is
! 643: # root directory.
! 644:
! 645: $res = ucfirst($drv) . ':/';
! 646: }
! 647: else {
! 648: # Current directory on drive was set.
! 649: # Remove both '\r' and '\n'.
! 650: $cur_dir_on_drv =~ s{\n|\r}{}g;
! 651:
! 652: # Append relative path part.
! 653: $res = $cur_dir_on_drv . '/';
! 654: }
! 655: $res .= $rel_path if defined $rel_path;
! 656:
! 657: # Replace any possible back slashes with forward slashes,
! 658: # remove any duplicated slashes, resolve relative dirs.
! 659: return normalize_path($res);
! 660: }
! 661:
! 662: # Internal function. Tries to find or guess Win32 version of given
! 663: # absolute Unix-style path. Other types of paths are not supported.
! 664: # Returned paths contain only single forward slashes (no back and
! 665: # duplicated slashes).
! 666: # Last resort. Used only when other transformations are not available.
! 667: sub do_dumb_guessed_transform {
! 668: my ($path) = @_;
! 669:
! 670: # Replace any possible back slashes and duplicated forward slashes
! 671: # with single forward slashes.
! 672: $path =~ s{[/\\]+}{/}g;
! 673:
! 674: # Empty path is not valid.
! 675: return undef if (length($path) == 0);
! 676:
! 677: # RE to find Win32 drive letter
! 678: my $drv_ltr_re = drives_mounted_on_cygdrive() ?
! 679: qr{^/cygdrive/([a-zA-Z])($|/.*$)} :
! 680: qr{^/([a-zA-Z])($|/.*$)};
! 681:
! 682: # Check path whether path is Win32 directly mapped drive and try to
! 683: # transform it assuming that drive letter is matched to Win32 drive letter.
! 684: if($path =~ m{$drv_ltr_re}) {
! 685: return ucfirst($1) . ':/' if(length($2) == 0);
! 686: return ucfirst($1) . ':' . $2;
! 687: }
! 688:
! 689: # This may be some custom mapped path. ('/mymount/path')
! 690:
! 691: # Must check longest possible path component as subdir can be mapped to
! 692: # different directory. For example '/usr/bin/' can be mapped to '/bin/' or
! 693: # '/bin/' can be mapped to '/usr/bin/'.
! 694: my $check_path = $path;
! 695: my $path_tail = '';
! 696: do {
! 697: if(-d $check_path) {
! 698: my $res =
! 699: `(cd "$check_path" && cmd /c "echo %__CD__%") 2>/dev/null`;
! 700: if($? == 0 && substr($path, 0, 1) ne '%') {
! 701: # Remove both '\r' and '\n'.
! 702: $res =~ s{\n|\r}{}g;
! 703:
! 704: # Replace all back slashes with forward slashes.
! 705: $res =~ s{\\}{/}g;
! 706:
! 707: if(length($path_tail) > 0) {
! 708: return $res . $path_tail;
! 709: }
! 710: else {
! 711: $res =~ s{/$}{} unless $check_path =~ m{/$};
! 712: return $res;
! 713: }
! 714: }
! 715: }
! 716: if($check_path =~ m{(^.*/)([^/]+/*)}) {
! 717: $check_path = $1;
! 718: $path_tail = $2 . $path_tail;
! 719: }
! 720: else {
! 721: # Shouldn't happens as root '/' directory should always
! 722: # be resolvable.
! 723: warn "Can't determine Win32 directory for path \"$path\".\n";
! 724: return undef;
! 725: }
! 726: } while(1);
! 727: }
! 728:
! 729:
! 730: # Internal function. Converts given Unix-style absolute path to Win32 format.
! 731: sub simple_transform_win32_to_unix {
! 732: my ($path) = @_;
! 733:
! 734: if(should_use_cygpath()) {
! 735: # 'cygpath' gives precise result.
! 736: my $res;
! 737: chomp($res = `cygpath -a -u '$path'`);
! 738: if($? != 0) {
! 739: warn "Can't determine Unix-style directory for Win32 " .
! 740: "directory \"$path\".\n";
! 741: return undef;
! 742: }
! 743:
! 744: # 'cygpath' removes last slash if path is root dir on Win32 drive.
! 745: $res .= '/' if(substr($res, length($res) - 1, 1) ne '/' &&
! 746: $path =~ m{[/\\]$});
! 747: return $res;
! 748: }
! 749:
! 750: # 'cygpath' is not available, use guessed transformation.
! 751: unless($path =~ s{^([a-zA-Z]):(?:/|\\)}{/\l$1/}) {
! 752: warn "Can't determine Unix-style directory for Win32 " .
! 753: "directory \"$path\".\n";
! 754: return undef;
! 755: }
! 756:
! 757: $path = '/cygdrive' . $path if(drives_mounted_on_cygdrive());
! 758: return $path;
! 759: }
! 760:
! 761: 1; # End of module
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>
![[BACK]](/icons/cvsweb/back.gif){kind=icon}
Return to pathhelp.pm CVS log ![[TXT]](/icons/cvsweb/text.gif){kind=icon}
![[DIR]](/icons/cvsweb/dir.gif){kind=icon}
Up to [ELWIX - Embedded LightWeight unIX -] / embedaddon / curl / tests