-
Notifications
You must be signed in to change notification settings - Fork 349
/
opamStd.ml
1392 lines (1194 loc) · 37.9 KB
/
opamStd.ml
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
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
(**************************************************************************)
(* *)
(* Copyright 2012-2015 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. *)
(* *)
(**************************************************************************)
open OpamCompat
module type SET = sig
include Set.S
val map: (elt -> elt) -> t -> t
val is_singleton: t -> bool
val choose_one : t -> elt
val of_list: elt list -> t
val to_string: t -> string
val to_json: t -> OpamJson.t
val of_json: OpamJson.t -> t option
val find: (elt -> bool) -> t -> elt
val find_opt: (elt -> bool) -> t -> elt option
val safe_add: elt -> t -> t
module Op : sig
val (++): t -> t -> t
val (--): t -> t -> t
val (%%): t -> t -> t
end
end
module type MAP = sig
include Map.S
val to_string: ('a -> string) -> 'a t -> string
val to_json: ('a -> OpamJson.t) -> 'a t -> OpamJson.t
val of_json: (OpamJson.t -> 'a option) -> OpamJson.t -> 'a t option
val keys: 'a t -> key list
val values: 'a t -> 'a list
val find_opt: key -> 'a t -> 'a option
val union: ('a -> 'a -> 'a) -> 'a t -> 'a t -> 'a t
val is_singleton: 'a t -> bool
val of_list: (key * 'a) list -> 'a t
val safe_add: key -> 'a -> 'a t -> 'a t
val update: key -> ('a -> 'a) -> 'a -> 'a t -> 'a t
end
module type ABSTRACT = sig
type t
val of_string: string -> t
val to_string: t -> string
val to_json: t -> OpamJson.t
val of_json: OpamJson.t -> t option
module Set: SET with type elt = t
module Map: MAP with type key = t
end
module type OrderedType = sig
include Set.OrderedType
val to_string: t -> string
val to_json: t -> OpamJson.t
val of_json: OpamJson.t -> t option
end
let max_print = 100
module OpamList = struct
let cons x xs = x :: xs
let concat_map ?(left="") ?(right="") ?nil ?last_sep sep f =
let last_sep = match last_sep with None -> sep | Some sep -> sep in
function
| [] -> (match nil with Some s -> s | None -> left^right)
| l ->
let seplen = String.length sep in
let strs,len =
List.fold_left (fun (strs,len) x ->
let s = f x in s::strs, String.length s + seplen + len)
([], String.length left + String.length right - seplen)
l
in
let len = match l with
| _::_::_ -> len + String.length last_sep - seplen
| _ -> len
in
let buf = Bytes.create len in
let prepend i s =
let slen = String.length s in
Bytes.blit_string s 0 buf (i - slen) slen;
i - slen
in
let pos = prepend len right in
let pos = prepend pos (List.hd strs) in
let pos =
List.fold_left (fun (pos, cur_sep) s -> (prepend (prepend pos cur_sep) s, sep))
(pos, last_sep) (List.tl strs) |> fst
in
let pos = prepend pos left in
assert (pos = 0);
Bytes.to_string buf
let rec find_opt f = function
| [] -> None
| x::r -> if f x then Some x else find_opt f r
let to_string f =
concat_map ~left:"{ " ~right:" }" ~nil:"{}" ", " f
let rec remove_duplicates = function
| a::(b::_ as r) when a = b -> remove_duplicates r
| a::r -> a::remove_duplicates r
| [] -> []
let sort_nodup cmp l = remove_duplicates (List.sort cmp l)
let filter_map f l =
let rec loop accu = function
| [] -> List.rev accu
| h :: t ->
match f h with
| None -> loop accu t
| Some x -> loop (x::accu) t in
loop [] l
let filter_some l = filter_map (fun x -> x) l
let rec find_map f = function
| [] -> raise Not_found
| x::r -> match f x with
| Some r -> r
| None -> find_map f r
let insert comp x l =
let rec aux = function
| [] -> [x]
| h::t when comp h x < 0 -> h::aux t
| l -> x :: l in
aux l
let rec insert_at index value = function
| [] -> [value]
| l when index <= 0 -> value :: l
| x::l -> x :: insert_at (index - 1) value l
let pick_assoc x l =
let rec aux acc = function
| [] -> None, l
| (k,v) as b::r ->
if k = x then Some v, List.rev_append acc r
else aux (b::acc) r
in
aux [] l
let update_assoc k v l =
let rec aux acc = function
| [] -> List.rev ((k,v)::acc)
| (k1,_) as b::r ->
if k1 = k then List.rev_append acc ((k,v)::r)
else aux (b::acc) r
in
aux [] l
end
module Set = struct
module Make (O : OrderedType) = struct
module S = Set.Make(O)
include S
let fold f set i =
let r = ref i in
S.iter (fun elt ->
r := f elt !r
) set;
!r
let is_singleton s =
not (is_empty s) &&
min_elt s == max_elt s
let choose_one s =
if is_empty s then raise Not_found
else if is_singleton s then choose s
else failwith "choose_one"
let of_list l =
List.fold_left (fun set e -> add e set) empty l
let to_string s =
if S.cardinal s > max_print then
Printf.sprintf "%d elements" (S.cardinal s)
else
let l = S.fold (fun nv l -> O.to_string nv :: l) s [] in
OpamList.to_string (fun x -> x) (List.rev l)
let map f t =
S.fold (fun e set -> S.add (f e) set) t S.empty
exception Found of elt
let find_opt fn t =
try iter (fun x -> if fn x then raise (Found x)) t; None
with Found x -> Some x
let find fn t =
match find_opt fn t with
| Some x -> x
| None -> raise Not_found
let to_json t =
let elements = S.elements t in
let jsons = List.map O.to_json elements in
`A jsons
let of_json = function
| `A jsons ->
begin try
let get = function
| None -> raise Not_found
| Some v -> v in
let elems = List.map get (List.map O.of_json jsons) in
Some (S.of_list elems)
with Not_found -> None
end
| _ -> None
module Op = struct
let (++) = union
let (--) = diff
let (%%) = inter
end
let safe_add elt t =
if mem elt t
then failwith (Printf.sprintf "duplicate entry %s" (O.to_string elt))
else add elt t
end
end
module Map = struct
module Make (O : OrderedType) = struct
module M = Map.Make(O)
include M
let fold f map i =
let r = ref i in
M.iter (fun key value->
r:= f key value !r
) map;
!r
let map f map =
fold (fun key value map ->
add key (f value) map
) map empty
let mapi f map =
fold (fun key value map ->
add key (f key value) map
) map empty
let values map =
List.rev (M.fold (fun _ v acc -> v :: acc) map [])
let keys map =
List.rev (M.fold (fun k _ acc -> k :: acc) map [])
let union f m1 m2 =
M.merge (fun _ a b -> match a, b with
| Some _ as s, None | None, (Some _ as s) -> s
| Some v1, Some v2 -> Some (f v1 v2)
| None, None -> assert false)
m1 m2
let is_singleton s =
not (is_empty s) &&
fst (min_binding s) == fst (max_binding s)
let to_string string_of_value m =
if M.cardinal m > max_print then
Printf.sprintf "%d elements" (M.cardinal m)
else
let s (k,v) = Printf.sprintf "%s:%s" (O.to_string k) (string_of_value v) in
let l = fold (fun k v l -> s (k,v)::l) m [] in
OpamList.to_string (fun x -> x) l
let of_list l =
List.fold_left (fun map (k,v) -> add k v map) empty l
let to_json json_of_value t =
let bindings = M.bindings t in
let jsons = List.map (fun (k,v) ->
`O [ ("key" , O.to_json k);
("value", json_of_value v) ]
) bindings in
`A jsons
let of_json value_of_json = function
| `A jsons ->
begin try
let get_pair = function
| `O binding ->
begin match
O.of_json (List.assoc "key" binding),
value_of_json (List.assoc "value" binding)
with
| Some key, Some value -> (key, value)
| _ -> raise Not_found
end
| _ -> raise Not_found in
let pairs = List.map get_pair jsons in
Some (of_list pairs)
with Not_found -> None
end
| _ -> None
let find_opt k map = try Some (find k map) with Not_found -> None
let safe_add k v map =
if mem k map
then failwith (Printf.sprintf "duplicate entry %s" (O.to_string k))
else add k v map
let update k f zero map =
let v = try find k map with Not_found -> zero in
add k (f v) map
end
end
module AbstractString = struct
type t = string
let of_string x = x
let to_string x = x
let to_json x = `String x
let of_json = function
| `String x -> Some 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 = Set.Make(O)
module Map = Map.Make(O)
end
module OInt = struct
type t = int
let compare = compare
let to_string = string_of_int
let to_json i = `String (string_of_int i)
let of_json = function
| `String s -> (try Some (int_of_string s) with _ -> None)
| _ -> None
end
module IntMap = Map.Make(OInt)
module IntSet = Set.Make(OInt)
module Option = struct
let map f = function
| None -> None
| Some x -> Some (f x)
let iter f = function
| None -> ()
| Some x -> f x
let default dft = function
| None -> dft
| Some x -> x
let default_map dft = function
| None -> dft
| some -> some
let replace f = function
| None -> None
| Some x -> f x
let map_default f dft = function
| None -> dft
| Some x -> f x
let compare cmp o1 o2 = match o1,o2 with
| None, None -> 0
| Some _, None -> 1
| None, Some _ -> -1
| Some x1, Some x2 -> cmp x1 x2
let to_string ?(none="") f = function
| Some x -> f x
| None -> none
let some x = Some x
let none _ = None
let of_Not_found f x =
try Some (f x) with Not_found -> None
module Op = struct
let (>>=) = function
| None -> fun _ -> None
| Some x -> fun f -> f x
let (>>|) opt f = map f opt
let (>>+) opt f = match opt with
| None -> f ()
| some -> some
let (+!) opt dft = default dft opt
let (++) = function
| None -> fun opt -> opt
| some -> fun _ -> some
end
end
module OpamString = struct
module OString = struct
type t = string
let compare = compare
let to_string x = x
let to_json x = `String x
let of_json = function
| `String s -> Some s
| _ -> None
end
module StringSet = Set.Make(OString)
module StringMap = Map.Make(OString)
module SetSet = Set.Make(StringSet)
module SetMap = Map.Make(StringSet)
module Set = StringSet
module Map = StringMap
let starts_with ~prefix s =
let x = String.length prefix in
let n = String.length s in
n >= x
&& String.sub s 0 x = prefix
let ends_with ~suffix s =
let x = String.length suffix in
let n = String.length s in
n >= x
&& String.sub s (n - x) x = suffix
let contains_char s c =
try let _ = String.index s c in true
with Not_found -> false
let contains ~sub =
Re.(execp (compile (str sub)))
let exact_match re s =
try
let subs = Re.exec re s in
let subs = Array.to_list (Re.get_all_ofs subs) in
let n = String.length s in
let subs = List.filter (fun (s,e) -> s=0 && e=n) subs in
List.length subs > 0
with Not_found ->
false
let find_from f s i =
let l = String.length s in
if i < 0 || i > l then
invalid_arg "find_from"
else
let rec g i =
if i < l then
if f s.[i] then
i
else
g (succ i)
else
raise Not_found in
g i
let map f s =
let len = String.length s in
let b = Bytes.create len in
for i = 0 to len - 1 do Bytes.set b i (f s.[i]) done;
Bytes.to_string b
let is_whitespace = function
| ' ' | '\t' | '\r' | '\n' -> true
| _ -> false
let strip str =
let p = ref 0 in
let l = String.length str in
while !p < l && is_whitespace (String.unsafe_get str !p) do
incr p;
done;
let p = !p in
let l = ref (l - 1) in
while !l >= p && is_whitespace (String.unsafe_get str !l) do
decr l;
done;
String.sub str p (!l - p + 1)
let strip_right str =
let rec aux i =
if i < 0 || not (is_whitespace str.[i]) then i else aux (i-1)
in
let l = String.length str in
let i = aux (l-1) in
if i = l - 1 then str
else String.sub str 0 (i+1)
let sub_at n s =
if String.length s <= n then
s
else
String.sub s 0 n
let remove_prefix ~prefix s =
if starts_with ~prefix s then
let x = String.length prefix in
let n = String.length s in
String.sub s x (n - x)
else
s
let remove_suffix ~suffix s =
if ends_with ~suffix s then
let x = String.length suffix in
let n = String.length s in
String.sub s 0 (n - x)
else
s
let cut_at_aux fn s sep =
try
let i = fn s sep in
let name = String.sub s 0 i in
let version = String.sub s (i+1) (String.length s - i - 1) in
Some (name, version)
with Invalid_argument _ | Not_found ->
None
let cut_at = cut_at_aux String.index
let rcut_at = cut_at_aux String.rindex
let split s c =
(* old compat version (Re 1.2.0)
{[Re_str.split (Re_str.regexp (Printf.sprintf "[%c]+" c)) s]} *)
Re.(split (compile (rep1 (char c)))) s
let split_delim s c =
let tokens = Re.(split_full (compile (char c)) s) in
let rec aux acc = function
| [] -> acc
| (`Delim _)::[] -> ""::acc
| (`Text s)::tl -> aux (s::acc) tl
| (`Delim _)::tl -> aux acc tl
in
let acc0 =
match tokens with
| (`Delim _)::_ -> [""]
|_ -> []
in List.rev (aux acc0 tokens)
let fold_left f acc s =
let acc = ref acc in
for i = 0 to String.length s - 1 do acc := f !acc s.[i] done;
!acc
end
type warning_printer =
{mutable warning : 'a . ('a, unit, string, unit) format4 -> 'a}
let console = ref {warning = fun fmt -> Printf.ksprintf prerr_string fmt}
module Env = struct
(* Remove from a c-separated list of string the one with the given prefix *)
let reset_value ~prefix c v =
let v = OpamString.split v c in
List.filter (fun v -> not (OpamString.starts_with ~prefix v)) v
(* Split the list in two according to the first occurrence of the string
starting with the given prefix.
*)
let cut_value ~prefix c v =
let v = OpamString.split v c in
let rec aux before =
function
| [] -> [], List.rev before
| curr::after when OpamString.starts_with ~prefix curr ->
before, after
| curr::after -> aux (curr::before) after
in aux [] v
let list =
let lazy_env = lazy (
let e = Unix.environment () in
List.rev_map (fun s ->
match OpamString.cut_at s '=' with
| None -> s, ""
| Some p -> p
) (Array.to_list e)
) in
fun () -> Lazy.force lazy_env
let get =
if Sys.win32 then
fun n ->
let n = String.uppercase_ascii n in
snd (List.find (fun (k,_) -> String.uppercase_ascii k = n) (list ()))
else
fun n -> List.assoc n (list ())
let getopt n = try Some (get n) with Not_found -> None
let escape_single_quotes ?(using_backslashes=false) =
if using_backslashes then
Re.(replace (compile (set "\\\'")) ~f:(fun g -> "\\"^Group.get g 0))
else
Re.(replace_string (compile (char '\'')) ~by:"'\"'\"'")
end
(** To use when catching default exceptions: ensures we don't catch fatal errors
like C-c *)
let fatal e = match e with
| Sys.Break -> prerr_newline (); raise e
| Assert_failure _ | Match_failure _ -> raise e
| _ -> ()
module OpamSys = struct
let path_sep = if Sys.win32 then ';' else ':'
let split_path_variable ?(clean=true) =
if Sys.win32 then fun path ->
let length = String.length path in
let rec f acc index current last normal =
if index = length then
let current = current ^ String.sub path last (index - last) in
List.rev (if current <> "" then current::acc else acc)
else let c = path.[index]
and next = succ index in
if c = ';' && normal || c = '"' then
let current = current ^ String.sub path last (index - last) in
if c = '"' then
f acc next current next (not normal)
else
let acc = if current = "" then acc else current::acc in
f acc next "" next true
else
f acc next current last normal in
f [] 0 "" 0 true
else fun path ->
let split = if clean then OpamString.split else OpamString.split_delim in
split path path_sep
let with_process_in cmd args f =
if Sys.win32 then
assert false;
let path = split_path_variable (Env.get "PATH") in
let cmd =
List.find Sys.file_exists (List.map (fun d -> Filename.concat d cmd) path)
in
let ic = Unix.open_process_in (cmd^" "^args) in
try
let r = f ic in
ignore (Unix.close_process_in ic) ; r
with exn ->
ignore (Unix.close_process_in ic) ; raise exn
let tty_out = Unix.isatty Unix.stdout
let tty_in = Unix.isatty Unix.stdin
let default_columns =
let default = 16_000_000 in
let cols =
try int_of_string (Env.get "COLUMNS") with
| Not_found
| Failure _ -> default
in
if cols > 0 then cols else default
let get_terminal_columns () =
let fallback = 80 in
let cols =
try (* terminfo *)
with_process_in "tput" "cols"
(fun ic -> int_of_string (input_line ic))
with
| Unix.Unix_error _ | Sys_error _ | Failure _ | End_of_file | Not_found ->
try (* GNU stty *)
with_process_in "stty" "size"
(fun ic ->
match OpamString.split (input_line ic) ' ' with
| [_ ; v] -> int_of_string v
| _ -> failwith "stty")
with
| Unix.Unix_error _ | Sys_error _ | Failure _
| End_of_file | Not_found -> fallback
in
if cols > 0 then cols else fallback
let win32_get_console_width () =
let hConsoleOutput = OpamStubs.(getStdHandle STD_OUTPUT_HANDLE) in
let {OpamStubs.size = (width, _); _} =
OpamStubs.getConsoleScreenBufferInfo hConsoleOutput
in
width
let terminal_columns =
let v = ref (lazy (get_terminal_columns ())) in
let () =
try Sys.set_signal 28 (* SIGWINCH *)
(Sys.Signal_handle
(fun _ -> v := lazy (get_terminal_columns ())))
with Invalid_argument _ -> ()
in
if Sys.win32 then
fun () ->
if tty_out
then win32_get_console_width ()
else default_columns
else
fun () ->
if tty_out
then Lazy.force !v
else default_columns
let home =
let home = lazy (try Env.get "HOME" with Not_found -> Sys.getcwd ()) in
fun () -> Lazy.force home
let etc () = "/etc"
let uname =
let memo = Hashtbl.create 7 in
fun arg ->
try Hashtbl.find memo arg with Not_found ->
let r =
try
with_process_in "uname" arg
(fun ic -> Some (OpamString.strip (input_line ic)))
with Unix.Unix_error _ | Sys_error _ | Not_found -> None
in
Hashtbl.add memo arg r;
r
let system () =
(* CSIDL_SYSTEM = 0x25 *)
OpamStubs.(shGetFolderPath 0x25 SHGFP_TYPE_CURRENT)
type os =
| Darwin
| Linux
| FreeBSD
| OpenBSD
| NetBSD
| DragonFly
| Cygwin
| Win32
| Unix
| Other of string
let os =
let os = lazy (
match Sys.os_type with
| "Unix" -> begin
match uname "-s" with
| Some "Darwin" -> Darwin
| Some "Linux" -> Linux
| Some "FreeBSD" -> FreeBSD
| Some "OpenBSD" -> OpenBSD
| Some "NetBSD" -> NetBSD
| Some "DragonFly" -> DragonFly
| _ -> Unix
end
| "Win32" -> Win32
| "Cygwin" -> Cygwin
| s -> Other s
) in
fun () -> Lazy.force os
type shell = SH_sh | SH_bash | SH_zsh | SH_csh | SH_fish
let shell_of_string = function
| "tcsh"
| "bsd-csh"
| "csh" -> Some SH_csh
| "zsh" -> Some SH_zsh
| "bash" -> Some SH_bash
| "fish" -> Some SH_fish
| "sh" -> Some SH_sh
| _ -> None
let executable_name =
if Sys.win32 then
fun name ->
if Filename.check_suffix name ".exe" then
name
else
name ^ ".exe"
else
fun x -> x
let guess_shell_compat () =
let parent_guess =
if Sys.win32 then
None
else
let ppid = Unix.getppid () in
let dir = Filename.concat "/proc" (string_of_int ppid) in
try
Some (Unix.readlink (Filename.concat dir "exe"))
with e ->
fatal e;
try
with_process_in "ps"
(Printf.sprintf "-p %d -o comm= 2>/dev/null" ppid)
(fun ic -> Some (input_line ic))
with
| Unix.Unix_error _ | Sys_error _ | Failure _ | End_of_file | Not_found ->
try
let c = open_in_bin ("/proc/" ^ string_of_int ppid ^ "/cmdline") in
begin try
let s = input_line c in
close_in c;
Some (String.sub s 0 (String.index s '\000'))
with
| Not_found ->
None
| e ->
close_in c;
fatal e; None
end
with e ->
fatal e; None
in
let test shell = shell_of_string (Filename.basename shell) in
let shell =
match Option.replace test parent_guess with
| None ->
Option.of_Not_found Env.get "SHELL" |> Option.replace test
| some ->
some
in
Option.default SH_sh shell
let guess_dot_profile shell =
let home f =
try Filename.concat (home ()) f
with Not_found -> f in
match shell with
| SH_fish ->
List.fold_left Filename.concat (home ".config") ["fish"; "config.fish"]
| SH_zsh -> home ".zshrc"
| SH_bash ->
(try
List.find Sys.file_exists [
(* Bash looks up these 3 files in order and only loads the first,
for LOGIN shells *)
home ".bash_profile";
home ".bash_login";
home ".profile";
(* Bash loads .bashrc INSTEAD, for interactive NON login shells only;
but it's often included from the above.
We may include our variables in both to be sure ; for now we rely
on non-login shells inheriting their env from a login shell
somewhere... *)
]
with Not_found ->
(* iff none of the above exist, creating this should be safe *)
home ".bash_profile")
| SH_csh ->
let cshrc = home ".cshrc" in
let tcshrc = home ".tcshrc" in
if Sys.file_exists cshrc then cshrc else tcshrc
| SH_sh -> home ".profile"
let registered_at_exit = ref []
let at_exit f =
Pervasives.at_exit f;
registered_at_exit := f :: !registered_at_exit
let exec_at_exit () =
List.iter
(fun f -> try f () with _ -> ())
!registered_at_exit
let is_cygwin_variant =
if Sys.win32 then
let results = Hashtbl.create 17 in
let requires_cygwin name =
let cmd = Printf.sprintf "cygcheck \"%s\"" name in
let ((c, _, _) as process) = Unix.open_process_full cmd (Unix.environment ()) in
let rec f a =
match input_line c with
| x ->
if OpamString.ends_with ~suffix:"cygwin1.dll" (String.trim x) then
if OpamString.starts_with ~prefix:" " x then
f `Cygwin
else if a <> `Cygwin then
f `CygLinked
else
f a
else
f a
| exception _ ->
Unix.close_process_full process |> ignore;
a
in
f `Native
in
fun name ->
if Filename.is_relative name then
requires_cygwin name
else
try
Hashtbl.find results name
with Not_found ->
let result = requires_cygwin name
in
Hashtbl.add results name result;
result
else
fun _ -> `Native
exception Exit of int
exception Exec of string * string array * string array
let exit i = raise (Exit i)
type exit_reason =
[ `Success | `False | `Bad_arguments | `Not_found | `Aborted | `Locked
| `No_solution | `File_error | `Package_operation_error | `Sync_error
| `Configuration_error | `Solver_failure | `Internal_error
| `User_interrupt ]
let exit_codes : (exit_reason * int) list = [
(* Normal return values *)
`Success, 0;
`False, 1;
(* Errors happening in normal use (user related, or impossible requests) *)
`Bad_arguments, 2;
`Not_found, 5;
`Aborted, 10;
`Locked, 15;
`No_solution, 20;
(* Errors related to the database (repository and package definitions) *)
`File_error, 30;
`Package_operation_error, 31;
(* Network related error *)
`Sync_error, 40;
(* Opam setup error *)
`Configuration_error, 50;
(* Errors that shouldn't happen and are likely bugs *)
`Solver_failure, 60;
`Internal_error, 99;
(* Received signals *)
`User_interrupt, 130;
]
let get_exit_code reason = List.assoc reason exit_codes
let exit_because reason = exit (get_exit_code reason)
type nonrec warning_printer = warning_printer =
{mutable warning : 'a . ('a, unit, string, unit) format4 -> 'a}
let set_warning_printer =
let called = ref false in
fun printer ->
if !called then invalid_arg "Just what do you think you're doing, Dave?";
called := true;
console := printer
end