Filename.chop_suffix_opt (#2125)

Changes

@@ -136,6 +136,9 @@ Working version
 - GPR#2119: clarify the documentation of Set.diff
   (Gabriel Scherer, suggestion by John Skaller)
 
+- MPR#7812, GPR#2125: Add Filename.chop_suffix_opt
+  (Alain Frisch, review by Nicolás Ojeda Bär, suggestion by whitequark)
+
 ### Other libraries:
 
 - GPR#1061: Add ?follow parameter to Unix.link. This allows hardlinking

stdlib/filename.ml

@@ -83,6 +83,18 @@ module Unix = struct
     String.length name >= String.length suff &&
     String.sub name (String.length name - String.length suff)
                     (String.length suff) = suff
+
+  let chop_suffix_opt ~suffix filename =
+    let len_s = String.length suffix and len_f = String.length filename in
+    if len_f >= len_s then
+      let r = String.sub filename (len_f - len_s) len_s in
+      if r = suffix then
+        Some (String.sub filename 0 (len_f - len_s))
+      else
+        None
+    else
+      None
+
   let temp_dir_name =
     try Sys.getenv "TMPDIR" with Not_found -> "/tmp"
   let quote = generic_quote "'\\''"
@@ -110,6 +122,19 @@ module Win32 = struct
    (let s = String.sub name (String.length name - String.length suff)
                             (String.length suff) in
     String.lowercase_ascii s = String.lowercase_ascii suff)
+
+  let chop_suffix_opt ~suffix filename =
+    let len_s = String.length suffix and len_f = String.length filename in
+    if len_f >= len_s then
+      let r = String.sub filename (len_f - len_s) len_s in
+      if String.lowercase_ascii r = String.lowercase_ascii suffix then
+        Some (String.sub filename 0 (len_f - len_s))
+      else
+        None
+    else
+      None
+
+
   let temp_dir_name =
     try Sys.getenv "TEMP" with Not_found -> "."
   let quote s =
@@ -163,6 +188,7 @@ module Cygwin = struct
   let is_relative = Win32.is_relative
   let is_implicit = Win32.is_implicit
   let check_suffix = Win32.check_suffix
+  let chop_suffix_opt = Win32.chop_suffix_opt
   let temp_dir_name = Unix.temp_dir_name
   let quote = Unix.quote
   let basename = generic_basename is_dir_sep current_dir_name
@@ -170,23 +196,27 @@ module Cygwin = struct
 end
 
 let (current_dir_name, parent_dir_name, dir_sep, is_dir_sep,
-     is_relative, is_implicit, check_suffix, temp_dir_name, quote, basename,
+     is_relative, is_implicit, check_suffix, chop_suffix_opt,
+     temp_dir_name, quote, basename,
      dirname) =
   match Sys.os_type with
   | "Win32" ->
       (Win32.current_dir_name, Win32.parent_dir_name, Win32.dir_sep,
        Win32.is_dir_sep,
        Win32.is_relative, Win32.is_implicit, Win32.check_suffix,
+       Win32.chop_suffix_opt,
        Win32.temp_dir_name, Win32.quote, Win32.basename, Win32.dirname)
   | "Cygwin" ->
       (Cygwin.current_dir_name, Cygwin.parent_dir_name, Cygwin.dir_sep,
        Cygwin.is_dir_sep,
        Cygwin.is_relative, Cygwin.is_implicit, Cygwin.check_suffix,
+       Cygwin.chop_suffix_opt,
        Cygwin.temp_dir_name, Cygwin.quote, Cygwin.basename, Cygwin.dirname)
   | _ -> (* normally "Unix" *)
       (Unix.current_dir_name, Unix.parent_dir_name, Unix.dir_sep,
        Unix.is_dir_sep,
        Unix.is_relative, Unix.is_implicit, Unix.check_suffix,
+       Unix.chop_suffix_opt,
        Unix.temp_dir_name, Unix.quote, Unix.basename, Unix.dirname)
 
 let concat dirname filename =

stdlib/filename.mli

@@ -42,12 +42,33 @@ val is_implicit : string -> bool
 
 val check_suffix : string -> string -> bool
 (** [check_suffix name suff] returns [true] if the filename [name]
-   ends with the suffix [suff]. *)
+    ends with the suffix [suff].
+
+    Under Windows ports (including Cygwin), comparison is
+    case-insensitive, relying on [String.lowercase_ascii].  Note that
+    this does not match exactly the interpretation of case-insensitive
+    filename equivalence from Windows.  *)
 
 val chop_suffix : string -> string -> string
 (** [chop_suffix name suff] removes the suffix [suff] from
    the filename [name]. The behavior is undefined if [name] does not
-   end with the suffix [suff]. *)
+   end with the suffix [suff]. It is thus recommmended to use
+   [chop_suffix_opt] instead.
+*)
+
+val chop_suffix_opt: suffix:string -> string -> string option
+(** [chop_suffix_opt ~suffix filename] removes the suffix from
+    the [filename] if possible, or returns [None] if the
+    filename does not end with the suffix.
+
+    Under Windows ports (including Cygwin), comparison is
+    case-insensitive, relying on [String.lowercase_ascii].  Note that
+    this does not match exactly the interpretation of case-insensitive
+    filename equivalence from Windows.
+
+    @since 4.08
+*)
+
 
 val extension : string -> string
 (** [extension name] is the shortest suffix [ext] of [name0] where:

testsuite/tests/lib-filename/ocamltests

@@ -1 +1,2 @@
 extension.ml
+suffix.ml

testsuite/tests/lib-filename/suffix.ml

@@ -0,0 +1,27 @@
+(* TEST
+*)
+
+let () =
+  let test ~suffix name exp =
+    let r1 = Filename.chop_suffix_opt ~suffix name <> None in
+    let r2 = Filename.check_suffix name suffix in
+    assert (r1 = r2);
+    assert (r1 = exp)
+  in
+  let full_test ~suffix name =
+    test ~suffix name true;
+    match Filename.chop_suffix_opt ~suffix name with
+    | None -> assert false
+    | Some base -> assert (base ^ suffix = name)
+  in
+  let win32 = Sys.os_type = "Win32" || Sys.os_type = "Cygwin" in
+  full_test ~suffix:".txt" "foo.txt";
+  full_test ~suffix:"txt" "foo.txt";
+  full_test ~suffix:"" "foo.txt";
+  full_test ~suffix:"" "";
+  test ~suffix:".txt" "f" false;
+  test ~suffix:".txt" "" false;
+  test ~suffix:".txt" "foo.txt.bak" false;
+  test ~suffix:".txt" "foo.TXT" win32;
+  if win32 then
+    assert (Filename.chop_suffix_opt ~suffix:".txt" "foo.TXT" = Some "foo")