Source file opamFilename.ml

(**************************************************************************)
(*                                                                        *)
(*    Copyright 2012-2020 OCamlPro                                        *)
(*    Copyright 2012 INRIA                                                *)
(*                                                                        *)
(*  All rights reserved. This file is distributed under the terms of the  *)
(*  GNU Lesser General Public License version 2.1, with the special       *)
(*  exception on linking described in the file LICENSE.                   *)
(*                                                                        *)
(**************************************************************************)

let split ~sep path =
  let sep =
    let real_sep = function
      | `Unix -> Re.char '/'
      | `Windows -> Re.alt Re.[ char '\\'; char '/' ]
    in
    match sep with
    | `Unspecified when Sys.win32 -> real_sep `Windows
    | `Unspecified -> real_sep `Unix
    | `Unix | `Windows as sep -> real_sep sep
  in
  Re.(split (compile sep) path)

let might_escape ~sep path =
  List.exists (String.equal Filename.parent_dir_name)
    (split ~sep path)

let is_dir_sep =
  if Sys.win32 then
    function '/' | '\\' -> true | _ -> false
  else
    function '/' -> true | _ -> false

let is_rel_seg = function
  | "." | ".." -> true
  | _ -> false

module Base = struct
  include OpamStd.AbstractString

  let compare = String.compare
  let equal = String.equal

  let check_suffix filename s =
    Filename.check_suffix filename s

  let add_extension filename suffix =
    filename ^ "." ^ suffix
end

let log fmt = OpamConsole.log "FILENAME" fmt
let slog = OpamConsole.slog

module Dir = struct

  include OpamStd.AbstractString

  let compare = String.compare
  let equal = String.equal

  let of_string dirname =
    let dirname =
      if dirname = "~" then OpamStd.Sys.home ()
      else if
        OpamCompat.String.starts_with ~prefix:("~"^Filename.dir_sep) dirname
      then
        Filename.concat (OpamStd.Sys.home ())
          (OpamStd.String.remove_prefix ~prefix:("~"^Filename.dir_sep) dirname)
      else dirname
    in
    OpamSystem.real_path (OpamSystem.forward_to_back dirname)

  let to_string dirname = dirname

end

let raw_dir s = s

let mk_tmp_dir () =
  Dir.of_string @@ OpamSystem.mk_temp_dir ()

let with_tmp_dir fn =
  OpamSystem.with_tmp_dir (fun dir -> fn (Dir.of_string dir))

let with_tmp_dir_job fjob =
  OpamSystem.with_tmp_dir_job (fun dir -> fjob (Dir.of_string dir))

let rmdir dirname =
  OpamSystem.remove_dir (Dir.to_string dirname)

let rmdir_cleanup dirname =
  OpamSystem.rmdir_cleanup (Dir.to_string dirname)

let cwd () =
  Dir.of_string (Unix.getcwd ())

let mkdir dirname =
  OpamSystem.mkdir (Dir.to_string dirname)

let exists_dir dirname =
  try (Unix.stat (Dir.to_string dirname)).Unix.st_kind = Unix.S_DIR
  with Unix.Unix_error _ -> false

let cleandir dirname =
  if exists_dir dirname then
    (log "cleandir %a" (slog Dir.to_string) dirname;
     OpamSystem.remove (Dir.to_string dirname);
     mkdir dirname)

let rec_dirs d =
  let fs = OpamSystem.rec_dirs (Dir.to_string d) in
  List.rev (List.rev_map Dir.of_string fs)

let dirs d =
  let fs = OpamSystem.dirs (Dir.to_string d) in
  List.rev (List.rev_map Dir.of_string fs)

let dir_is_empty d =
  OpamSystem.dir_is_empty (Dir.to_string d)

let is_dir_read_only dirname =
  OpamSystem.is_dir_read_only (Dir.to_string dirname)

let exec dir ?env ?name ?metadata ?keep_going cmds =
  OpamSystem.commands ~dir ?env ?name ?metadata ?keep_going cmds

let move_dir ~src ~dst =
  OpamSystem.mv (Dir.to_string src) (Dir.to_string dst)

let opt_dir dirname =
  if exists_dir dirname then Some dirname else None

let basename_dir dirname =
  Base.of_string (Filename.basename (Dir.to_string dirname))

let dirname_dir dirname = Filename.dirname (Dir.to_string dirname)

let link_dir ~target ~link =
  if exists_dir link then
    OpamSystem.internal_error "Cannot link: %s already exists."
      (Dir.to_string link)
  else
    OpamSystem.link (Dir.to_string target) (Dir.to_string link)

