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