PR#4549: make Filename.dirname/basename POSIX compliant

git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@11999 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02

4 files changed, 62 insertions, 42 deletions

diff --git a/Changes b/Changes
index 4104ee419..c2787304a 100644
--- a/Changes
+++ b/Changes
@@ -38,7 +38,7 @@ Standard library:
   (PR#5437)
 
 Bug Fixes:
-- PR#4549: Filename.dirname is not handling multiple / on Unix
+* PR#4549: Filename.dirname is not handling multiple / on Unix
 - PR#4869: rare collisions between assembly labels for code and data
 - PR#4880: "assert" constructs now show up in the exception stack backtrace
 - PR#5313: ocamlopt -g misses optimizations
diff --git a/VERSION b/VERSION
index fe54d2adb..49ebc9c38 100644
--- a/VERSION
+++ b/VERSION
@@ -1,4 +1,4 @@
-3.13.0+dev8 (2011-10-25)
+3.13.0+dev9 (2012-01-06)
 
 # The version string is the first line of this file.
 # It must be in the format described in stdlib/sys.mli
diff --git a/stdlib/filename.ml b/stdlib/filename.ml
index 92bd21718..8c3ad5315 100644
--- a/stdlib/filename.ml
+++ b/stdlib/filename.ml
@@ -25,30 +25,55 @@ let generic_quote quotequote s =
   Buffer.add_char b '\'';
   Buffer.contents b
 
-let generic_basename rindex_dir_sep current_dir_name name =
-  let raw_name =
-    try
-      let p = rindex_dir_sep name + 1 in
-      String.sub name p (String.length name - p)
-    with Not_found ->
-      name
+(* This function implements the Open Group specification found here:
+  [[1]] http://pubs.opengroup.org/onlinepubs/9699919799/utilities/basename.html
+  In step 1 of [[1]], we choose to return "." for empty input.
+    (for compatibility with previous versions of OCaml)
+  In step 2, we choose to process "//" normally.
+  Step 6 is not implemented: we consider that the [suffix] operand is
+    always absent.  Suffixes are handled by [chop_suffix] and [chop_extension].
+*)
+let generic_basename is_dir_sep current_dir_name name =
+  let rec find_end n =
+    if n < 0 then String.sub name 0 1
+    else if is_dir_sep name n then find_end (n - 1)
+    else find_beg n (n + 1)
+  and find_beg n p =
+    if n < 0 then String.sub name 0 p
+    else if is_dir_sep name n then String.sub name (n + 1) (p - n - 1)
+    else find_beg (n - 1) p
   in
-  if raw_name = "" then current_dir_name else raw_name
-
-let generic_dirname rindex_dir_sep current_dir_name dir_sep name =
-  try
-    match rindex_dir_sep name with
-      0 -> dir_sep
-    | n -> String.sub name 0 n
-  with Not_found ->
-    current_dir_name
+  if name = ""
+  then current_dir_name
+  else find_end (String.length name - 1)
+
+(* This function implements the Open Group specification found here:
+  [[2]] http://pubs.opengroup.org/onlinepubs/9699919799/utilities/dirname.html
+  In step 6 of [[2]], we choose to process "//" normally.
+*)
+let generic_dirname is_dir_sep current_dir_name name =
+  let rec trailing_sep n =
+    if n < 0 then String.sub name 0 1
+    else if is_dir_sep name n then trailing_sep (n - 1)
+    else base n
+  and base n =
+    if n < 0 then current_dir_name
+    else if is_dir_sep name n then intermediate_sep n
+    else base (n - 1)
+  and intermediate_sep n =
+    if n < 0 then String.sub name 0 1
+    else if is_dir_sep name n then intermediate_sep (n - 1)
+    else String.sub name 0 (n + 1)
+  in
+  if name = ""
+  then current_dir_name
+  else trailing_sep (String.length name - 1)
 
 module Unix = struct
   let current_dir_name = "."
   let parent_dir_name = ".."
   let dir_sep = "/"
   let is_dir_sep s i = s.[i] = '/'
-  let rindex_dir_sep s = String.rindex s '/'
   let is_relative n = String.length n < 1 || n.[0] <> '/';;
   let is_implicit n =
     is_relative n
@@ -61,8 +86,8 @@ module Unix = struct
   let temp_dir_name =
     try Sys.getenv "TMPDIR" with Not_found -> "/tmp"
   let quote = generic_quote "'\\''"
-  let basename = generic_basename rindex_dir_sep current_dir_name
-  let dirname = generic_dirname rindex_dir_sep current_dir_name dir_sep
+  let basename = generic_basename is_dir_sep current_dir_name
+  let dirname = generic_dirname is_dir_sep current_dir_name
 end
 
 module Win32 = struct
@@ -70,12 +95,6 @@ module Win32 = struct
   let parent_dir_name = ".."
   let dir_sep = "\\"
   let is_dir_sep s i = let c = s.[i] in c = '/' || c = '\\' || c = ':'
-  let rindex_dir_sep s =
-    let rec pos i =
-      if i < 0 then raise Not_found
-      else if is_dir_sep s i then i
-      else pos (i - 1)
-    in pos (String.length s - 1)
   let is_relative n =
     (String.length n < 1 || n.[0] <> '/')
     && (String.length n < 1 || n.[0] <> '\\')
@@ -129,11 +148,11 @@ module Win32 = struct
     else ("", s)
   let dirname s =
     let (drive, path) = drive_and_path s in
-    let dir = generic_dirname rindex_dir_sep current_dir_name dir_sep path in
+    let dir = generic_dirname is_dir_sep current_dir_name path in
     drive ^ dir
   let basename s =
     let (drive, path) = drive_and_path s in
-    generic_basename rindex_dir_sep current_dir_name path
+    generic_basename is_dir_sep current_dir_name path
 end
 
 module Cygwin = struct
@@ -141,33 +160,32 @@ module Cygwin = struct
   let parent_dir_name = ".."
   let dir_sep = "/"
   let is_dir_sep = Win32.is_dir_sep
-  let rindex_dir_sep = Win32.rindex_dir_sep
   let is_relative = Win32.is_relative
   let is_implicit = Win32.is_implicit
   let check_suffix = Win32.check_suffix
   let temp_dir_name = Unix.temp_dir_name
   let quote = Unix.quote
-  let basename = generic_basename rindex_dir_sep current_dir_name
-  let dirname = generic_dirname rindex_dir_sep current_dir_name dir_sep
+  let basename = generic_basename is_dir_sep current_dir_name
+  let dirname = generic_dirname is_dir_sep current_dir_name
 end
 
-let (current_dir_name, parent_dir_name, dir_sep, is_dir_sep, rindex_dir_sep,
+let (current_dir_name, parent_dir_name, dir_sep, is_dir_sep,
      is_relative, is_implicit, check_suffix, temp_dir_name, quote, basename,
      dirname) =
   match Sys.os_type with
     "Unix" ->
       (Unix.current_dir_name, Unix.parent_dir_name, Unix.dir_sep,
-       Unix.is_dir_sep, Unix.rindex_dir_sep,
+       Unix.is_dir_sep,
        Unix.is_relative, Unix.is_implicit, Unix.check_suffix,
        Unix.temp_dir_name, Unix.quote, Unix.basename, Unix.dirname)
   | "Win32" ->
       (Win32.current_dir_name, Win32.parent_dir_name, Win32.dir_sep,
-       Win32.is_dir_sep, Win32.rindex_dir_sep,
+       Win32.is_dir_sep,
        Win32.is_relative, Win32.is_implicit, Win32.check_suffix,
        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.rindex_dir_sep,
+       Cygwin.is_dir_sep,
        Cygwin.is_relative, Cygwin.is_implicit, Cygwin.check_suffix,
        Cygwin.temp_dir_name, Cygwin.quote, Cygwin.basename, Cygwin.dirname)
   | _ -> assert false
diff --git a/stdlib/filename.mli b/stdlib/filename.mli
index 7e447585c..b4644ad67 100644
--- a/stdlib/filename.mli
+++ b/stdlib/filename.mli
@@ -59,17 +59,19 @@ val chop_extension : string -> string
 
 val basename : string -> string
 (** Split a file name into directory name / base file name.
-   [concat (dirname name) (basename name)] returns a file name
-   which is equivalent to [name]. Moreover, after setting the
-   current directory to [dirname name] (with {!Sys.chdir}),
+   If [name] is a valid file name, then [concat (dirname name) (basename name)]
+   returns a file name which is equivalent to [name]. Moreover,
+   after setting the current directory to [dirname name] (with {!Sys.chdir}),
    references to [basename name] (which is a relative file name)
    designate the same file as [name] before the call to {!Sys.chdir}.
 
-   The result is not specified if the argument is not a valid file name
-   (for example, under Unix if there is a NUL character in the string). *)
+   This function conforms to the specification of POSIX.1-2008 for the
+   [basename] utility. *)
 
 val dirname : string -> string
-(** See {!Filename.basename}. *)
+(** See {!Filename.basename}.
+   This function conforms to the specification of POSIX.1-2008 for the
+   [dirname] utility. *)
 
 val temp_file : ?temp_dir: string -> string -> string -> string
 (** [temp_file prefix suffix] returns the name of a