New functions: trim-short-suffix, trim-long-suffix.

* lib.c, lib.h (chk_substrdup): New function.

* stream.c, stream.h (trim_short_suffix, trim_long_suffix):
New functions.
(stream_init): trim-short-suffix and trim-long-suffix
intrinsics registered.

* tests/018/path.tl: New tests.

* txr.1: Documented.

* stdlib/doc-syms.tl: Updated.

7 files changed, 191 insertions, 0 deletions

diff --git a/lib.c b/lib.c
index 006036a9..0e8bbbb1 100644
--- a/lib.c
+++ b/lib.c
@@ -4064,6 +4064,21 @@ wchar_t *chk_strdup(const wchar_t *str)
   return copy;
 }
 
+wchar_t *chk_substrdup(const wchar_t *str, size_t off, size_t len)
+{
+  size_t size = wcslen(str) + 1, nchar;
+  wchar_t *copy;
+  if (off >= size - 1)
+    return chk_strdup(L"");
+  if (off + len < off)
+    uw_throw(error_s, lit("string size overflow"));
+  nchar = min(size - off, len + 1);
+  copy = chk_wmalloc(nchar);
+  wmemcpy(copy, str, nchar - 1);
+  copy[nchar - 1] = 0;
+  return copy;
+}
+
 char *chk_strdup_utf8(const char *str)
 {
   size_t nchar = strlen(str) + 1;
diff --git a/lib.h b/lib.h
index de4f858a..07ff1edf 100644
--- a/lib.h
+++ b/lib.h
@@ -717,6 +717,7 @@ mem_t *chk_manage_vec(mem_t *old, size_t oldfilled, size_t newfilled,
 wchar_t *chk_wmalloc(size_t nwchar);
 wchar_t *chk_wrealloc(wchar_t *, size_t nwchar);
 wchar_t *chk_strdup(const wchar_t *str);
+wchar_t *chk_substrdup(const wchar_t *str, size_t off, size_t len);
 char *chk_strdup_utf8(const char *str);
 unsigned char *chk_strdup_8bit(const wchar_t *str);
 mem_t *chk_copy_obj(mem_t *orig, size_t size);
diff --git a/stdlib/doc-syms.tl b/stdlib/doc-syms.tl
index b2bfa33e..c4a116c4 100644
--- a/stdlib/doc-syms.tl
+++ b/stdlib/doc-syms.tl
@@ -1922,7 +1922,9 @@
       ("trie-lookup-feed-char" "N-014E6D7B")
       ("trie-value-at" "N-012A1BAD")
       ("trim-left" "N-00CF29CC")
+      ("trim-long-suffix" "N-03CAC692")
       ("trim-right" "N-00CF29CC")
+      ("trim-short-suffix" "N-03CAC692")
       ("trim-str" "N-00E6E63B")
       ("true" "N-00373D97")
       ("trunc" "D-005C")
diff --git a/stream.c b/stream.c
index 1227113e..f1a3deb0 100644
--- a/stream.c
+++ b/stream.c
@@ -5087,6 +5087,68 @@ val long_suffix(val name, val alt_in)
   }
 }
 