let to_list_dir dir =
  let base d = Dir.of_string (Filename.basename (Dir.to_string d)) in
  let rec aux acc dir =
    let d = dirname_dir dir in
    if d <> dir then aux (base dir :: acc) d
    else base dir :: acc in
  aux [] dir

let (/) d1 s2 =
  let s1 = Dir.to_string d1 in
  raw_dir (Filename.concat s1 s2)

let concat_and_resolve d1 s2 =
  let s1 = Dir.to_string d1 in
  Dir.of_string (Filename.concat s1 s2)

type t = {
  dirname:  Dir.t;
  basename: Base.t;
}

let create dirname basename =
  let b1 = OpamSystem.forward_to_back (Filename.dirname (Base.to_string basename)) in
  let b2 = Base.of_string (Filename.basename (Base.to_string basename)) in
  let dirname = OpamSystem.forward_to_back dirname in
  if basename = b2 then
    { dirname; basename }
  else
    let b1 =
      if dirname = ""
      then b1
      else OpamStd.String.remove_prefix ~prefix:Filename.dir_sep b1
    in
    { dirname = dirname / b1; basename = b2 }

let of_basename basename =
  let dirname = Dir.of_string Filename.current_dir_name in
  { dirname; basename }

let raw str =
  let dirname = raw_dir (Filename.dirname str) in
  let basename = Base.of_string (Filename.basename str) in
  create dirname basename

let to_string t =
  Filename.concat (Dir.to_string t.dirname) (Base.to_string t.basename)

let touch t =
  OpamSystem.write (to_string t) ""

let chmod t p =
  Unix.chmod (to_string t) p

let written_since file =
  let last_update =
    (Unix.stat (to_string file)).Unix.st_mtime
  in
  (Unix.time () -. last_update)

let of_string s =
  let dirname = Filename.dirname s in
  let basename = Filename.basename s in
  {
    dirname  = Dir.of_string dirname;
    basename = Base.of_string basename;
  }

let dirname t = t.dirname

let basename t = t.basename

let read filename =
  OpamSystem.read (to_string filename)

let open_in filename =
  try open_in (to_string filename)
  with Sys_error _ -> raise (OpamSystem.File_not_found (to_string filename))

let open_in_bin filename =
  try open_in_bin (to_string filename)
  with Sys_error _ -> raise (OpamSystem.File_not_found (to_string filename))

let open_out filename =
  try open_out (to_string filename)
  with Sys_error _ -> raise (OpamSystem.File_not_found (to_string filename))

let open_out_bin filename =
  try open_out_bin (to_string filename)
  with Sys_error _ -> raise (OpamSystem.File_not_found (to_string filename))

let write filename raw =
  OpamSystem.write (to_string filename) raw

let remove filename =
  OpamSystem.remove_file (to_string filename)

let with_open_out_bin_aux open_out_bin filename f =
  let v, oc =
    mkdir (dirname filename);
    try open_out_bin filename
    with Sys_error _ -> raise (OpamSystem.File_not_found (to_string filename))
  in
  try
    Unix.lockf (Unix.descr_of_out_channel oc) Unix.F_LOCK 0;
    f oc;
    close_out oc;
    v
  with e ->
    OpamStd.Exn.finalise e @@ fun () ->
    close_out oc; remove filename

let with_open_out_bin [@deprecated] =
  with_open_out_bin_aux (fun f -> (), open_out_bin f)

let with_open_out_bin_atomic filename f =
  let open_temp_file filename =
    let mode = [Open_binary] in
    let perms = 0o666 in
    let temp_dir = Dir.to_string (dirname filename) in
    Filename.open_temp_file ~mode ~perms ~temp_dir "opam-atomic" ".tmp"
  in
  let temp_file = with_open_out_bin_aux open_temp_file filename f in
  try
    Sys.rename temp_file (to_string filename)
  with Sys_error _ ->
    OpamSystem.remove_file temp_file;
    raise (OpamSystem.File_not_found (to_string filename))

let exists filename =
  try (Unix.stat (to_string filename)).Unix.st_kind = Unix.S_REG
  with Unix.Unix_error _ -> false

let opt_file filename =
  if exists filename then Some filename else None

let with_tmp_file fn =
  OpamSystem.with_tmp_file (fun file -> fn (of_string file))

let with_tmp_file_job fjob =
  OpamSystem.with_tmp_file_job (fun file -> fjob (of_string file))

let with_contents fn filename =
  fn (read filename)

let check_suffix filename s =
  Filename.check_suffix (to_string filename) s

let add_extension filename suffix =
  of_string ((to_string filename) ^ "." ^ suffix)

let chop_extension filename =
  of_string (Filename.chop_extension (to_string filename))

let rec_files ?except_vcs d =
  let fs = OpamSystem.rec_files ?except_vcs (Dir.to_string d) in
  List.rev_map of_string fs

let files d =
  let fs = OpamSystem.files (Dir.to_string d) in
  List.rev_map of_string fs

let files_and_links d =
  let fs = OpamSystem.files_all_not_dir (Dir.to_string d) in
  List.rev_map of_string fs

let copy ~src ~dst =
  if src <> dst then OpamSystem.copy_file (to_string src) (to_string dst)

let copy_dir_t f ~src ~dst =
  if src <> dst then f (Dir.to_string src) (Dir.to_string dst)

let copy_dir = copy_dir_t OpamSystem.copy_dir
let copy_dir_except_vcs = copy_dir_t OpamSystem.copy_dir_except_vcs

let install ?warning ?exec ~src ~dst () =
  if src <> dst then OpamSystem.install ?warning ?exec (to_string src) (to_string dst)

let move ~src ~dst =
  if src <> dst then
    OpamSystem.mv (to_string src) (to_string dst)

let readlink src =
  if exists src then
    try
      let rl = Unix.readlink (to_string src) in
      if Filename.is_relative rl then
        of_string (Filename.concat (dirname src) rl)
      else of_string rl
    with Unix.Unix_error _ -> src
  else
    OpamSystem.internal_error "%s does not exist." (to_string src)

let is_symlink src =
  try
    let s = Unix.lstat (to_string src) in
    s.Unix.st_kind = Unix.S_LNK
  with Unix.Unix_error _ -> false

let is_symlink_dir src =
  try
    let s = Unix.lstat (Dir.to_string src) in
    s.Unix.st_kind = Unix.S_LNK
  with Unix.Unix_error _ -> false

let is_exec file =
  try OpamSystem.is_exec (to_string file)
  with Unix.Unix_error _ ->
    OpamSystem.internal_error "%s does not exist." (to_string file)

let cmpable_dir_string dir =
  match OpamSystem.forward_to_back (Dir.to_string dir) with
  | "" -> ""
  | d -> Filename.concat d ""

let cmpable_file_string file =
  OpamSystem.forward_to_back (to_string file)

let starts_with prefix filename =
  let prefix = cmpable_dir_string prefix in
  let dir = cmpable_file_string filename in
  OpamCompat.String.starts_with ~prefix dir

let dir_starts_with prefix dir =
  let prefix = cmpable_dir_string prefix in
  let dir = cmpable_dir_string dir in
  OpamCompat.String.starts_with ~prefix dir

let remove_prefix prefix filename =
  let prefix =
    let str = Dir.to_string prefix in
    if str = "" then "" else Filename.concat str "" in
  let filename = to_string filename in
  OpamStd.String.remove_prefix ~prefix filename

let remove_prefix_dir prefix dir =
  let prefix = Dir.to_string prefix in
  let dirname = Dir.to_string dir in
  if prefix = "" then dirname
  else
    OpamStd.String.remove_prefix ~prefix dirname |>
    OpamStd.String.remove_prefix ~prefix:Filename.dir_sep

let process_in ?root fn src dst =
  let basename = match root with
    | None   -> basename src
    | Some r ->
      if starts_with r src then remove_prefix r src
      else OpamSystem.internal_error "%s is not a prefix of %s"
          (Dir.to_string r) (to_string src) in
  let dst = Filename.concat (Dir.to_string dst) basename in
  fn ~src ~dst:(of_string dst)

let copy_in ?root = process_in ?root copy

let is_archive filename =
  OpamSystem.is_archive (to_string filename)

let extract filename dirname =
  OpamSystem.extract (to_string filename) ~dir:(Dir.to_string dirname)

let extract_job filename dirname =
  OpamSystem.extract_job (to_string filename) ~dir:(Dir.to_string dirname)

let extract_in filename dirname =
  OpamSystem.extract_in (to_string filename) ~dir:(Dir.to_string dirname)

let extract_in_job filename dirname =
  OpamSystem.extract_in_job (to_string filename) ~dir:(Dir.to_string dirname)

type generic_file =
  | D of Dir.t
  | F of t

let extract_generic_file filename dirname =
  match filename with
  | F f ->
    log "extracting %a to %a"
      (slog to_string) f
      (slog Dir.to_string) dirname;
    extract f dirname
  | D d ->
    if d <> dirname then (
      log "copying %a to %a"
        (slog Dir.to_string) d
        (slog Dir.to_string) dirname;
      copy_dir ~src:d ~dst:dirname
    )

let ends_with suffix filename =
  OpamCompat.String.ends_with ~suffix (to_string filename)

let dir_ends_with suffix dirname =
  OpamCompat.String.ends_with ~suffix (Dir.to_string dirname)

let remove_suffix suffix filename =
  let suffix = Base.to_string suffix in
  let filename = to_string filename in
  OpamStd.String.remove_suffix ~suffix filename

let rec find_in_parents f dir =
  if f dir then Some dir else
  let parent = dirname_dir dir in
  if parent = dir then None
  else find_in_parents f parent

let link ?(relative=false) ~target ~link =
  if target = link then () else
  let target =
    if not relative then to_string target else
    match
      find_in_parents (fun d -> d <> "/" && starts_with d link) (dirname target)
    with
    | None -> to_string target
    | Some ancestor ->
      let back =
        let rel = remove_prefix_dir ancestor (dirname link) in
        OpamStd.List.concat_map Filename.dir_sep
          (fun _ -> "..")
          (OpamStd.String.split rel Filename.dir_sep.[0])
      in
      let forward = remove_prefix ancestor target in
      Filename.concat back forward
  in
  OpamSystem.link target (to_string link)
[@@ocaml.warning "-16"]

let parse_patch ~dir patch_file =
  OpamPatch.parse_patch ~translate:(Some (Dir.to_string dir)) (to_string patch_file)

module PatchFS = struct
  type root = string
  type file = string
  type target = unit
  let root_label = "directory"
  let translate_patch = true
  let root_to_string root = root
  let file_to_string file = file
  let equal_file = String.equal
  let get_path ~fail dir file =
    let dir = Filename.concat (OpamSystem.real_path dir) "" in
    let file = OpamSystem.real_path (Filename.concat dir file) in
    if not (OpamStd.String.is_prefix_of ~from:0 ~full:file dir) then
      fail ();
    file
  let write file content _target = OpamSystem.write file content
  let on_unclean_accept file content =
    Option.iter (fun c -> write (file^".orig") c ()) content
  let on_unclean_reject file content diff =
    on_unclean_accept file content;
    write (file^".rej") (Format.asprintf "%a" Patch.pp diff) ()
  let exists file _target = Sys.file_exists file
  let exists_dir file _target =
    let dir = Filename.dirname file in
    Sys.file_exists dir && Sys.is_directory dir
  let read file _target = OpamSystem.read file
  let remove file _target = OpamSystem.remove_file file
  let remove_dir file _target = OpamSystem.rmdir_cleanup (Filename.dirname file)
  let same_dirname ~src ~dst =
    Filename.dirname src = (Filename.dirname dst : string)
  let mv ~src ~dst _target = OpamSystem.mv src dst
  let open_ _target f = f ()
  let save _target = ()
end

