core/io/pathnames/pathnames.factor

   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 ;
   5 IN: io.pathnames
   6
   7 SYMBOL: 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     index-of-last [ path-separator? ] find-last-from ;
  21
  22 HOOK: root-directory? io-backend ( path -- ? )
  23
  24 M: object root-directory?
  25     [ f ] [ [ path-separator? ] all? ] if-empty ;
  26
  27 ERROR: 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 -- ? )
  65     {
  66         { [ dup "\\\\?\\" head? ] [ t ] }
  67         { [ dup length 2 < ] [ f ] }
  68         { [ dup second CHAR: : = ] [ t ] }
  69         [ f ]
  70     } cond nip ;
  71
  72 : special-path? ( path -- rest ? )
  73     {
  74         { [ "resource:" ?head ] [ t ] }
  75         { [ "vocab:" ?head ] [ t ] }
  76         [ f ]
  77     } cond ;
  78
  79 PRIVATE>
  80
  81 TUPLE: pathname string ;
  82
  83 C: <pathname> pathname
  84
  85 : >pathname ( obj -- pathname )
  86     dup pathname? [ <pathname> ] unless ;
  87
  88 : pathname> ( pathname -- obj )
  89     dup pathname? [ string>> ] when ;
  90
  91 : absolute-path? ( path -- ? )
  92     {
  93         { [ dup empty? ] [ drop f ] }
  94         { [ dup special-path? nip ] [ drop t ] }
  95         { [ os windows? ] [ windows-absolute-path? ] }
  96         { [ dup first path-separator? ] [ drop t ] }
  97         [ drop f ]
  98     } cond ;
  99
 100 : append-relative-path ( path1 path2 -- path )
 101     [ trim-tail-separators ]
 102     [ trim-head-separators ] bi* "/" glue ;
 103
 104 : append-path ( path1 path2 -- path )
 105     [ pathname> ] bi@
 106     {
 107         { [ over empty? ] [ append-path-empty ] }
 108         { [ dup empty? ] [ drop ] }
 109         { [ over trim-tail-separators "." = ] [ nip ] }
 110         { [ dup absolute-path? ] [ nip ] }
 111         { [ dup head.? ] [ rest trim-head-separators append-path ] }
 112         { [ dup head..? ] [
 113             2 tail trim-head-separators
 114             [ parent-directory ] dip append-path
 115         ] }
 116         { [ over absolute-path? over first path-separator? and ] [
 117             [ 2 head ] dip append
 118         ] }
 119         [ append-relative-path ]
 120     } cond ;
 121
 122 : prepend-path ( path1 path2 -- path )
 123     swap append-path ; inline
 124
 125 : 3append-path ( path chunk1 chunk2 -- path' )
 126     [ append-path ] dip append-path ; inline
 127
 128 : file-name ( path -- string )
 129     dup root-directory? [
 130         trim-tail-separators
 131         dup last-path-separator [ 1 + tail ] [
 132             drop special-path? [ file-name ] when
 133         ] if
 134     ] unless ;
 135
 136 : file-stem ( path -- stem )
 137     file-name "." split1-last drop ;
 138
 139 : file-extension ( path -- extension )
 140     file-name "." split1-last nip ;
 141
 142 : has-file-extension? ( path -- ? )
 143     dup ?last path-separator?
 144     [ drop f ]
 145     [ file-name CHAR: . swap member? ] if ;
 146
 147 : path-components ( path -- seq )
 148     normalize-path path-separator split harvest ;
 149
 150 HOOK: resolve-symlinks os ( path -- path' )
 151
 152 M: object resolve-symlinks normalize-path ;
 153
 154 : resource-path ( path -- newpath )
 155     "resource-path" get prepend-path ;
 156
 157 HOOK: home io-backend ( -- dir )
 158
 159 M: object home "" resource-path ;
 160
 161 : home-path ( path -- newpath ) home prepend-path ;
 162
 163 GENERIC: vocab-path ( path -- newpath )
 164
 165 GENERIC: absolute-path ( path -- path' )
 166
 167 M: string absolute-path
 168     {
 169         { [ "resource:" ?head ] [ trim-head-separators resource-path absolute-path ] }
 170         { [ "vocab:" ?head ] [ trim-head-separators vocab-path absolute-path ] }
 171         { [ "~" ?head ] [ trim-head-separators home prepend-path absolute-path ] }
 172         [ current-directory get prepend-path ]
 173     } cond ;
 174
 175 M: object normalize-path
 176     absolute-path ;
 177
 178 : root-path* ( path -- path' )
 179     dup absolute-path? [
 180         dup [ path-separator? ] find
 181         drop 1 + head
 182     ] when ;
 183
 184 HOOK: root-path os ( path -- path' )
 185
 186 M: object root-path root-path* ;
 187
 188 : relative-path* ( path -- relative-path )
 189     dup absolute-path? [
 190         dup [ path-separator? ] find
 191         drop 1 + tail
 192     ] when ;
 193
 194 HOOK: relative-path os ( path -- path' )
 195
 196 M: object relative-path relative-path* ;
 197
 198 : canonicalize-path* ( path -- path' )
 199     [
 200         relative-path
 201         [ path-separator? ] split-when
 202         [ { "." "" } member? ] reject
 203         V{ } clone [
 204             dup ".." = [
 205                 over empty?
 206                 [ over push ]
 207                 [ over ?last ".." = [ over push ] [ drop dup pop* ] if ] if
 208             ] [
 209                 over push
 210             ] if
 211         ] reduce
 212     ] keep dup absolute-path? [
 213         [
 214             [ ".." = ] trim-head
 215             path-separator join
 216         ] dip root-path prepend-path
 217     ] [
 218         drop path-separator join [ "." ] when-empty
 219     ] if ;
 220
 221 HOOK: canonicalize-path io-backend ( path -- path' )
 222
 223 M: object canonicalize-path canonicalize-path* ;
 224
 225 HOOK: canonicalize-drive io-backend ( path -- path' )
 226
 227 M: object canonicalize-drive ;
 228
 229 HOOK: canonicalize-path-full io-backend ( path -- path' )
 230
 231 M: object canonicalize-path-full canonicalize-path canonicalize-drive ;
 232
 233 : >windows-path ( path -- path' ) H{ { CHAR: / CHAR: \\ } } substitute ;
 234
 235 M: pathname absolute-path string>> absolute-path ;
 236
 237 M: pathname <=> [ string>> ] compare ;