/core/io/pathnames/pathnames.factor

http://github.com/abeaumont/factor · Factor · 173 lines · 131 code · 40 blank · 2 comment · 40 complexity · f23c5b205d82b4dea2876c64763abf57 MD5 · raw file

  1. ! Copyright (C) 2004, 2009 Slava Pestov, Doug Coleman.
  2. ! See http://factorcode.org/license.txt for BSD license.
  3. USING: accessors combinators io.backend kernel math math.order
  4. namespaces sequences splitting strings system ;
  5. IN: io.pathnames
  6. SYMBOL: current-directory
  7. : path-separator? ( ch -- ? ) os windows? "/\\" "/" ? member? ;
  8. : path-separator ( -- string ) os windows? "\\" "/" ? ;
  9. : trim-tail-separators ( string -- string' )
  10. [ path-separator? ] trim-tail ;
  11. : trim-head-separators ( string -- string' )
  12. [ path-separator? ] trim-head ;
  13. : last-path-separator ( path -- n ? )
  14. [ length 1 - ] keep [ path-separator? ] find-last-from ;
  15. HOOK: root-directory? io-backend ( path -- ? )
  16. M: object root-directory? ( path -- ? )
  17. [ f ] [ [ path-separator? ] all? ] if-empty ;
  18. ERROR: no-parent-directory path ;
  19. : parent-directory ( path -- parent )
  20. dup root-directory? [
  21. trim-tail-separators
  22. dup last-path-separator [
  23. 1 + cut
  24. ] [
  25. drop "." swap
  26. ] if
  27. { "" "." ".." } member? [
  28. no-parent-directory
  29. ] when
  30. ] unless ;
  31. <PRIVATE
  32. : head-path-separator? ( path1 ? -- ?' )
  33. [
  34. [ t ] [ first path-separator? ] if-empty
  35. ] [
  36. drop f
  37. ] if ;
  38. : head.? ( path -- ? ) "." ?head head-path-separator? ;
  39. : head..? ( path -- ? ) ".." ?head head-path-separator? ;
  40. : append-path-empty ( path1 path2 -- path' )
  41. {
  42. { [ dup head.? ] [
  43. rest trim-head-separators append-path-empty
  44. ] }
  45. { [ dup head..? ] [ drop no-parent-directory ] }
  46. [ nip ]
  47. } cond ;
  48. : windows-absolute-path? ( path -- path ? )
  49. {
  50. { [ dup "\\\\?\\" head? ] [ t ] }
  51. { [ dup length 2 < ] [ f ] }
  52. { [ dup second CHAR: : = ] [ t ] }
  53. [ f ]
  54. } cond ;
  55. : special-path? ( path -- rest ? )
  56. {
  57. { [ "resource:" ?head ] [ t ] }
  58. { [ "vocab:" ?head ] [ t ] }
  59. [ f ]
  60. } cond ;
  61. PRIVATE>
  62. : absolute-path? ( path -- ? )
  63. {
  64. { [ dup empty? ] [ f ] }
  65. { [ dup special-path? nip ] [ t ] }
  66. { [ os windows? ] [ windows-absolute-path? ] }
  67. { [ dup first path-separator? ] [ t ] }
  68. [ f ]
  69. } cond nip ;
  70. : append-relative-path ( path1 path2 -- path )
  71. [ trim-tail-separators ]
  72. [ trim-head-separators ] bi* "/" glue ;
  73. : append-path ( path1 path2 -- path )
  74. {
  75. { [ over empty? ] [ append-path-empty ] }
  76. { [ dup empty? ] [ drop ] }
  77. { [ over trim-tail-separators "." = ] [ nip ] }
  78. { [ dup absolute-path? ] [ nip ] }
  79. { [ dup head.? ] [ rest trim-head-separators append-path ] }
  80. { [ dup head..? ] [
  81. 2 tail trim-head-separators
  82. [ parent-directory ] dip append-path
  83. ] }
  84. { [ over absolute-path? over first path-separator? and ] [
  85. [ 2 head ] dip append
  86. ] }
  87. [ append-relative-path ]
  88. } cond ;
  89. : prepend-path ( path1 path2 -- path )
  90. swap append-path ; inline
  91. : file-name ( path -- string )
  92. dup root-directory? [
  93. trim-tail-separators
  94. dup last-path-separator [ 1 + tail ] [
  95. drop special-path? [ file-name ] when
  96. ] if
  97. ] unless ;
  98. : file-stem ( path -- stem )
  99. file-name "." split1-last drop ;
  100. : file-extension ( path -- extension )
  101. file-name "." split1-last nip ;
  102. : path-components ( path -- seq )
  103. normalize-path path-separator split harvest ;
  104. HOOK: resolve-symlinks os ( path -- path' )
  105. M: object resolve-symlinks normalize-path ;
  106. : resource-path ( path -- newpath )
  107. "resource-path" get prepend-path ;
  108. HOOK: home io-backend ( -- dir )
  109. M: object home "" resource-path ;
  110. GENERIC: vocab-path ( path -- newpath )
  111. GENERIC: absolute-path ( path -- path' )
  112. M: string absolute-path
  113. "resource:" ?head [
  114. trim-head-separators resource-path
  115. absolute-path
  116. ] [
  117. "vocab:" ?head [
  118. trim-head-separators vocab-path
  119. absolute-path
  120. ] [
  121. "~" ?head [
  122. trim-head-separators home prepend-path
  123. absolute-path
  124. ] [
  125. current-directory get prepend-path
  126. ] if ] if
  127. ] if ;
  128. M: object normalize-path ( path -- path' )
  129. absolute-path ;
  130. TUPLE: pathname string ;
  131. C: <pathname> pathname
  132. M: pathname absolute-path string>> absolute-path ;
  133. M: pathname <=> [ string>> ] compare ;