path.ml (7569B)
1 (* Unison file synchronizer: src/path.ml *) 2 (* Copyright 1999-2020, Benjamin C. Pierce 3 4 This program is free software: you can redistribute it and/or modify 5 it under the terms of the GNU General Public License as published by 6 the Free Software Foundation, either version 3 of the License, or 7 (at your option) any later version. 8 9 This program is distributed in the hope that it will be useful, 10 but WITHOUT ANY WARRANTY; without even the implied warranty of 11 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12 GNU General Public License for more details. 13 14 You should have received a copy of the GNU General Public License 15 along with this program. If not, see <http://www.gnu.org/licenses/>. 16 *) 17 18 19 (* Defines an abstract type of relative pathnames *) 20 21 type 'a path = string 22 type t = string 23 type local = string 24 25 let mpath = Umarshal.string 26 let m = mpath 27 let mlocal = mpath 28 29 let pathSeparatorChar = '/' 30 let pathSeparatorString = "/" 31 32 let concat p p' = 33 let l = String.length p in 34 if l = 0 then p' else 35 let l' = String.length p' in 36 if l' = 0 then p else 37 let p'' = Bytes.create (l + l' + 1) in 38 String.blit p 0 p'' 0 l; 39 Bytes.set p'' l pathSeparatorChar; 40 String.blit p' 0 p'' (l + 1) l'; 41 Bytes.to_string p'' 42 43 let empty = "" 44 45 let isEmpty p = String.length p = 0 46 47 let length p = 48 let l = ref 0 in 49 for i = 0 to String.length p - 1 do 50 if p.[i] = pathSeparatorChar then incr l 51 done; 52 !l 53 54 (* Add a name to the end of a path *) 55 let rcons n path = concat (Name.toString n) path 56 57 let toStringList p = Str.split (Str.regexp pathSeparatorString) p 58 59 (* Give a left-to-right list of names in the path *) 60 let toNames p = Safelist.map Name.fromString (toStringList p) 61 62 let child path name = concat path (Name.toString name) 63 64 let parent path = 65 try 66 let i = String.rindex path pathSeparatorChar in 67 String.sub path 0 i 68 with Not_found -> 69 empty 70 71 let finalName path = 72 try 73 let i = String.rindex path pathSeparatorChar + 1 in 74 Some (Name.fromString (String.sub path i (String.length path - i))) 75 with Not_found -> 76 if isEmpty path then 77 None 78 else 79 Some (Name.fromString path) 80 81 (* pathDeconstruct : path -> (name * path) option *) 82 let deconstruct path = 83 try 84 let i = String.index path pathSeparatorChar in 85 Some (Name.fromString (String.sub path 0 i), 86 String.sub path (i + 1) (String.length path - i - 1)) 87 with Not_found -> 88 if isEmpty path then 89 None 90 else 91 Some (Name.fromString path, empty) 92 93 let deconstructRev path = 94 try 95 let i = String.rindex path pathSeparatorChar in 96 Some (Name.fromString 97 (String.sub path (i + 1) (String.length path - i - 1)), 98 String.sub path 0 i) 99 with Not_found -> 100 if path = "" then 101 None 102 else 103 Some (Name.fromString path, empty) 104 105 let winAbspathRx = Rx.rx "([a-zA-Z]:)?(/|\\\\).*" 106 let unixAbspathRx = Rx.rx "/.*" 107 let is_absolute s = 108 if Sys.win32 || Sys.cygwin then Rx.match_string winAbspathRx s 109 else Rx.match_string unixAbspathRx s 110 111 (* Function string2path: string -> path 112 113 THIS IS THE CRITICAL FUNCTION. 114 115 Problem: What to do on argument "" ? 116 What we do: we raise Invalid_argument. 117 118 Problem: double slash within the argument, e.g., "foo//bar". 119 What we do: we raise Invalid_argument. 120 121 Problem: What if string2path is applied to an absolute path? We 122 want to disallow this, but, relative is relative. E.g., on Unix it 123 makes sense to have a directory with subdirectory "c:". Then, it 124 makes sense to synchronize on the path "c:". But this will go 125 badly if the Unix system synchronizes with a Windows system. 126 What we do: we check whether a path is relative using local 127 conventions, and raise Invalid_argument if not. If we synchronize 128 with a system with other conventions, then problems must be caught 129 elsewhere. E.g., the system should refuse to create a directory 130 "c:" on a Windows machine. 131 132 Problem: spaces in the argument, e.g., " ". Still not sure what to 133 do here. Is it possible to create a file with this name in Unix or 134 Windows? 135 136 Problem: trailing slashes, e.g., "foo/bar/". Shells with 137 command-line completion may produce these routinely. 138 What we do: we remove them. Moreover, we remove as many as 139 necessary, e.g., "foo/bar///" becomes "foo/bar". This may be 140 counter to conventions of some shells/os's, where "foo/bar///" 141 might mean "/". 142 143 Examples: 144 loop "hello/there" -> ["hello"; "there"] 145 loop "/hello/there" -> [""; "hello"; "there"] 146 loop "" -> [""] 147 loop "/" -> [""; ""] 148 loop "//" -> [""; ""; ""] 149 loop "c:/" ->["c:"; ""] 150 loop "c:/foo" -> ["c:"; "foo"] 151 *) 152 let fromString str = 153 let str0 = str in 154 let str = if Sys.win32 || Sys.cygwin then Fileutil.backslashes2forwardslashes str else str in 155 if is_absolute str then 156 raise (Util.Transient 157 (Printf.sprintf "The path '%s' is not a relative path" str)); 158 let str = Fileutil.removeTrailingSlashes str in 159 if str = "" then empty else 160 let rec loop p str = 161 try 162 let pos = String.index str pathSeparatorChar in 163 let name1 = String.sub str 0 pos in 164 if name1 = ".." then 165 raise (Util.Transient 166 (Printf.sprintf 167 "Reference to parent directory '..' not allowed \ 168 in path '%s'" str0)); 169 let str_res = 170 String.sub str (pos + 1) (String.length str - pos - 1) in 171 if pos = 0 || name1 = "." then begin 172 loop p str_res 173 end else 174 loop (child p (Name.fromString name1)) str_res 175 with 176 Not_found -> 177 if str = ".." then 178 raise (Util.Transient 179 (Printf.sprintf 180 "Reference to parent directory '..' not allowed \ 181 in path '%s'" str0)); 182 if str = "." then p else child p (Name.fromString str) 183 | Invalid_argument _ -> 184 raise(Invalid_argument "Path.fromString") in 185 loop empty str 186 187 let toString path = path 188 189 let compare p1 p2 = (Case.ops())#compare p1 p2 190 191 let toDebugString path = String.concat " / " (toStringList path) 192 193 let addSuffixToFinalName path suffix = path ^ suffix 194 195 let addToFinalName path suffix = 196 let l = String.length path in 197 assert (l > 0); 198 let i = try String.rindex path '/' with Not_found -> -1 in 199 let j = try String.rindex path '.' with Not_found -> -1 in 200 let j = if j <= i then l else j in 201 String.sub path 0 j ^ suffix ^ String.sub path j (l - j) 202 203 let addPrefixToFinalName path prefix = 204 try 205 let i = String.rindex path pathSeparatorChar + 1 in 206 let l = String.length path in 207 let l' = String.length prefix in 208 let p = Bytes.create (l + l') in 209 String.blit path 0 p 0 i; 210 String.blit prefix 0 p i l'; 211 String.blit path i p (i + l') (l - i); 212 Bytes.to_string p 213 with Not_found -> 214 assert (not (isEmpty path)); 215 prefix ^ path 216 217 (* Pref controlling whether symlinks are followed. *) 218 let followPred = Pred.create "follow" 219 ~category:(`Advanced `Sync) 220 ("Including the preference \\texttt{-follow \\ARG{pathspec}} causes Unison to \ 221 treat symbolic links matching \\ARG{pathspec} as `invisible' and \ 222 behave as if the object pointed to by the link had appeared literally \ 223 at this position in the replica. See \ 224 \\sectionref{symlinks}{Symbolic Links} for more details. \ 225 The syntax of \\ARG{pathspec} is \ 226 described in \\sectionref{pathspec}{Path Specification}.") 227 228 let followLink path = 229 Pred.test followPred (toString path) 230 231 let forceLocal p = p 232 let makeGlobal p = p