1 ! Copyright (C) 2004, 2009 Slava Pestov, Doug Coleman.
2 ! See https://factorcode.org/license.txt for BSD license.
3 USING: accessors assocs combinators io.backend kernel math
4 math.order namespaces sequences splitting strings system ;
7 SYMBOL: current-directory
9 : path-separator? ( ch -- ? ) os windows? "/\\" "/" ? member? ;
11 : path-separator ( -- string ) os windows? "\\" "/" ? ;
13 : trim-tail-separators ( string -- string' )
14 [ path-separator? ] trim-tail ;
16 : trim-head-separators ( string -- string' )
17 [ path-separator? ] trim-head ;
19 : last-path-separator ( path -- n ? )
20 index-of-last [ path-separator? ] find-last-from ;
22 HOOK: root-directory? io-backend ( path -- ? )
24 M: object root-directory?
25 [ f ] [ [ path-separator? ] all? ] if-empty ;
27 ERROR: no-parent-directory path ;
29 : parent-directory ( path -- parent )
32 dup last-path-separator [
37 { "" "." ".." } member? [
44 : head-path-separator? ( path1 ? -- ?' )
46 [ t ] [ first path-separator? ] if-empty
51 : head.? ( path -- ? ) "." ?head head-path-separator? ;
53 : head..? ( path -- ? ) ".." ?head head-path-separator? ;
55 : append-path-empty ( path1 path2 -- path' )
58 rest trim-head-separators append-path-empty
60 { [ dup head..? ] [ drop no-parent-directory ] }
64 : windows-absolute-path? ( path -- ? )
66 { [ dup "\\\\?\\" head? ] [ t ] }
67 { [ dup length 2 < ] [ f ] }
68 { [ dup second CHAR: : = ] [ t ] }
72 : special-path? ( path -- rest ? )
74 { [ "resource:" ?head ] [ t ] }
75 { [ "vocab:" ?head ] [ t ] }
81 : absolute-path? ( path -- ? )
83 { [ dup empty? ] [ drop f ] }
84 { [ dup special-path? nip ] [ drop t ] }
85 { [ os windows? ] [ windows-absolute-path? ] }
86 { [ dup first path-separator? ] [ drop t ] }
90 : append-relative-path ( path1 path2 -- path )
91 [ trim-tail-separators ]
92 [ trim-head-separators ] bi* "/" glue ;
94 : append-path ( path1 path2 -- path )
96 { [ over empty? ] [ append-path-empty ] }
97 { [ dup empty? ] [ drop ] }
98 { [ over trim-tail-separators "." = ] [ nip ] }
99 { [ dup absolute-path? ] [ nip ] }
100 { [ dup head.? ] [ rest trim-head-separators append-path ] }
102 2 tail trim-head-separators
103 [ parent-directory ] dip append-path
105 { [ over absolute-path? over first path-separator? and ] [
106 [ 2 head ] dip append
108 [ append-relative-path ]
111 : prepend-path ( path1 path2 -- path )
112 swap append-path ; inline
114 : 3append-path ( path chunk1 chunk2 -- path' )
115 [ append-path ] dip append-path ; inline
117 : file-name ( path -- string )
118 dup root-directory? [
120 dup last-path-separator [ 1 + tail ] [
121 drop special-path? [ file-name ] when
125 : file-stem ( path -- stem )
126 file-name "." split1-last drop ;
128 : file-extension ( path -- extension )
129 file-name "." split1-last nip ;
131 : has-file-extension? ( path -- ? )
132 dup ?last path-separator?
134 [ file-name CHAR: . swap member? ] if ;
136 : path-components ( path -- seq )
137 normalize-path path-separator split harvest ;
139 HOOK: resolve-symlinks os ( path -- path' )
141 M: object resolve-symlinks normalize-path ;
143 : resource-path ( path -- newpath )
144 "resource-path" get prepend-path ;
146 HOOK: home io-backend ( -- dir )
148 M: object home "" resource-path ;
150 : home-path ( path -- newpath ) home prepend-path ;
152 GENERIC: vocab-path ( path -- newpath )
154 GENERIC: absolute-path ( path -- path' )
156 M: string absolute-path
158 { [ "resource:" ?head ] [ trim-head-separators resource-path absolute-path ] }
159 { [ "vocab:" ?head ] [ trim-head-separators vocab-path absolute-path ] }
160 { [ "~" ?head ] [ trim-head-separators home prepend-path absolute-path ] }
161 [ current-directory get prepend-path ]
164 M: object normalize-path
167 : root-path* ( path -- path' )
169 dup [ path-separator? ] find
173 HOOK: root-path os ( path -- path' )
175 M: object root-path root-path* ;
177 : relative-path* ( path -- relative-path )
179 dup [ path-separator? ] find
183 HOOK: relative-path os ( path -- path' )
185 M: object relative-path relative-path* ;
187 : canonicalize-path* ( path -- path' )
190 [ path-separator? ] split-when
191 [ { "." "" } member? ] reject
196 [ over ?last ".." = [ over push ] [ drop dup pop* ] if ] if
201 ] keep dup absolute-path? [
205 ] dip root-path prepend-path
207 drop path-separator join [ "." ] when-empty
210 HOOK: canonicalize-path io-backend ( path -- path' )
212 M: object canonicalize-path canonicalize-path* ;
214 HOOK: canonicalize-drive io-backend ( path -- path' )
216 M: object canonicalize-drive ;
218 HOOK: canonicalize-path-full io-backend ( path -- path' )
220 M: object canonicalize-path-full canonicalize-path canonicalize-drive ;
222 : >windows-path ( path -- path' ) H{ { CHAR: / CHAR: \\ } } substitute ;
224 TUPLE: pathname string ;
226 C: <pathname> pathname
228 M: pathname absolute-path string>> absolute-path ;
230 M: pathname <=> [ string>> ] compare ;
232 : >pathname ( obj -- pathname )
233 dup pathname? [ <pathname> ] unless ;