1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
|
(**************************************************************************)
(* *)
(* OCaml *)
(* *)
(* Gabriel Scherer, projet Parsifal, INRIA Saclay *)
(* *)
(* Copyright 2017 Institut National de Recherche en Informatique et *)
(* en Automatique. *)
(* *)
(* 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. *)
(* *)
(**************************************************************************)
open! Stdlib
type path = string
type path_prefix = string
type error_message = string
type ('a, 'b) result =
| Ok of 'a
| Error of 'b
let errorf fmt = Printf.ksprintf (fun err -> Error err) fmt
let encode_prefix str =
let buf = Buffer.create (String.length str) in
let push_char = function
| '%' -> Buffer.add_string buf "%#"
| '=' -> Buffer.add_string buf "%+"
| ':' -> Buffer.add_string buf "%."
| c -> Buffer.add_char buf c
in
String.iter ~f:push_char str;
Buffer.contents buf
let decode_prefix str =
let buf = Buffer.create (String.length str) in
let rec loop i =
if i >= String.length str
then Ok (Buffer.contents buf)
else
match str.[i] with
| ('=' | ':') as c -> errorf "invalid character '%c' in key or value" c
| '%' -> (
let push c =
Buffer.add_char buf c;
loop (i + 2)
in
if i + 1 = String.length str
then errorf "invalid encoded string %S (trailing '%%')" str
else
match str.[i + 1] with
| '#' -> push '%'
| '+' -> push '='
| '.' -> push ':'
| c -> errorf "invalid %%-escaped character '%c'" c)
| c ->
Buffer.add_char buf c;
loop (i + 1)
in
loop 0
type pair =
{ target : path_prefix
; source : path_prefix
}
let encode_pair { target; source } =
String.concat ~sep:"=" [ encode_prefix target; encode_prefix source ]
let decode_pair str =
match String.lsplit2 str ~on:'=' with
| None -> errorf "invalid key/value pair %S, no '=' separator" str
| Some (encoded_target, encoded_source) -> (
match decode_prefix encoded_target, decode_prefix encoded_source with
| Ok target, Ok source -> Ok { target; source }
| (Error _ as err), _ | _, (Error _ as err) -> err)
type map = pair option list
let encode_map map =
let encode_elem = function
| None -> ""
| Some pair -> encode_pair pair
in
List.map ~f:encode_elem map |> String.concat ~sep:":"
exception Shortcut of error_message
let decode_map str =
let decode_or_empty = function
| "" -> None
| pair -> (
match decode_pair pair with
| Ok str -> Some str
| Error err -> raise (Shortcut err))
in
let pairs = String.split_char ~sep:':' str in
match List.map ~f:decode_or_empty pairs with
| exception Shortcut err -> Error err
| map -> Ok map
let rewrite_opt prefix_map path =
let is_prefix = function
| None -> false
| Some { target = _; source } -> String.is_prefix path ~prefix:source
in
match
List.find
~f:is_prefix
(* read key/value pairs from right to left, as the spec demands *)
(List.rev prefix_map)
with
| exception Not_found -> None
| None -> None
| Some { source; target } ->
Some
(target
^ String.sub
path
~pos:(String.length source)
~len:(String.length path - String.length source))
let rewrite prefix_map path =
match rewrite_opt prefix_map path with
| None -> path
| Some path -> path
let flip l =
List.map l ~f:(Option.map ~f:(fun x -> { source = x.target; target = x.source }))
(* copied from ocaml/utils/misc.ml *)
let get_build_path_prefix_map =
let init = ref false in
let map_cache = ref None in
fun () ->
if not !init
then (
init := true;
match Sys.getenv "BUILD_PATH_PREFIX_MAP" with
| exception Not_found -> ()
| encoded_map -> (
match decode_map encoded_map with
| Error err ->
failwith
@@ Printf.sprintf
"Invalid value for the environment variable BUILD_PATH_PREFIX_MAP: %s"
err
| Ok map -> map_cache := Some map));
!map_cache
|
