Commit f9a8faa3 authored by Yannick Moy's avatar Yannick Moy Committed by Johannes Kanig

N919-012 Add functions for removing special parent/current subpaths

Function Sysutil.relativize_filename does not work well when its first
argument contains special subpaths for the parent and current directories
(".." and "."). Provide a function Sysutil.normalize_filename that removes
such subpaths, to be called before Sysutil.relativize_filename.
parent e6a36925
...@@ -122,6 +122,13 @@ let path_of_file f = ...@@ -122,6 +122,13 @@ let path_of_file f =
in in
aux [] f aux [] f
(* return the file name of an absolute path *)
let rec file_of_path l =
match l with
| [] -> ""
| [x] -> x
| x::l -> Filename.concat x (file_of_path l)
(* (*
let test x = (Filename.dirname x, Filename.basename x) let test x = (Filename.dirname x, Filename.basename x)
...@@ -136,6 +143,25 @@ let p1 = path_of_file "/bin/bash" ...@@ -136,6 +143,25 @@ let p1 = path_of_file "/bin/bash"
let p1 = path_of_file "../src/f.why" let p1 = path_of_file "../src/f.why"
*) *)
let normalize_filename f =
let rec aux af acc =
match af, acc with
| x::rf, _ ->
if x = Filename.current_dir_name then
aux rf acc
else if x = Filename.parent_dir_name then
(match acc with
| _::racc -> aux rf racc
| [] ->
(* do not treat currently cases like "../../../a/b/c/d",
that cannot occur if [f] is a full path *)
failwith "cannot normalize filename")
else
aux rf (x::acc)
| [], _ -> acc
in
file_of_path (List.rev (aux (path_of_file f) []))
let relativize_filename base f = let relativize_filename base f =
let rec aux ab af = let rec aux ab af =
match ab,af with match ab,af with
...@@ -144,16 +170,16 @@ let relativize_filename base f = ...@@ -144,16 +170,16 @@ let relativize_filename base f =
let rec aux2 acc p = let rec aux2 acc p =
match p with match p with
| [] -> acc | [] -> acc
| _::rb -> aux2 (Filename.parent_dir_name::acc) rb | x::rb ->
(if x = Filename.current_dir_name then
aux2 acc rb
else if x = Filename.parent_dir_name then
failwith "cannot relativize filename"
else
aux2 (Filename.parent_dir_name::acc) rb)
in aux2 af ab in aux2 af ab
in in
let rec rebuild l = file_of_path (aux (path_of_file base) (path_of_file f))
match l with
| [] -> ""
| [x] -> x
| x::l -> Filename.concat x (rebuild l)
in
rebuild (aux (path_of_file base) (path_of_file f))
let absolutize_filename dirname f = let absolutize_filename dirname f =
if Filename.is_relative f then if Filename.is_relative f then
......
...@@ -49,13 +49,19 @@ val copy_dir : string -> string -> unit ...@@ -49,13 +49,19 @@ val copy_dir : string -> string -> unit
currently the directory must contains only directories and common files currently the directory must contains only directories and common files
*) *)
val path_of_file : string -> string list val path_of_file : string -> string list
(** [path_of_file filename] return the absolute path of [filename] *) (** [path_of_file filename] return the absolute path of [filename] *)
val normalize_filename : string -> string
(** [normalize_filename filename] removes from [filename] occurrences of
"." and ".." that denote respectively the current directory and
parent directory, whenever possible *)
val relativize_filename : string -> string -> string val relativize_filename : string -> string -> string
(** [relativize_filename base filename] relativize the filename (** [relativize_filename base filename] relativize the filename
[filename] according to [base] *) [filename] according to [base]. [base] should not contain occurrences of
"." and "..", which can be removed by calling first [normalize_filename].
*)
val absolutize_filename : string -> string -> string val absolutize_filename : string -> string -> string
(** [absolutize_filename base filename] absolutize the filename (** [absolutize_filename base filename] absolutize the filename
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment