1structure internal_functions :> internal_functions = 2struct 3 4fun member e [] = false 5 | member e (h::t) = e = h orelse member e t 6 7fun equal x y = x = y 8 9fun spacify0 acc [] = List.rev acc 10 | spacify0 acc [x] = List.rev (x::acc) 11 | spacify0 acc (h::t) = spacify0 (" "::h::acc) t 12 13val spacify = String.concat o spacify0 [] 14 15fun dropWhile P [] = [] 16 | dropWhile P (l as (h::t)) = if P h then dropWhile P t else l 17 18fun find_unescaped cset ss = let 19 open Substring 20 val sz = size ss 21 fun recurse i = 22 if i >= sz then NONE 23 else 24 let val c = Substring.sub(ss,i) 25 in 26 if member c cset then SOME i 27 else if c = #"\\" then recurse (i + 2) 28 else recurse (i + 1) 29 end 30in 31 recurse 0 32end 33 34fun tokenize s = let 35 (* could be a call to tokens, but for escaped spaces getting in the way *) 36 open Substring 37 val ss = dropl Char.isSpace (full s) 38 fun recurse acc ss = 39 (* assumes first character of ss is not isSpace, or size ss = 0 *) 40 if size ss = 0 then List.rev acc 41 else 42 case find_unescaped [#" ", #"\t"] ss of 43 NONE => List.rev (string ss::acc) 44 | SOME i => let 45 val (t1, rest) = splitAt(ss, i) 46 in 47 recurse (string t1::acc) (dropl Char.isSpace rest) 48 end 49in 50 recurse [] ss 51end 52 53fun subst(from,to,on) = let 54 open Substring 55 val (from,to,on) = (full from, full to, full on) 56 val _ = size from > 0 orelse 57 raise Fail "empty from argument to `subst' function" 58 fun recurse acc ss = let 59 val (ok, rest) = position (string from) ss 60 in 61 if size rest > 0 then 62 recurse (to::ok::acc) (slice(rest, size from, NONE)) 63 else concat (List.rev (ok::acc)) 64 end 65in 66 recurse [] on 67end 68 69 70fun find_percent ss = let 71 open Substring 72 fun recurse acc ss = 73 case getc ss of 74 NONE => (full (String.implode (List.rev acc)), full "") 75 | SOME(c, ss') => let 76 in 77 case c of 78 #"\\" => let 79 in 80 case getc ss' of 81 NONE => (full (String.implode (List.rev (c::acc))), full "") 82 | SOME(c',ss'') => 83 if c' = #"%" orelse c' = #"\\" then 84 recurse (c'::acc) ss'' 85 else 86 recurse (c'::c::acc) ss'' 87 end 88 | _ => if c = #"%" then (full (String.implode(List.rev acc)), ss) 89 else recurse (c::acc) ss' 90 end 91in 92 recurse [] ss 93end 94 95fun pattern_match pattern object = let 96 open Substring 97 fun translate_pattern patss = let 98 val (pfx, rest) = find_percent patss 99 val sfx = if size rest > 0 then let 100 val (sfx, rest') = find_percent (slice(rest, 1, NONE)) 101 in 102 if size rest' > 0 then 103 raise Fail "Multiple % chars in pattern" 104 else 105 SOME sfx 106 end 107 else NONE 108 in 109 (pfx, sfx) 110 end 111 fun fromright (patss, i) (objss, j) = 112 if j = ~1 then NONE 113 else if i = ~1 then SOME (slice(objss, 0, SOME (j + 1))) 114 else let 115 val pc = sub(patss, i) 116 val oc = sub(objss, j) 117 in 118 if pc = oc then fromright(patss, i - 1) (objss, j - 1) 119 else NONE 120 end 121 122 val (patpfx, patsfx) = translate_pattern (full pattern) 123 val objss = full object 124in 125 if isPrefix (string patpfx) objss then let 126 val objrest = slice(objss, size patpfx, NONE) 127 in 128 case patsfx of 129 NONE => if size objrest = 0 then SOME "" else NONE 130 | SOME sfx => Option.map string 131 (fromright (sfx, size sfx - 1) 132 (objrest, size objrest - 1)) 133 end 134 else NONE 135end 136 137fun pcsubst (residue, pattern) = let 138 open Substring 139 val patss = full pattern 140 val resss = full residue 141 fun recurse acc ss = 142 case find_unescaped [#"%"] ss of 143 NONE => concat (List.rev (ss::acc)) 144 | SOME i => let 145 val (pfx, sfx) = splitAt(ss, i) 146 in 147 recurse (resss::pfx::acc) (slice(sfx, 1, NONE)) 148 end 149in 150 recurse [] (full pattern) 151end 152 153fun patsubst (from,to,arglist) = let 154 fun mapthis s = 155 case pattern_match from s of 156 NONE => s 157 | SOME stem => pcsubst(stem,to) 158in 159 spacify (map mapthis (tokenize arglist)) 160end 161 162fun split_to_directories (comps : parse_glob.t list) = let 163 open parse_glob 164 fun recurse h acc [] = List.rev (List.rev h::acc) 165 | recurse h acc (RE r :: rest) = recurse (RE r::h) acc rest 166 | recurse h acc (CHAR #"/" :: rest) = recurse [] (List.rev h::acc) rest 167 | recurse h acc (CHAR c :: rest) = recurse (CHAR c :: h) acc rest 168in 169 recurse [] [] comps 170end 171 172fun dirfiles dirname = let 173 val dirstrm = OS.FileSys.openDir dirname 174 fun recurse acc = 175 case OS.FileSys.readDir dirstrm of 176 NONE => "." :: ".." :: acc 177 | SOME fname => recurse (fname :: acc) 178in 179 recurse [] before OS.FileSys.closeDir dirstrm 180end 181 182fun safeIsDir s = 183 OS.FileSys.isDir s handle OS.SysErr _ => false 184 185fun diag s = TextIO.output(TextIO.stdErr, s) 186 187fun wildcard s = 188 if s = "" then [""] 189 else let 190 open parse_glob 191 val comps = parse_glob_components s 192 val split_comps = split_to_directories comps 193 fun initial_split d l k = 194 case l of 195 h::t => if null h then 196 initial_split "/" t (fn (d,s,r) => k (d,s ^ "/", r)) 197 else k (d,"", l) 198 | [] => k (d,"", l) 199 val (starting_dir,pfx, rest) = 200 initial_split (OS.FileSys.getDir()) split_comps (fn x => x) 201 fun recurse curpfx curdir complist : string list = 202 case complist of 203 c::cs => (* c must be non-null *) 204 let 205 val dotfiles_ok = case c of CHAR #"." :: _ => true 206 | _ => false 207 val re = toRegexp c 208 val files = Listsort.sort String.compare (dirfiles curdir) 209 val m = regexpMatch.match re 210 val require_dir = not (null cs) 211 val (_, _, cs') = initial_split "" cs (fn x => x) 212 val slashes = if require_dir then "/" else "" 213 fun check s = 214 m s andalso 215 (dotfiles_ok orelse String.sub(s,0) <> #".") andalso 216 (not require_dir orelse 217 safeIsDir (OS.Path.concat(curdir, s))) 218 handle e => raise Fail (s ^ " - " ^ exnMessage e) 219 in 220 case List.filter check files of 221 [] => [] 222 | fs => 223 let 224 val newpfxs = map (fn s => curpfx ^ s ^ slashes) fs 225 in 226 if null cs' then newpfxs 227 else let 228 val newdirs = map (fn d => OS.Path.concat(curdir, d)) fs 229 val more_results : string list list = 230 ListPair.map (fn (pfx,dir) => recurse pfx dir cs') 231 (newpfxs,newdirs) 232 in 233 List.concat more_results 234 end 235 end 236 end 237 | [] => raise Fail "wildcard.recurse: should never happen" 238 in 239 case rest of 240 [] => (* happens if input was a series of forward slashes *) [s] 241 | _ => case recurse pfx starting_dir rest of [] => [] | x => x 242 end 243 244fun get_first f [] = NONE 245 | get_first f (h::t) = (case f h of NONE => get_first f t | x => x) 246 247fun which arg = 248 let 249 open OS.FileSys Systeml 250 val sepc = if isUnix then #":" else #";" 251 fun check p = 252 let 253 val fname = OS.Path.concat(p, arg) 254 in 255 if access (fname, [A_READ, A_EXEC]) then SOME fname else NONE 256 end 257 fun smash NONE = "" | smash (SOME s) = s 258 in 259 case OS.Process.getEnv "PATH" of 260 SOME path => 261 let 262 val paths = (if isUnix then [] else ["."]) @ 263 String.fields (fn c => c = sepc) path 264 in 265 smash (get_first check paths) 266 end 267 | NONE => if isUnix then "" else smash (check ".") 268 end 269 270fun shell arg = 271 let 272 open Unix 273 274 (* TODO This gets rid of all carriage returns; should only replace 275 those paired with a newline *) 276 fun fix_nls s = 277 let 278 val s = String.translate (fn c => if c = #"\r" then "" else String.str c) s 279 val s = if String.isSuffix "\n" s then 280 String.substring (s, 0, String.size s - 1) 281 else s 282 in 283 String.map (fn c => if c = #"\n" then #" " else c) s 284 end 285 286 val proc = execute ("/bin/sh", ["-c", arg]) 287 val ins = textInstreamOf proc 288 val str = fix_nls (TextIO.inputAll ins) 289 in 290 if OS.Process.isSuccess (reap proc) then str else "" 291 end 292 handle OS.SysErr _ => "" 293 294fun function_call (fnname, args, eval) = let 295 open Substring 296in 297 case fnname of 298 "if" => 299 if length args <> 2 andalso length args <> 3 then 300 raise Fail "Bad number of arguments to `if' function." 301 else let 302 val condition = dropr Char.isSpace (hd args) 303 val condition_evalled = eval condition 304 in 305 if condition_evalled <> "" then eval (List.nth(args, 1)) 306 else if length args = 3 then eval (List.nth(args, 2)) 307 else "" 308 end 309 | "subst" => 310 if length args <> 3 then 311 raise Fail "Bad number of arguments to `subst' function." 312 else let 313 val args_evalled = map eval args 314 val tuple = case args_evalled of 315 [x,y,z] => (x,y,z) 316 | _ => raise Fail "Can't happen" 317 in 318 subst tuple 319 end 320 | "patsubst" => 321 if length args <> 3 then 322 raise Fail "Bad number of arguments to `patsubst' function." 323 else let 324 val args_evalled = map eval args 325 val tuple = case args_evalled of 326 [x,y,z] => (x,y,z) 327 | _ => raise Fail "Can't happen" 328 in 329 patsubst tuple 330 end 331 | "protect" => if length args <> 1 then 332 raise Fail "Bad number of arguments to `protect' function." 333 else 334 Systeml.protect (eval (hd args)) 335 | "dprot" => if length args <> 1 then 336 raise Fail "Bad number of arguments to 'dprot' function." 337 else subst(" ", "\\ ", eval (hd args)) 338 | "findstring" => if length args <> 2 then 339 raise Fail "Bad number of arguments to 'findstring' \ 340 \function." 341 else let 342 val (findstr, instr) = case map eval args of 343 [x,y] => (x,y) 344 | _ => raise Fail "Can't happen" 345 open Substring 346 val (pfx,sfx) = position findstr (full instr) 347 in 348 if size sfx = 0 then "" else findstr 349 end 350 | "which" => if length args <> 1 then 351 raise Fail "Bad number of arguments to 'which' function" 352 else let 353 val arg_evalled = eval (hd args) 354 in 355 which arg_evalled 356 end 357 | "wildcard" => if length args <> 1 then 358 raise Fail "Bad number of arguments to 'wildcard' function" 359 else let 360 val args' = tokenize (Substring.string (hd args)) 361 val args_evalled = map (eval o Substring.full) args' 362 in 363 spacify (List.concat (map wildcard args_evalled)) 364 end 365 | "shell" => if length args <> 1 then 366 raise Fail "Bad number of arguments to 'shell' function" 367 else let 368 val arg_evalled = eval (hd args) 369 in 370 shell arg_evalled 371 end 372 | _ => raise Fail ("Unknown function name: "^fnname) 373end 374 375 376end (* struct *) 377