/core/io/pathnames/pathnames.factor

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