core/io/pathnames/pathnames.factor

   1 ! Copyright (C) 2004, 2008 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
   7 SYMBOL: current-directory
   8
   9 : path-separator? ( ch -- ? ) os windows? "/\\" "/" ? member? ;
  10
  11 : path-separator ( -- string ) os windows? "\\" "/" ? ;
  12
  13 : trim-right-separators ( str -- newstr )
  14     [ path-separator? ] trim-right ;
  15
  16 : trim-left-separators ( str -- newstr )
  17     [ path-separator? ] trim-left ;
  18
  19 : last-path-separator ( path -- n ? )
  20     [ length 1- ] keep [ path-separator? ] find-last-from ;
  21
  22 HOOK: root-directory? io-backend ( path -- ? )
  23
  24 M: object root-directory? ( path -- ? )
  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-right-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-left-separators append-path-empty
  59         ] }
  60         { [ dup head..? ] [ drop no-parent-directory ] }
  61         [ nip ]
  62     } cond ;
  63
  64 PRIVATE>
  65
  66 : windows-absolute-path? ( path -- path ? )
  67     {
  68         { [ dup "\\\\?\\" head? ] [ t ] }
  69         { [ dup length 2 < ] [ f ] }
  70         { [ dup second CHAR: : = ] [ t ] }
  71         [ f ]
  72     } cond ;
  73
  74 : absolute-path? ( path -- ? )
  75     {
  76         { [ dup empty? ] [ f ] }
  77         { [ dup "resource:" head? ] [ t ] }
  78         { [ os windows? ] [ windows-absolute-path? ] }
  79         { [ dup first path-separator? ] [ t ] }
  80         [ f ]
  81     } cond nip ;
  82
  83 : append-path ( str1 str2 -- str )
  84     {
  85         { [ over empty? ] [ append-path-empty ] }
  86         { [ dup empty? ] [ drop ] }
  87         { [ over trim-right-separators "." = ] [ nip ] }
  88         { [ dup absolute-path? ] [ nip ] }
  89         { [ dup head.? ] [ rest trim-left-separators append-path ] }
  90         { [ dup head..? ] [
  91             2 tail trim-left-separators
  92             [ parent-directory ] dip append-path
  93         ] }
  94         { [ over absolute-path? over first path-separator? and ] [
  95             [ 2 head ] dip append
  96         ] }
  97         [
  98             [ trim-right-separators "/" ] dip
  99             trim-left-separators 3append
 100         ]
 101     } cond ;
 102
 103 : prepend-path ( str1 str2 -- str )
 104     swap append-path ; inline
 105
 106 : file-name ( path -- string )
 107     dup root-directory? [
 108         trim-right-separators
 109         dup last-path-separator [ 1+ tail ] [
 110             drop "resource:" ?head [ file-name ] when
 111         ] if
 112     ] unless ;
 113
 114 : file-extension ( filename -- extension )
 115     "." split1-last nip ;
 116
 117 : resource-path ( path -- newpath )
 118     "resource-path" get prepend-path ;
 119
 120 GENERIC: (normalize-path) ( path -- path' )
 121
 122 M: string (normalize-path)
 123     "resource:" ?head [
 124         trim-left-separators resource-path
 125         (normalize-path)
 126     ] [
 127         current-directory get prepend-path
 128     ] if ;
 129
 130 M: object normalize-path ( path -- path' )
 131     (normalize-path) ;
 132
 133 TUPLE: pathname string ;
 134
 135 C: <pathname> pathname
 136
 137 M: pathname (normalize-path) string>> (normalize-path) ;
 138
 139 M: pathname <=> [ string>> ] compare ;
 140
 141 HOOK: home io-backend ( -- dir )
 142
 143 M: object home "" resource-path ;