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. # NOTE: IO::Path.resolve assumes dir sep is 1 char
  18. method dir-sep { 「\」 }
  19. method devnull { 'nul' }
  20. method rootdir { 「\」 }
  21. method splitdir(Cool:D $path) {
  22. nqp::p6bindattrinvres(
  23. (), List, '$!reified',
  24. nqp::split('/', nqp::join('/', nqp::split(「\」, $path.Str))))
  25. || ('',)
  26. }
  27. method basename(\path) {
  28. my str $str = nqp::unbox_s(path);
  29. my int $indexf = nqp::rindex($str,'/');
  30. my int $indexb = nqp::rindex($str,'\\');
  31. nqp::p6bool($indexf == -1 && $indexb == -1)
  32. ?? path
  33. !! $indexf > $indexb
  34. ?? substr(path,nqp::box_i($indexf + 1,Int) )
  35. !! substr(path,nqp::box_i($indexb + 1,Int) );
  36. }
  37. method tmpdir {
  38. my $ENV := %*ENV;
  39. my $io;
  40. first( {
  41. if .defined {
  42. $io = .IO;
  43. $io.d && $io.rwx;
  44. }
  45. },
  46. $ENV<TMPDIR>,
  47. $ENV<TEMP>,
  48. $ENV<TMP>,
  49. 'SYS:/temp',
  50. 'C:\system\temp',
  51. 'C:/temp',
  52. '/tmp',
  53. '/',
  54. ) ?? $io !! IO::Path.new(".");
  55. }
  56. method path {
  57. gather {
  58. take '.';
  59. my $p := %*ENV;
  60. nqp::if(
  61. ($p := nqp::if(nqp::defined($_ := $p<PATH>), $_, $p<Path>)),
  62. nqp::stmts(
  63. (my int $els = nqp::elems(my $parts := nqp::split(';', $p))),
  64. (my int $i = -1),
  65. nqp::until(
  66. nqp::iseq_i($els, $i = nqp::add_i($i, 1)),
  67. ($_ := nqp::atpos($parts, $i))
  68. # unsure why old code removed all `"`, but keeping code same
  69. # https://irclog.perlgeek.de/perl6-dev/2017-05-15#i_14585448
  70. && take nqp::join('', nqp::split(「"」, $_)))))
  71. }
  72. }
  73. method is-absolute ($path) {
  74. nqp::p6bool(
  75. nqp::iseq_i(($_ := nqp::ord($path)), 92) # /^ 「\」 /
  76. || nqp::iseq_i($_, 47) # /^ 「/」 /
  77. || (nqp::eqat($path, ':', 1) # /^ <[A..Z a..z]> ':' [ 「\」 | 「/」 ] /
  78. && ( (nqp::isge_i($_, 65) && nqp::isle_i($_, 90)) # drive letter
  79. || (nqp::isge_i($_, 97) && nqp::isle_i($_, 122)))
  80. && ( nqp::iseq_i(($_ := nqp::ordat($path, 2)), 92) # slash
  81. || nqp::iseq_i($_, 47))))
  82. }
  83. method split(IO::Spec::Win32: Cool:D $path is copy) {
  84. $path ~~ s[ <$slash>+ $] = '' #=
  85. unless $path ~~ /^ <$driveletter>? <$slash>+ $/;
  86. $path ~~
  87. m/^ ( <$volume_rx> ? )
  88. ( [ .* <$slash> ]? )
  89. (.*)
  90. /;
  91. my str $volume = $0.Str;
  92. my str $dirname = $1.Str;
  93. my str $basename = $2.Str;
  94. nqp::stmts(
  95. nqp::while( # s/ <?after .> <$slash>+ $//
  96. nqp::isgt_i(($_ := nqp::sub_i(nqp::chars($dirname), 1)), 0)
  97. && (nqp::eqat($dirname, 「\」, $_) || nqp::eqat($dirname, '/', $_)),
  98. $dirname = nqp::substr($dirname, 0, $_)),
  99. nqp::if(
  100. $volume && nqp::isfalse($dirname) && nqp::isfalse($basename),
  101. nqp::if(
  102. nqp::eqat($volume, ':', 1) # /^ <[A..Z a..z]> ':'/
  103. && ( (nqp::isge_i(($_ := nqp::ord($volume)), 65) # drive letter
  104. && nqp::isle_i($_, 90))
  105. || (nqp::isge_i($_, 97) && nqp::isle_i($_, 122))),
  106. ($dirname = '.'),
  107. ($dirname = 「\」))),
  108. nqp::if(
  109. (nqp::iseq_s($dirname, 「\」) || nqp::iseq_s($dirname, '/'))
  110. && nqp::isfalse($basename),
  111. $basename = 「\」),
  112. nqp::if(
  113. $basename && nqp::isfalse($dirname),
  114. $dirname = '.'));
  115. (:$volume, :$dirname, :$basename)
  116. }
  117. method join (Str \vol, Str $dir is copy, Str $file is copy) {
  118. nqp::stmts(
  119. nqp::if(
  120. $file && nqp::iseq_s($dir, '.'),
  121. ($dir = ''),
  122. nqp::if(
  123. (nqp::iseq_s($dir, 「\」) || nqp::iseq_s($dir, 「/」))
  124. && (nqp::iseq_s($file, 「\」) || nqp::iseq_s($file, 「/」)),
  125. nqp::stmts(
  126. ($file = ''),
  127. nqp::if(
  128. nqp::isgt_i(nqp::chars(vol), 2), # i.e. UNC path
  129. $dir = '')))),
  130. self.catpath: vol, $dir, $file)
  131. }
  132. method splitpath(Str() $path, :$nofile = False) {
  133. if $nofile {
  134. $path ~~ /^ (<$volume_rx>?) (.*) /;
  135. (~$0, ~$1, '');
  136. }
  137. else {
  138. $path ~~
  139. m/^ ( <$volume_rx> ? )
  140. ( [ .* <$slash> [ '.' ** 1..2 $]? ]? )
  141. (.*)
  142. /;
  143. (~$0, ~$1, ~$2);
  144. }
  145. }
  146. method catpath(Str $vol is copy, Str \dir, Str \file) {
  147. nqp::stmts(
  148. nqp::if( # Make sure the glue separator is present
  149. $vol && dir # unless it's a relative path like A:foo.txt
  150. && nqp::isfalse(
  151. nqp::iseq_i(nqp::ord($vol, 1), 58) # /^ <[A..Z a..z]> ':'/
  152. && ( (nqp::isge_i(nqp::ord($vol), 65) # 'A'
  153. && nqp::isle_i(nqp::ord($vol), 90)) # 'Z'
  154. || (nqp::isge_i(nqp::ord($vol), 97) # 'a'
  155. && nqp::isle_i(nqp::ord($vol), 122)))) # 'z'
  156. && nqp::isfalse( # /<[/\\]> $/
  157. nqp::iseq_i(92, nqp::ord( # '\'
  158. $vol, nqp::sub_i(nqp::chars($vol), 1)))
  159. || nqp::iseq_i(47, nqp::ord( # '/'
  160. $vol, nqp::sub_i(nqp::chars($vol), 1))))
  161. && nqp::isfalse( # /^ /<[/\\]>/
  162. nqp::iseq_i(92, nqp::ord(dir)) # '\'
  163. || nqp::iseq_i(47, nqp::ord(dir))), # '/'
  164. $vol = nqp::concat($vol, 「\」)),
  165. nqp::if(
  166. dir && file
  167. && nqp::isfalse( # /<[/\\]> $/
  168. nqp::iseq_i(92, nqp::ord( # '\'
  169. dir, nqp::sub_i(nqp::chars(dir), 1)))
  170. || nqp::iseq_i(47, nqp::ord( # '/'
  171. dir, nqp::sub_i(nqp::chars(dir), 1)))),
  172. nqp::concat($vol, nqp::concat(dir, nqp::concat(「\」, file))),
  173. nqp::concat($vol, nqp::concat(dir, file))))
  174. }
  175. method rel2abs (Str() $path is copy, $base? is copy, :$omit-volume) {
  176. nqp::if(
  177. (nqp::eqat($path, ':', 1) # /^ <[A..Z a..z]> ':' [ 「\」 | 「/」 ] /
  178. && ( (nqp::isge_i(($_ := nqp::ord($path)), 65) # drive letter
  179. && nqp::isle_i($_, 90))
  180. || (nqp::isge_i($_, 97) && nqp::isle_i($_, 122)))
  181. && ( nqp::iseq_i(($_ := nqp::ordat($path, 2)), 92) # slash
  182. || nqp::iseq_i($_, 47)))
  183. || 0, #($path ~~ /^ <$UNCpath>/),
  184. self.canonpath($path),
  185. nqp::if(
  186. nqp::iseq_i(($_ := nqp::ord($path)), 92) # /^ 「\」 /
  187. || nqp::iseq_i($_, 47), # /^ 「/」 /
  188. nqp::if(
  189. $omit-volume,
  190. self.canonpath($path),
  191. nqp::stmts(
  192. (my $vol),
  193. nqp::if(
  194. nqp::defined($base),
  195. ($vol := self.splitpath($base).AT-POS(0))),
  196. nqp::unless(
  197. $vol,
  198. ($vol := self.splitpath($*CWD)[0])),
  199. self.canonpath($vol ~ $path))),
  200. nqp::stmts(
  201. nqp::unless(
  202. nqp::defined($base),
  203. ($base = $*CWD),
  204. nqp::unless(
  205. self.is-absolute($base),
  206. ($base = self.rel2abs: $base),
  207. ($base = self.canonpath: $base))),
  208. (my ($path_directories, $path_file)
  209. = self.splitpath($path)[1, 2]),
  210. (my ($base_volume, $base_directories)
  211. = self.splitpath($base, :nofile)),
  212. self.canonpath(
  213. self.catpath(
  214. $base_volume,
  215. self.catdir($base_directories, $path_directories),
  216. $path_file)))))
  217. }
  218. method !canon-cat ( $first, *@rest, :$parent --> Str:D) {
  219. $first ~~ /^ ([ <$driveletter> <$slash>?
  220. | <$UNCpath>
  221. | [<$slash> ** 2] <$notslash>+
  222. | <$slash> ]?)
  223. (.*)
  224. /;
  225. my str $volume = ~$0;
  226. my str $path = ~$1;
  227. my int $temp;
  228. $volume = nqp::join(「\」, nqp::split('/', $volume));
  229. $temp = nqp::ord($volume);
  230. nqp::if(
  231. nqp::eqat($volume, ':', 1) # this chunk == ~~ /^<[A..Z a..z]>':'/
  232. && ( (nqp::isge_i($temp, 65) && nqp::isle_i($temp, 90))
  233. || (nqp::isge_i($temp, 97) && nqp::isle_i($temp, 122))),
  234. ($volume = nqp::uc($volume)),
  235. nqp::if(
  236. ($temp = nqp::chars($volume))
  237. && nqp::isfalse(nqp::eqat($volume, 「\」, nqp::sub_i($temp, 1))),
  238. ($volume = nqp::concat($volume, 「\」))));
  239. $path = join 「\」, $path, @rest.flat;
  240. # /xx\\\yy\/zz --> \xx\yy\zz
  241. $path = nqp::join(「\」, nqp::split('/', $path));
  242. nqp::while(
  243. nqp::isne_i(-1, $temp = nqp::index($path, 「\\」)),
  244. ($path = nqp::replace($path, $temp, 2, 「\」)));
  245. # xx/././yy --> xx/yy
  246. $path ~~ s:g/[ ^ | 「\」] '.' 「\.」* [ 「\」 | $ ]/\\/;
  247. nqp::if($parent,
  248. nqp::while(
  249. ($path ~~ s:g {
  250. [^ | <?after 「\」>] <!before 「..\」> <-[\\]>+ 「\..」 [ 「\」 | $ ]
  251. } = ''),
  252. nqp::null));
  253. nqp::while( # \xx --> xx NOTE: this is *not* root
  254. nqp::iseq_i(0, nqp::index($path, 「\」)),
  255. ($path = nqp::substr($path, 1)));
  256. nqp::while( # xx\ --> xx
  257. nqp::eqat($path, 「\」, ($temp = nqp::sub_i(nqp::chars($path), 1))),
  258. ($path = nqp::substr($path, 0, $temp)));
  259. nqp::if( # <vol>\.. --> <vol>\
  260. nqp::eqat($volume, 「\」, nqp::sub_i(nqp::chars($volume), 1)),
  261. $path ~~ s/ ^ '..' 「\..」* [ 「\」 | $ ] //);
  262. nqp::if(
  263. $path,
  264. nqp::concat($volume, $path),
  265. nqp::stmts( # \\HOST\SHARE\ --> \\HOST\SHARE
  266. nqp::iseq_i(0, nqp::index($volume, 「\\」))
  267. && nqp::iseq_i(nqp::rindex($volume, 「\」),
  268. ($temp = nqp::sub_i(nqp::chars($volume), 1)))
  269. && ($volume = nqp::substr($volume, 0, $temp)),
  270. $volume || '.'))
  271. }
  272. }