Fixed the implementation of Filename.{split_,}ext

src/future.ml

@@ -375,11 +375,11 @@ module Scheduler = struct
           let (similar, rest) = List.partition ~f:(eq_ext x) xs in
           (x :: similar) :: group_by_ext rest in
      let pp_ext ppf filename =
-       let ext = match Filename.ext filename with
+       let ext =
-         | Some s when s.[0] = '.' ->
+         match Filename.extension filename with
-            String.sub ~pos:1 ~len:(String.length s - 1) s
+         | "" -> ""
-         | Some s -> s
+         | s -> String.sub ~pos:1 ~len:(String.length s - 1) s
-         | None -> "" in
+       in
        Format.fprintf ppf "%s" ext in
      let pp_comma ppf () = Format.fprintf ppf "," in
      let pp_group ppf = function

src/gen_rules.ml

@@ -492,9 +492,9 @@ module Gen(P : Params) = struct
     let files =
       List.filter_map (String_map.values modules) ~f:(fun m -> Module.file ~dir m ml_kind)
       |> List.map ~f:(fun fn ->
-        match ml_kind, Filename.ext (Path.to_string fn) with
+        match ml_kind, Filename.extension (Path.to_string fn) with
-        | Impl, Some ".ml"  -> Arg_spec.Dep fn
+        | Impl, ".ml"  -> Arg_spec.Dep fn
-        | Intf, Some ".mli" -> Dep fn
+        | Intf, ".mli" -> Dep fn
         | Impl, _ -> S [A "-impl"; Dep fn]
         | Intf, _ -> S [A "-intf"; Dep fn])
     in
@@ -651,12 +651,10 @@ module Gen(P : Params) = struct
      +-----------------------------------------------------------------+ *)
 
   let pp_fname fn =
-    match Filename.split_ext fn with
+    let fn, ext = Filename.split_extension fn in
-    | None -> fn ^ ".pp"
+    (* We need to to put the .pp before the .ml so that the compiler realises that
-    | Some (fn, ext) ->
+       [foo.pp.mli] is the interface for [foo.pp.ml] *)
-      (* We need to to put the .pp before the .ml so that the compiler realises that
+    fn ^ ".pp" ^ ext
-         [foo.pp.mli] is the interface for [foo.pp.ml] *)
-      fn ^ ".pp" ^ ext
 
   let pped_module ~dir (m : Module.t) ~f =
     let ml_pp_fname = pp_fname m.ml_fname in
@@ -1136,9 +1134,7 @@ module Gen(P : Params) = struct
                cmi exists and reads it instead of re-creating it, which
                could create a race condition. *)
             ([ "-intf-suffix"
-             ; match Filename.ext m.ml_fname with
+             ; Filename.extension m.ml_fname
-             | None -> ""
-             | Some ext -> ext
              ],
              [Module.cm_file m ~dir Cmi], [])
           | Cmi, None -> assert false

src/import.ml

@@ -279,20 +279,48 @@ end
 module Filename = struct
   include Filename
 
-  let split_ext fn =
+  (* Return the index of the start of the extension, using the same semantic as
-    match String.rindex fn '.' with
+     [Filename.extension] in 4.04 *)
-    | exception Not_found -> None
+  let extension_start =
-    | i ->
+    (* This is from the win32 implementation, but it is acceptable for the usage we make
-      Some
+       of it in this function and covers all platforms. *)
-        (String.sub fn ~pos:0 ~len:i,
+    let is_dir_sep = function
-         String.sub fn ~pos:i ~len:(String.length fn - i))
+      | '/' | '\\' | ':' -> true
+      | _ -> false
+    in
+    let rec check_at_least_one_non_dot s len candidate i =
+      if i < 0 then
+        len
+      else
+        match s.[i] with
+        | '.' ->
+          check_at_least_one_non_dot s len candidate (i - 1)
+        | c ->
+          if is_dir_sep c then
+            len
+          else
+            candidate
+    in
+    let rec search_dot s len i =
+      if i <= 0 then
+        len
+      else
+        match s.[i] with
+        | '.' -> check_at_least_one_non_dot s len i (i - 1)
+        | c   -> if is_dir_sep c then len else search_dot s len (i - 1)
+    in
+    fun s ->
+      let len = String.length s in
+      search_dot s len (len - 1)
 
-  let ext fn =
+  let split_extension fn =
-    match String.rindex fn '.' with
+    let i = extension_start fn in
-    | exception Not_found -> None
+    (String.sub fn ~pos:0 ~len:i,
-    | i ->
+     String.sub fn ~pos:i ~len:(String.length fn - i))
-      Some
+
-        (String.sub fn ~pos:i ~len:(String.length fn - i))
+  let extension fn =
+    let i = extension_start fn in
+    String.sub fn ~pos:i ~len:(String.length fn - i)
 end
 
 module Option = struct

src/jbuild_load.ml

@@ -154,8 +154,8 @@ let load ?(extra_ignored_subtrees=Path.Set.empty) () =
       let files = File_tree.Dir.files dir in
       let pkgs =
         String_set.fold files ~init:pkgs ~f:(fun fn acc ->
-          match Filename.split_ext fn with
+          match Filename.split_extension fn with
-          | Some (pkg, ".opam") when pkg <> "" ->
+          | (pkg, ".opam") when pkg <> "" ->
             let version_from_opam_file =
               let lines = lines_of_file (Path.relative path fn |> Path.to_string) in
               List.find_map lines ~f:(fun s ->

test/expect-tests/expect_test.mll

@@ -107,7 +107,7 @@ let main () =
 
   let corrected_fn = fn ^ ".corrected" in
   (* Temporary hack: *)
-  (* Sys.chdir "../.."; *)
+  if Filename.basename (Sys.getcwd ()) = "default" then Sys.chdir "../..";
   if txt <> res then begin
     let oc = open_out_bin corrected_fn in
     output_string oc res;

test/expect-tests/filename.mlt

@@ -0,0 +1,56 @@
+(* -*- tuareg -*- *)
+
+#warnings "-40";;
+
+open Jbuilder;;
+open Import;;
+
+Filename.extension "toto.titi";;
+[%%expect{|
+- : string = ".titi"
+|}]
+
+Filename.extension "toto.";;
+[%%expect{|
+- : string = "."
+|}]
+
+Filename.extension ".";;
+[%%expect{|
+- : string = ""
+|}]
+
+Filename.extension ".titi";;
+[%%expect{|
+- : string = ""
+|}]
+
+Filename.extension ".a";;
+[%%expect{|
+- : string = ""
+|}]
+
+Filename.extension "a.";;
+[%%expect{|
+- : string = "."
+|}]
+
+Filename.extension "a.a";;
+[%%expect{|
+- : string = ".a"
+|}]
+
+Filename.extension "truc/a.a";;
+[%%expect{|
+- : string = ".a"
+|}]
+
+Filename.extension "truc/.a";;
+[%%expect{|
+- : string = ""
+|}]
+
+Filename.extension "truc/a.";;
+[%%expect{|
+- : string = "."
+|}]

test/expect-tests/jbuild

@@ -15,3 +15,10 @@
          (glob_files ${ROOT}/vendor/re/*.cmi)
          (files_recursively_in findlib-db)))
   (action (chdir ${ROOT} (run ${exe:expect_test.bc} ${<})))))
+
+(alias
+ ((name runtest)
+  (deps (filename.mlt
+         (glob_files ${ROOT}/src/*.cmi)
+         (glob_files ${ROOT}/vendor/re/*.cmi)))
+  (action (chdir ${ROOT} (run ${exe:expect_test.bc} ${<})))))