Something went wrong. Try again.
An OCaml implementation of glob(3)
Something went wrong. Try again.
123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271(*--------------------------------------------------------------------------- Copyright (c) 2026 The ocaml-glob programmers. All rights reserved. SPDX-License-Identifier: ISC ---------------------------------------------------------------------------*)
type path = string
let path_of_string s = s
module Options = struct type t = { mark : bool; no_sort : bool }
let default = { mark = false; no_sort = false }
let make ?(no_sort = default.no_sort) ?(mark = default.mark) () = { mark; no_sort }
let pp ppf v = Fmt.record [ Fmt.field "mark" (fun v -> v.mark) Fmt.bool ] ppf v
let mark t = t.mark let no_sort t = t.no_sortend
type char_class = Chars of char list | Char_range of (char * char)
let pp_char_class ppf = function | Chars cs -> (Fmt.brackets @@ Fmt.(list ~sep:Fmt.comma Fmt.(quote ~mark:"\'" char))) ppf cs | Char_range (a, b) -> Fmt.pf ppf "%c-%c" a b
let char_class_of_chars cs = let rec loop cs acc = function | c1 :: '-' :: c2 :: rest -> let acc = match cs with [] -> acc | cs -> Chars (List.rev cs) :: acc in loop [] (Char_range (c1, c2) :: acc) rest | c :: rest -> loop (c :: cs) acc rest | [] -> ( match cs with | [] -> List.rev acc | cs -> List.rev (Chars (List.rev cs) :: acc)) in loop [] [] cs
let char_class_to_string = function | Chars cs -> let len = List.length cs in String.init len (List.nth cs) | Char_range (a, b) -> String.make 1 a ^ "-" ^ String.make 1 b
let rec list_mem eq = function | [] -> false | x :: rest -> eq x || list_mem eq rest
let compile_char_class = function | Chars cs -> fun c -> list_mem (Char.equal c) cs | Char_range (c1, c2) -> fun c -> let i = Char.code c in let c1_code = Char.code c1 in let c2_code = Char.code c2 in if c1_code <= c2_code then i >= c1_code && i <= c2_code else false
let compile_char_classes css = let rec loop cs v = match cs with [] -> false | c :: cs -> compile_char_class c v || loop cs v in loop css
type component = | Dir_sep | String of string | Question | Star | Range of char_class list | Complement of char_class list
let pp_component ppf = function | Dir_sep -> Fmt.string ppf "dir_sep" | String s -> Fmt.(quote string) ppf s | Question -> Fmt.string ppf "?" | Star -> Fmt.string ppf "*" | Range cc -> Fmt.pf ppf "[%a]" Fmt.(list ~sep:Fmt.comma pp_char_class) cc | Complement cc -> Fmt.pf ppf "[!%a]" Fmt.(list ~sep:Fmt.comma pp_char_class) cc
type t = { dir_sep : char; components : component list }
let pp ppf t = let pp_r ppf t = Fmt.record [ Fmt.field "dir_sep" (fun t -> t.dir_sep) Fmt.char; Fmt.field "components" (fun t -> t.components) Fmt.(brackets @@ list ~sep:Fmt.comma pp_component); ] ppf t in Fmt.braces pp_r ppf t
let default_dir_sep = if Sys.win32 then '\\' else '/'let to_components t = t.components
let of_components ?(dir_sep = default_dir_sep) components = { dir_sep; components }
let of_string ?(dir_sep = default_dir_sep) s = let buf = Buffer.create 16 in let add_buf cs = if Buffer.length buf <> 0 then begin let v = String (Buffer.contents buf) in Buffer.clear buf; v :: cs end else cs in let peek s idx = match String.get s idx with | exception Invalid_argument _ -> None | c -> Some c in let rec normal cs idx = match String.get s idx with | exception Invalid_argument _ -> List.rev (add_buf cs) | '*' -> let cs = add_buf cs in normal (Star :: cs) (idx + 1) | '?' -> let cs = add_buf cs in normal (Question :: cs) (idx + 1) | '[' when peek s (idx + 1) <> Some '!' -> let cs = add_buf cs in let ccs, idx = in_range (idx + 1) in normal (Range ccs :: cs) idx | '[' when peek s (idx + 1) = Some '!' -> let cs = add_buf cs in (* Skip the ! *) let ccs, idx = in_range (idx + 2) in normal (Complement ccs :: cs) idx | c when Char.equal dir_sep c -> let cs = add_buf cs in normal (Dir_sep :: cs) (idx + 1) | c -> Buffer.add_char buf c; normal cs (idx + 1) and in_range_cs chars idx = let first_bracket_idx = idx - 1 in let rec aux chars idx = match String.get s idx with | exception Invalid_argument _ -> Fmt.failwith "Unclosed character class: char # %i from `%s'" idx s | ']' when Int.equal (first_bracket_idx + 1) idx -> aux (']' :: chars) (idx + 1) | ']' -> (List.rev chars, idx + 1) | c -> aux (c :: chars) (idx + 1) in aux chars idx and in_range idx = let cs, idx = in_range_cs [] idx in let cs = char_class_of_chars cs in (cs, idx) in match normal [] 0 with | components -> Ok { dir_sep; components } | exception Failure msg -> Error msg
let to_string t = let buf = Buffer.create 16 in let add_literal_string s = String.iter (fun c -> match c with | '*' | '?' | '[' -> Buffer.add_char buf '['; Buffer.add_char buf c; Buffer.add_char buf ']' | c when Char.equal c t.dir_sep -> Buffer.add_char buf '['; Buffer.add_char buf c; Buffer.add_char buf ']' | c -> Buffer.add_char buf c) s in List.iter (function | Dir_sep -> Buffer.add_char buf t.dir_sep | String s -> add_literal_string s | Question -> Buffer.add_char buf '?' | Star -> Buffer.add_char buf '*' | Range cs -> Buffer.add_char buf '['; List.iter (fun c -> Buffer.add_string buf (char_class_to_string c)) cs; Buffer.add_char buf ']' | Complement cs -> Buffer.add_string buf "[!"; List.iter (fun c -> Buffer.add_string buf (char_class_to_string c)) cs; Buffer.add_char buf ']') t.components; Buffer.contents buf
let dir_sep = Dir_seplet string s = String slet question = Questionlet star = Starlet range c1 c2 = Range [ Char_range (c1, c2) ]let ranges cs = Range cslet complement c1 c2 = Complement [ Char_range (c1, c2) ]let complements cs = Complement cs
let sub_string ~off ~len s = try Some (String.sub s off len) with Invalid_argument _ -> None
let matches ?options glob path = ignore options; let rec matches i path = function | [] -> Int.equal (String.length path) i | (Dir_sep | String _ | Question | Range _ | Complement _) :: _ when i >= String.length path -> false | Dir_sep :: rest -> let b = Char.equal (String.get path i) glob.dir_sep in b && matches (i + 1) path rest | String s :: rest -> ( let s_len = String.length s in match sub_string path ~off:i ~len:s_len with | None -> false | Some sub -> String.equal s sub && matches (i + s_len) path rest) | Star :: rest -> let rest_len = String.length path - i in let break_len = match String.index_from_opt path i glob.dir_sep with | Some l -> l - i | None -> rest_len in (* Star may consume 0..break_len characters: try each length in order and let the suffix decide. *) let rec backtrack j = if matches (i + j) path rest then Some j else if j >= break_len then None else backtrack (j + 1) in Option.is_some (backtrack 0) | Question :: rest -> let b = not (Char.equal (String.get path i) glob.dir_sep) in b && matches (i + 1) path rest | Range cs :: rest -> (* some staged meta-programming would be nice right about now... *) let pred = compile_char_classes cs in pred (String.get path i) && matches (i + 1) path rest | Complement cs :: rest -> let pred c = not (compile_char_classes cs c) in pred (String.get path i) && matches (i + 1) path rest in matches 0 path glob.components
let split t = let rec loop (acc, saw_dir_sep) = function | [] -> (List.rev acc, [], saw_dir_sep) | Dir_sep :: rest -> loop (String.make 1 t.dir_sep :: acc, true) rest | String s :: rest -> loop (s :: acc, saw_dir_sep) rest | rest -> (List.rev acc, rest, saw_dir_sep) in let static, dyn, saw_dir_sep = loop ([], false) t.components in match (saw_dir_sep, static) with | false, [ s ] -> ("", String s :: dyn) | _ -> (String.concat "" static, dyn)