+val trim_short_suffix(val name)
+{
+  val self = lit("trim-short-suffix");
+  const wchar_t *psc = coerce(const wchar_t *, path_sep_chars);
+  const wchar_t *str = c_str(name, self);
+  const wchar_t *dot = wcsrchr(str, '.');
+  const wchar_t *sl = if3(dot, wcspbrk(dot + 1, psc), 0);
+  int sl_trail = if3(sl, sl[wcsspn(sl, psc)] == 0, 0);
+
+  if (!dot || (sl && sl[1] && !sl_trail) || dot == str || wcschr(psc, dot[-1])) {
+    return name;
+  } else {
+    size_t off = dot - str;
+    if (sl) {
+      size_t slsz = wcslen(sl) + 1;
+      size_t nchar = off + slsz;
+      wchar_t *out = chk_wmalloc(nchar);
+      wmemcpy(out, str, off);
+      wmemcpy(out + off, sl, slsz);
+      return string_own(out);
+    } else {
+      wchar_t *pref = chk_substrdup(str, 0, dot - str);
+      return string_own(pref);
+    }
+  }
+}
+
+val trim_long_suffix(val name)
+{
+  val self = lit("trim-long-suffix");
+  const wchar_t *psc = coerce(const wchar_t *, path_sep_chars);
+  const wchar_t *str = c_str(name, self);
+  const wchar_t *dot = wcschr(str, '.');
+
+  {
+    const wchar_t *sl;
+
+    while (dot && (sl = wcspbrk(dot, psc)) && sl[1] && sl[wcsspn(sl, psc)] != 0)
+      dot = wcschr(sl + 1, '.');
+
+    if (dot && (dot == str || wcschr(psc, dot[-1])))
+      dot = wcschr(dot + 1, '.');
+
+    if (!dot || dot == str) {
+      return name;
+    } else {
+      size_t off = dot - str;
+      if (sl) {
+        size_t slsz = wcslen(sl) + 1;
+        size_t nchar = off + slsz;
+        wchar_t *out = chk_wmalloc(nchar);
+        wmemcpy(out, str, off);
+        wmemcpy(out + off, sl, slsz);
+        return string_own(out);
+      } else {
+        wchar_t *pref = chk_substrdup(str, 0, dot - str);
+        return string_own(pref);
+      }
+    }
+  }
+}
+
 val path_cat(val dir_name, val base_name)
 {
   val dl = length_str(dir_name);
@@ -5409,6 +5471,8 @@ void stream_init(void)
   reg_fun(intern(lit("dir-name"), user_package), func_n1(dir_name));
   reg_fun(intern(lit("short-suffix"), user_package), func_n2o(short_suffix, 1));
   reg_fun(intern(lit("long-suffix"), user_package), func_n2o(long_suffix, 1));
+  reg_fun(intern(lit("trim-short-suffix"), user_package), func_n1(trim_short_suffix));
+  reg_fun(intern(lit("trim-long-suffix"), user_package), func_n1(trim_long_suffix));
   reg_fun(intern(lit("path-cat"), user_package), func_n0v(path_vcat));
   reg_varl(intern(lit("path-sep-chars"), user_package), static_str(path_sep_chars));
   reg_fun(intern(lit("get-indent-mode"), user_package), func_n1(get_indent_mode));
diff --git a/stream.h b/stream.h
index 9f3e326f..07c2bb80 100644
--- a/stream.h
+++ b/stream.h
@@ -256,6 +256,8 @@ val base_name(val path, val suff);
 val dir_name(val path);
 val short_suffix(val name, val alt_in);
 val long_suffix(val name, val alt_in);
+val trim_short_suffix(val name);
+val trim_long_suffix(val name);
 val path_cat(val dir_name, val base_name);
 val make_byte_input_stream(val obj);
 val iobuf_get(void);
diff --git a/tests/018/path.tl b/tests/018/path.tl
index aaaa6e11..62dbda6c 100644
--- a/tests/018/path.tl
+++ b/tests/018/path.tl
@@ -86,6 +86,54 @@
   (long-suffix "a.b/c.///") ".")
 
 (mtest
+  (trim-short-suffix "") ""
+  (trim-short-suffix ".") "."
+  (trim-short-suffix "/.") "/."
+  (trim-short-suffix ".b") ".b"
+  (trim-short-suffix ".a.b") ".a"
+  (trim-short-suffix ".a.b.c") ".a.b"
+  (trim-short-suffix "/.b") "/.b"
+  (trim-short-suffix "/.b/") "/.b/"
+  (trim-short-suffix "/.b//") "/.b//"
+  (trim-short-suffix "a.b") "a"
+  (trim-short-suffix "/a.b") "/a"
+  (trim-short-suffix "/a.b/") "/a/"
+  (trim-short-suffix "/a.b//") "/a//"
+  (trim-short-suffix "a.") "a"
+  (trim-short-suffix "/a.") "/a"
+  (trim-short-suffix "/a./") "/a/"
+  (trim-short-suffix "/a.//") "/a//")
+
+(mtest
+  (trim-long-suffix "") ""
+  (trim-long-suffix ".") "."
+  (trim-long-suffix "/.") "/."
+  (trim-long-suffix ".b") ".b"
+  (trim-long-suffix ".a.b") ".a"
+  (trim-long-suffix ".a.b.c") ".a"
+  (trim-long-suffix "/.b") "/.b"
+  (trim-long-suffix "/.b/") "/.b/"
+  (trim-long-suffix "/.b//") "/.b//"
+  (trim-long-suffix "a.b") "a"
+  (trim-long-suffix "/a.b") "/a"
+  (trim-long-suffix "/a.b/") "/a/"
+  (trim-long-suffix "/a.b//") "/a//"
+  (trim-long-suffix "/.b.c") "/.b"
+  (trim-long-suffix "/.b.c/") "/.b/"
+  (trim-long-suffix "/.b.c//") "/.b//"
+  (trim-long-suffix "/.b.c.d") "/.b"
+  (trim-long-suffix "/.b.c.d/") "/.b/"
+  (trim-long-suffix "/.b.c.d//") "/.b//"
+  (trim-long-suffix "a.b.c") "a"
+  (trim-long-suffix "/a.b.c") "/a"
+  (trim-long-suffix "/a.b.c/") "/a/"
+  (trim-long-suffix "/a.b.c//") "/a//"
+  (trim-long-suffix "a.") "a"
+  (trim-long-suffix "/a.") "/a"
+  (trim-long-suffix "/a./") "/a/"
+  (trim-long-suffix "/a.//") "/a//")
+
+(mtest
   (base-name "") ""
   (base-name "/") "/"
   (base-name ".") "."
diff --git a/txr.1 b/txr.1
index 8fc4a3f5..026df54d 100644
--- a/txr.1
+++ b/txr.1
@@ -57577,6 +57577,65 @@ extracted from this last component.
   (long-suffix "x.y.z/abc.tar.gz/") -> ".tar.gz"
 .brev
 
+.coNP Functions @ trim-long-suffix and @ trim-short-suffix
+.synb
+.mets (trim-long-suffix << path )
+.mets (trim-short-suffix << path )
+.syne
+.desc
+The
+.code trim-long-suffix
+and
+.code trim-short-suffix
+functions calculate the portion of
+.meta path
+.I "long suffix"
+and
+.I "short suffix"
+of the string argument
+.metn path ,
+and return a path with the suffix removed.
+
+Respectively,
+.code trim-long-suffix
+and
+.code trim-short-suffix
+calculate the suffix in exactly the same manner as
+.code long-suffix
+and
+.codn short-suffix .
+
+If
+.meta path
+is found not to contain a suffix, then it is returned.
+
+If
+.meta path
+contains a suffix, then a new string is returned from which
+the suffix is deleted. If the suffix is followed by one or more path separator
+characters, these are preserved in the return value.
+
+.TP* Examples:
+
+.verb
+  (trim-short-suffix "") -> ""
+  (trim-short-suffix "a") -> "a"
+  (trim-short-suffix ".") -> "."
+  (trim-short-suffix ".a") -> ".a"
+
+  (trim-short-suffix "a.") -> "a"
+  (trim-short-suffix "a.b") -> "a"
+  (trim-short-suffix "a.b.c") -> "a.b"
+
+  (trim-short-suffix "a./") -> "a/"
+  (trim-short-suffix "a.b/") -> "a/"
+  (trim-short-suffix "a.b.c/") -> "a.b/"
+
+  (trim-long-suffix "a.b.c") -> "a"
+  (trim-long-suffix "a.b.c/") -> "a/"
+  (trim-long-suffix "a.b.c///") -> "a///"
+.brev
+
 .coNP Function @ path-cat
 .synb
 .mets (path-cat >> [ dir-path <> { rel-path }*])