let patch ~allow_unclean patch_source dir =
  let patch_source =
    match patch_source with
    | `Patch_file f -> `Patch_file (to_string f)
    | `Patch_diffs _ as d -> d
  in
  OpamPatch.patch (module PatchFS) ~allow_unclean patch_source dir

let flock flag ?dontblock file = OpamSystem.flock flag ?dontblock (to_string file)

let with_flock flag ?dontblock file f =
  let lock = OpamSystem.flock flag ?dontblock (to_string file) in
  try
    let (fd, ch) =
      match OpamSystem.get_lock_fd lock with
      | exception Not_found ->
        let null =
          if OpamStd.Sys.(os () = Win32) then
            "nul"
          else
            "/dev/null"
        in
        let ch = Stdlib.open_out null in
        Unix.descr_of_out_channel ch, Some ch
      | fd ->
        fd, None
    in
    let r = f fd in
    OpamSystem.funlock lock;
    Option.iter Stdlib.close_out ch;
    r
  with e ->
    OpamStd.Exn.finalise e @@ fun () ->
    OpamSystem.funlock lock

let with_flock_upgrade flag ?dontblock lock f =
  if OpamSystem.lock_isatleast flag lock then f (OpamSystem.get_lock_fd lock)
  else (
    let old_flag = OpamSystem.get_lock_flag lock in
    OpamSystem.flock_update flag ?dontblock lock;
    try
      let r = f (OpamSystem.get_lock_fd lock) in
      OpamSystem.flock_update old_flag lock;
      r
    with e ->
      OpamStd.Exn.finalise e @@ fun () ->
      OpamSystem.flock_update old_flag lock
  )

let with_flock_write_then_read ?dontblock file write read =
  let lock = OpamSystem.flock `Lock_write ?dontblock (to_string file) in
  try
    let r = write (OpamSystem.get_lock_fd lock) in
    OpamSystem.flock_update `Lock_read lock;
    let r = read r in
    OpamSystem.funlock lock;
    r
  with e ->
    OpamStd.Exn.finalise e @@ fun () ->
    OpamSystem.funlock lock

let prettify_path s =
  let aux ~short ~prefix =
    let prefix = Filename.concat prefix "" in
    if OpamCompat.String.starts_with ~prefix s then
      let suffix = OpamStd.String.remove_prefix ~prefix s in
      Some (Filename.concat short suffix)
    else
      None in
  try
    match aux ~short:"~" ~prefix:(OpamStd.Sys.home ()) with
    | Some p -> p
    | None   -> s
  with Not_found -> s

let prettify_dir d =
  prettify_path (Dir.to_string d)

let prettify s =
  prettify_path (to_string s)

let to_json x = `String (to_string x)
let of_json = function
  | `String x -> (try Some (of_string x) with _ -> None)
  | _ -> None

let compare {dirname; basename} f =
  let dir = Dir.compare dirname f.dirname in
  if dir <> 0 then dir else
    Base.compare basename f.basename

let equal f g = compare f g = 0

module O = struct
  type tmp = t
  type t = tmp
  let compare = compare
  let to_string = to_string
  let to_json = to_json
  let of_json = of_json
end

module Map = OpamStd.Map.Make(O)
module Set = OpamStd.Set.Make(O)

module SubPath = struct

  include OpamStd.AbstractString

  let compare = String.compare
  let equal = String.equal

  let of_string s =
    OpamSystem.back_to_forward s
    |> OpamStd.String.remove_prefix ~prefix:"./"
    |> of_string
  let to_string = OpamSystem.forward_to_back
  let normalised_string s = s

  let (/) d s = d / to_string s
  let (/?) d = function
    | None -> d
    | Some s -> d / to_string s

end

module Op = struct

  let (/) = (/)

  let (//) d1 s2 =
    let d = Filename.dirname s2 in
    let b = Filename.basename s2 in
    if d <> "." then
      create (d1 / d) (Base.of_string b)
    else
      create d1 (Base.of_string s2)

end

module Attribute = struct

  type t = {
    base: Base.t;
    md5 : OpamHash.t;
    perm: int option;
  }

  let base t = t.base

  let md5 t = t.md5

  let perm t = t.perm

  let create base md5 perm =
    { base; md5; perm=perm }

  let to_string_list t =
    let perm = match t.perm with
      | None   -> []
      | Some p -> [Printf.sprintf "0o%o" p] in
    Base.to_string t.base :: OpamHash.to_string t.md5 :: perm

  let of_string_list = function
    | [base; md5]      ->
      { base=Base.of_string base; md5=OpamHash.of_string md5; perm=None }
    | [base;md5; perm] ->
      { base=Base.of_string base;
        md5=OpamHash.of_string md5;
        perm=Some (int_of_string perm) }
    | k                -> OpamSystem.internal_error
                            "remote_file: '%s' is not a valid line."
                            (String.concat " " k)

  let to_string t = String.concat " " (to_string_list t)
  let of_string s = of_string_list (OpamStd.String.split s ' ')

  let to_json x =
    `O ([ ("base" , Base.to_json x.base);
          ("md5"  , `String (OpamHash.to_string x.md5))]
        @ match x. perm with
          | None   -> []
          | Some p -> ["perm", `String (string_of_int p)])

  let of_json = function
    | `O dict ->
      begin try
          let open OpamStd.Option.Op in
          Base.of_json (OpamStd.List.assoc String.equal "base" dict)
          >>= fun base ->
          OpamHash.of_json (OpamStd.List.assoc String.equal "md5" dict)
          >>= fun md5 ->
          let perm =
            if not (OpamStd.List.mem_assoc String.equal "perm" dict) then None
            else match OpamStd.List.assoc String.equal "perm" dict with
              | `String hash ->
                (try Some (int_of_string hash) with _ -> raise Not_found)
              | _ -> raise Not_found
          in
          Some { base; md5; perm }
        with Not_found -> None
      end
    | _ -> None

  let compare {base; md5; perm} a =
    let base = Base.compare base a.base in
    if base <> 0 then base else
    let md5 = OpamHash.compare md5 a.md5 in
    if md5 <> 0 then md5 else
      Option.compare Int.compare perm a.perm

  let equal a b = compare a b = 0

  module O = struct
    type tmp = t
    type t = tmp
    let to_string = to_string
    let compare = compare
    let to_json = to_json
    let of_json = of_json
  end

  module Set = OpamStd.Set.Make(O)

  module Map = OpamStd.Map.Make(O)

end

let to_attribute root file =
  let basename = Base.of_string (remove_prefix root file) in
  let perm =
    let s = Unix.stat (to_string file) in
    s.Unix.st_perm in
  let digest = OpamHash.compute ~kind:`MD5 (to_string file) in
  Attribute.create basename digest (Some perm)

module Unix = struct
  type filename = t

  (* NOTE: OpamStd.AbstractString isn't used here to make sure the invariants
     of the Unix module hold. Mainly: paths are separated by / not \. *)
  module Internal = struct
    type t = string

    let compare = String.compare
    let equal = String.equal

    let of_string = OpamSystem.back_to_forward
    let to_string = Fun.id

    let to_json x = `String x
    let of_json = function
      | `String x -> Some (of_string x)
      | _ -> None

    module O = struct
      type t = string
      let to_string = to_string
      let compare = compare
      let to_json = to_json
      let of_json = of_json
    end
    module Set = OpamStd.Set.Make(O)
    module Map = OpamStd.Map.Make(O)
  end

  include Internal

  module Base = struct
    include Internal

    let of_base = OpamSystem.back_to_forward
    let to_base = Fun.id
  end

  (* Copied from the OCaml Stdlib Filename module *)
  (* Copyright 1996 Institut National de Recherche en Informatique et
     en Automatique. *)
  let current_dir_name = "."
  let dir_sep = "/"
  let is_dir_sep s i = s.[i] = '/'
  let concat dirname filename =
    let l = String.length dirname in
    if l = 0 || is_dir_sep dirname (l-1)
    then dirname ^ filename
    else dirname ^ dir_sep ^ filename
  (* 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)
  let dirname = generic_dirname is_dir_sep current_dir_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 name = ""
    then current_dir_name
    else find_end (String.length name - 1)
  let basename = generic_basename is_dir_sep current_dir_name

  module Dir = struct
    include Internal

    let of_dir = OpamSystem.back_to_forward
    let to_dir = OpamSystem.forward_to_back
    let dirname = dirname
    let basename = basename
  end


  module Op = struct
    let (/) = concat
    let (//) = concat
  end

  let of_filename x = OpamSystem.back_to_forward (concat x.dirname x.basename)
  let to_filename x = {
    dirname = OpamSystem.forward_to_back (dirname x);
    basename = basename x;
  }

  let starts_with prefix filename =
    if prefix = (filename : string) then true
    else
      let prefix = concat prefix "" in
      OpamCompat.String.starts_with ~prefix filename

  let remove_prefix prefix filename =
    if prefix = "" then filename
    else
      OpamStd.String.remove_prefix ~prefix:(concat prefix "") filename


  let to_relative_canonical_list filename =
      match String.split_on_char '/' filename with
      | [] -> assert false
      | ""::_::_ -> invalid_arg "not relative"
      | [""] -> invalid_arg "current directory"
      | file ->
        if List.hd (List.rev file) = "" then
          invalid_arg "current directory"
        else
          let lst =
            List.filter (fun seg ->
                if seg = ".." then
                  invalid_arg "'..' is forbidden"
                else
                  seg <> "" && not (String.equal current_dir_name seg))
              file
          in
          match lst with
          | [] -> invalid_arg "current directory"
          | _ -> lst

  let to_relative_canonical filename =
    try Ok (String.concat dir_sep
              (to_relative_canonical_list filename))
    with Invalid_argument msg -> Error msg

  let rec root_dir filename =
    if Char.equal filename.[0] dir_sep.[0] then
      let filename =
        String.sub filename 1 (String.length filename - 2)
      in
      Option.map ((^) dir_sep) (root_dir filename)
    else
      match OpamStd.String.cut_at filename dir_sep.[0] with
      | Some (root, _rest) -> Some root
      | None -> None

end