1. my class IO::Spec::Win32 is IO::Spec::Unix {
  2. # Some regexes we use for path splitting
  3. my $slash = regex { <[\/ \\]> }
  4. my $notslash = regex { <-[\/ \\]> }
  5. my $driveletter = regex { <[A..Z a..z]> ':' }
  6. my $UNCpath = regex { [<$slash> ** 2] <$notslash>+ <$slash> [<$notslash>+ | $] }
  7. my $volume_rx = regex { <$driveletter> | <$UNCpath> }
  8. method canonpath ($patharg, :$parent) {
  9. my $path = $patharg.Str;
  10. $path eq '' ?? '' !! self!canon-cat($path, :$parent);
  11. }
  12. method catdir(*@dirs) {
  13. return "" unless @dirs;
  14. return self!canon-cat( "\\", @dirs ) if @dirs[0] eq "";
  15. self!canon-cat(|@dirs);
  16. }
  17. method dir-sep { '\\' }
  18. method splitdir($dir) { $dir.split($slash) }
  19. method catfile(|c) { self.catdir(|c) }
  20. method devnull { 'nul' }
  21. method rootdir { '\\' }
  22. method basename(\path) {
  23. my str $str = nqp::unbox_s(path);
  24. my int $indexf = nqp::rindex($str,'/');
  25. my int $indexb = nqp::rindex($str,'\\');
  26. nqp::p6bool($indexf == -1 && $indexb == -1)
  27. ?? path
  28. !! $indexf > $indexb
  29. ?? substr(path,nqp::box_i($indexf + 1,Int) )
  30. !! substr(path,nqp::box_i($indexb + 1,Int) );
  31. }
  32. method tmpdir {
  33. my $ENV := %*ENV;
  34. my $io;
  35. first( {
  36. if .defined {
  37. $io = .IO;
  38. $io.d && $io.r && $io.w && $io.x;
  39. }
  40. },
  41. $ENV<TMPDIR>,
  42. $ENV<TEMP>,
  43. $ENV<TMP>,
  44. 'SYS:/temp',
  45. 'C:\system\temp',
  46. 'C:/temp',
  47. '/tmp',
  48. '/',
  49. ) ?? $io !! IO::Path.new(".");
  50. }
  51. method path {
  52. (".",
  53. split(';', %*ENV<PATH> // %*ENV<Path> // '').map( {
  54. .subst(:global, q/"/, '') } ).grep: *.chars );
  55. }
  56. method is-absolute ($path) {
  57. so $path ~~ /^ [ <$driveletter> <$slash> | <$slash> | <$UNCpath> ]/
  58. }
  59. multi method split(IO::Spec::Win32: Cool:D $path is copy) {
  60. $path ~~ s[ <$slash>+ $] = '' #=
  61. unless $path ~~ /^ <$driveletter>? <$slash>+ $/;
  62. $path ~~
  63. m/^ ( <$volume_rx> ? )
  64. ( [ .* <$slash> ]? )
  65. (.*)
  66. /;
  67. my ($volume, $dirname, $basename) = (~$0, ~$1, ~$2);
  68. $dirname ~~ s/ <?after .> <$slash>+ $//;
  69. if all($dirname, $basename) eq '' && $volume ne '' {
  70. $dirname = $volume ~~ /^<$driveletter>/
  71. ?? '.' !! '\\';
  72. }
  73. $basename = '\\' if $dirname eq any('/', '\\') && $basename eq '';
  74. $dirname = '.' if $dirname eq '' && $basename ne '';
  75. # temporary, for the transition period
  76. (:$volume, :$dirname, :$basename, :directory($dirname));
  77. # (:$volume, :$dirname, :$basename);
  78. }
  79. method join ($volume, $dirname is copy, $file is copy) {
  80. $dirname = '' if $dirname eq '.' && $file.chars;
  81. if $dirname.match( /^<$slash>$/ ) && $file.match( /^<$slash>$/ ) {
  82. $file = '';
  83. $dirname = '' if $volume.chars > 2; #i.e. UNC path
  84. }
  85. self.catpath($volume, $dirname, $file);
  86. }
  87. method splitpath(Str() $path, :$nofile = False) {
  88. if $nofile {
  89. $path ~~ /^ (<$volume_rx>?) (.*) /;
  90. (~$0, ~$1, '');
  91. }
  92. else {
  93. $path ~~
  94. m/^ ( <$volume_rx> ? )
  95. ( [ .* <$slash> [ '.' ** 1..2 $]? ]? )
  96. (.*)
  97. /;
  98. (~$0, ~$1, ~$2);
  99. }
  100. }
  101. method catpath($volume is copy, $dirname, $file) {
  102. # Make sure the glue separator is present
  103. # unless it's a relative path like A:foo.txt
  104. if $volume.chars and $dirname.chars
  105. and $volume !~~ /^<$driveletter>/
  106. and $volume !~~ /<$slash> $/
  107. and $dirname !~~ /^ <$slash>/
  108. { $volume ~= '\\' }
  109. if $file.chars and $dirname.chars
  110. and $dirname !~~ /<$slash> $/
  111. { $volume ~ $dirname ~ '\\' ~ $file; }
  112. else { $volume ~ $dirname ~ $file; }
  113. }
  114. method rel2abs ($path is copy, $base? is copy, :$omit-volume) {
  115. my $is_abs = ($path ~~ /^ [<$driveletter> <$slash> | <$UNCpath>]/ && 2)
  116. || ($path ~~ /^ <$slash> / && 1)
  117. || 0;
  118. # Check for volume (should probably document the '2' thing...)
  119. return self.canonpath( $path ) if $is_abs == 2 || ($is_abs == 1 && $omit-volume);
  120. if $is_abs {
  121. # It's missing a volume, add one
  122. my $vol;
  123. $vol = self.splitpath($base)[0] if $base.defined;
  124. $vol ||= self.splitpath($*CWD)[0];
  125. return self.canonpath( $vol ~ $path );
  126. }
  127. if not defined $base {
  128. # TODO: implement _getdcwd call ( Windows maintains separate CWD for each volume )
  129. # See: http://msdn.microsoft.com/en-us/library/1e5zwe0c%28v=vs.80%29.aspx
  130. #$base = Cwd::getdcwd( (self.splitpath: $path)[0] ) if defined &Cwd::getdcwd ;
  131. #$base //= $*CWD ;
  132. $base = $*CWD;
  133. }
  134. elsif ( !self.is-absolute( $base ) ) {
  135. $base = self.rel2abs( $base );
  136. }
  137. else {
  138. $base = self.canonpath( $base );
  139. }
  140. my ($path_directories, $path_file) = self.splitpath( $path )[1..2] ;
  141. my ($base_volume, $base_directories) = self.splitpath( $base, :nofile ) ;
  142. $path = self.catpath(
  143. $base_volume,
  144. self.catdir( $base_directories, $path_directories ),
  145. $path_file
  146. ) ;
  147. return self.canonpath( $path ) ;
  148. }
  149. method !canon-cat ( $first, *@rest, :$parent --> Str:D) {
  150. $first ~~ /^ ([ <$driveletter> <$slash>?
  151. | <$UNCpath>
  152. | [<$slash> ** 2] <$notslash>+
  153. | <$slash> ]?)
  154. (.*)
  155. /;
  156. my Str ($volume, $path) = ~$0, ~$1;
  157. $volume.=subst(:g, '/', '\\');
  158. if $volume ~~ /^<$driveletter>/ {
  159. $volume.=uc;
  160. }
  161. elsif $volume.chars && $volume !~~ / '\\' $/ {
  162. $volume ~= '\\';
  163. }
  164. $path = join "\\", $path, @rest.flat;
  165. $path ~~ s:g/ <$slash>+ /\\/; # /xx\\yy --> \xx\yy
  166. $path ~~ s:g/[ ^ | '\\'] '.' '\\.'* [ '\\' | $ ]/\\/; # xx/././yy --> xx/yy
  167. if $parent {
  168. while $path ~~ s:g { [^ | <?after '\\'>] <!before '..\\'> <-[\\]>+ '\\..' ['\\' | $ ] } = '' { };
  169. }
  170. $path ~~ s/^ '\\'+ //; # \xx --> xx NOTE: this is *not* root
  171. $path ~~ s/ '\\'+ $//; # xx\ --> xx
  172. if $volume ~~ / '\\' $ / { # <vol>\.. --> <vol>\
  173. $path ~~ s/ ^ '..' '\\..'* [ '\\' | $ ] //;
  174. }
  175. if $path eq '' { # \\HOST\SHARE\ --> \\HOST\SHARE
  176. $volume ~~ s/<?after '\\\\' .*> '\\' $ //;
  177. $volume || '.';
  178. }
  179. else {
  180. $volume ~ $path;
  181. }
  182. }
  183. }