package shexp

  1. Overview
  2. Docs

Source file import.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
module List = struct
  include ListLabels

  let concat_map l ~f = map l ~f |> concat
end

include (StdLabels : module type of struct include StdLabels end with module List := StdLabels.List)
include MoreLabels

module SMap = struct
  include Map.Make(String)
  let lookup t key =
    match find t key with
    | x -> Some x
    | exception Not_found -> None
end
module SSet = Set.Make(String)

include Shexp_sexp.Std
include Shexp_bigstring_io.Std

external reraise : exn -> _ = "%reraise"

let protectx ~finally ~f x =
  match f x with
  | y           -> finally x; y
  | exception e -> finally x; reraise e

let sprintf = Printf.sprintf

let ( ^/ ) = Filename.concat

module W : sig
  type 'a t
  val unit : unit t
  val int : int t
  val string : string t
  val process_status : Unix.process_status t
  val fd : Unix.file_descr t
  val stats : Unix.LargeFile.stats t
  val dir_handle : Unix.dir_handle t
  val pair : 'a t -> 'b t -> ('a * 'b) t
end = struct
  type 'a t = unit
  let unit = ()
  let int = ()
  let string = ()
  let process_status = ()
  let fd = ()
  let stats = ()
  let dir_handle = ()
  let pair _ _ = ()
end

(* We require a witness to be sure we apply the function fully *)
let retry_eintr : 'a. 'a W.t -> (unit -> 'a) -> 'a =
  let [@inline always] rec loop f n =
    try
      f ()
    with Unix.Unix_error (EINTR, _, _) when n < 1000 ->
      loop f (n + 1)
  in
  fun _ f -> loop f 0

let retry_eintr1 w f x = retry_eintr w (fun () -> f x)
let retry_eintr2 w f x y = retry_eintr w (fun () -> f x y)
let retry_eintr3 w f x y z = retry_eintr w (fun () -> f x y z)

module Unix = struct
  open Unix

  type nonrec file_descr        = file_descr
  type nonrec stats             = LargeFile.stats
  type nonrec access_permission = access_permission

  exception Unix_error = Unix_error

  let getpid      = getpid
  let environment = environment
  let stdin       = stdin
  let stdout      = stdout
  let stderr      = stderr
  let sleepf      = sleepf

  let close    x     = retry_eintr1 W.unit                      close           x
  let openfile x y z = retry_eintr3 W.fd                        openfile        x y z
  let readlink x     = retry_eintr1 W.string                    readlink        x
  let mkdir    x y   = retry_eintr2 W.unit                      mkdir           x y
  let chmod    x y   = retry_eintr2 W.unit                      chmod           x y
  let chown    x y z = retry_eintr3 W.unit                      chown           x y z
  let unlink   x     = retry_eintr1 W.unit                      unlink          x
  let rmdir    x     = retry_eintr1 W.unit                      rmdir           x
  let mkfifo   x y   = retry_eintr2 W.unit                      mkfifo          x y
  let link     x y   = retry_eintr2 W.unit                      link            x y
  let symlink  x y   = retry_eintr2 W.unit                      symlink         x y
  let rename   x y   = retry_eintr2 W.unit                      rename          x y
  let stat     x     = retry_eintr1 W.stats                     LargeFile.stat  x
  let lstat    x     = retry_eintr1 W.stats                     LargeFile.lstat x
  let access   x y   = retry_eintr2 W.unit                      access          x y
  let readdir  x     = retry_eintr1 W.string                    readdir         x
  let opendir  x     = retry_eintr1 W.dir_handle                opendir         x
  let closedir x     = retry_eintr1 W.unit                      closedir        x
  let lseek    x y z = retry_eintr3 W.int                       lseek           x y z
  let waitpid  x y   = retry_eintr2 W.(pair int process_status) waitpid         x y
end

module Posixat = struct
  open Posixat

  module Fd                = Fd
  module Open_flag         = Open_flag
  module At_flag           = At_flag
  module Access_permission = Access_permission
  module File_kind         = File_kind
  module File_perm         = File_perm
  module Stats             = Stats

  let at_fdcwd     = at_fdcwd
  let has_mkfifoat = has_mkfifoat

  let openat ~dir ~path ~flags ~perm = retry_eintr W.fd (fun () ->
    openat ~dir ~path ~flags ~perm)

  let faccessat ~dir ~path ~mode ~flags = retry_eintr W.unit (fun () ->
    faccessat ~dir ~path ~mode ~flags)

  let fchmodat ~dir ~path ~perm ~flags = retry_eintr W.unit (fun () ->
    fchmodat ~dir ~path ~perm ~flags)

  let fchownat ~dir ~path ~uid ~gid ~flags = retry_eintr W.unit (fun () ->
    fchownat ~dir ~path ~uid ~gid ~flags)

  let mkdirat ~dir ~path ~perm = retry_eintr W.unit (fun () ->
    mkdirat ~dir ~path ~perm)

  let unlinkat ~dir ~path ~flags = retry_eintr W.unit (fun () ->
    unlinkat ~dir ~path ~flags)

  let mkfifoat ~dir ~path ~perm = retry_eintr W.unit (fun () ->
    mkfifoat ~dir ~path ~perm)

  let linkat ~olddir ~oldpath ~newdir ~newpath ~flags = retry_eintr W.unit (fun () ->
    linkat ~olddir ~oldpath ~newdir ~newpath ~flags)

  let renameat ~olddir ~oldpath ~newdir ~newpath = retry_eintr W.unit (fun () ->
    renameat ~olddir ~oldpath ~newdir ~newpath)

  let symlinkat ~oldpath ~newdir ~newpath = retry_eintr W.unit (fun () ->
    symlinkat ~oldpath ~newdir ~newpath)

  let fstatat ~dir ~path ~flags = retry_eintr W.stats (fun () ->
    fstatat ~dir ~path ~flags)

  let readlinkat ~dir ~path = retry_eintr W.string (fun () ->
    readlinkat ~dir ~path)

  let fdopendir fd = retry_eintr1 W.dir_handle fdopendir fd
end
OCaml

Innovation. Community. Security.