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
762:
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