Source file signal.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
open! Import
include (
Int :
sig
type t = int [@@deriving bin_io]
include Comparable.S with type t := t
include Hashable.S with type t := t
end)
let of_caml_int t = t
let to_caml_int t = t
type sys_behavior =
[ `Continue (** Continue the process if it is currently stopped *)
| `Dump_core (** Terminate the process and dump core *)
| `Ignore (** Ignore the signal *)
| `Stop (** Stop the process *)
| `Terminate (** Terminate the process *)
]
[@@deriving sexp]
let equal (t : t) t' = t = t'
include struct
open Caml.Sys
let abrt = sigabrt
let alrm = sigalrm
let bus = sigbus
let chld = sigchld
let cont = sigcont
let fpe = sigfpe
let hup = sighup
let ill = sigill
let int = sigint
let kill = sigkill
let pipe = sigpipe
let poll = sigpoll
let prof = sigprof
let quit = sigquit
let segv = sigsegv
let stop = sigstop
let sys = sigsys
let term = sigterm
let trap = sigtrap
let tstp = sigtstp
let ttin = sigttin
let ttou = sigttou
let urg = sigurg
let usr1 = sigusr1
let usr2 = sigusr2
let vtalrm = sigvtalrm
let xcpu = sigxcpu
let xfsz = sigxfsz
let zero = 0
end
exception Invalid_signal_mnemonic_or_number of string [@@deriving sexp]
let to_string_with_version, of_string, default_sys_behavior =
let known =
[
"sigabrt", abrt, `Dump_core, 1
; "sigalrm", alrm, `Terminate, 1
; "sigbus", bus, `Dump_core, 2
; "sigchld", chld, `Ignore, 1
; "sigcont", cont, `Continue, 1
; "sigfpe", fpe, `Dump_core, 1
; "sighup", hup, `Terminate, 1
; "sigill", ill, `Dump_core, 1
; "sigint", int, `Terminate, 1
; "sigkill", kill, `Terminate, 1
; "sigpipe", pipe, `Terminate, 1
; "sigpoll", poll, `Terminate, 2
; "sigprof", prof, `Terminate, 1
; "sigquit", quit, `Dump_core, 1
; "sigsegv", segv, `Dump_core, 1
; "sigstop", stop, `Stop, 1
; "sigsys", sys, `Dump_core, 2
; "sigterm", term, `Terminate, 1
; "sigtrap", trap, `Dump_core, 2
; "sigtstp", tstp, `Stop, 1
; "sigttin", ttin, `Stop, 1
; "sigttou", ttou, `Stop, 1
; "sigurg", urg, `Ignore, 2
; "sigusr1", usr1, `Terminate, 1
; "sigusr2", usr2, `Terminate, 1
; "sigvtalrm", vtalrm, `Terminate, 1
; "sigxcpu", xcpu, `Dump_core, 2
; "sigxfsz", xfsz, `Dump_core, 2
; "sigzero", zero, `Ignore, 1
]
in
let name_and_version_by_t = Int.Table.create ~size:1 () in
let t_by_name = String.Table.create ~size:1 () in
let behavior_by_t = Int.Table.create ~size:1 () in
List.iter known ~f:(fun (name, t, behavior, stable_version) ->
Hashtbl.set name_and_version_by_t ~key:t ~data:(name, stable_version);
Hashtbl.set t_by_name ~key:name ~data:t;
Hashtbl.set behavior_by_t ~key:t ~data:behavior);
let to_string_with_version t ~version:requested_version =
match Hashtbl.find name_and_version_by_t t with
| Some (string, needed_version) when requested_version >= needed_version -> string
| _ -> "<unknown signal " ^ Int.to_string t ^ ">"
in
let of_string s =
let s = String.lowercase (String.strip s) in
match Hashtbl.find t_by_name s with
| Some sn -> sn
| None ->
if String.is_prefix s ~prefix:"<unknown signal "
then (
try Int.of_string (String.slice s 16 ~-1) with
| _ -> raise (Invalid_signal_mnemonic_or_number s))
else raise (Invalid_signal_mnemonic_or_number s)
in
let default_sys_behavior t =
match Hashtbl.find behavior_by_t t with
| None ->
raise
(Invalid_argument
("Signal.default_sys_behavior: unknown signal " ^ Int.to_string t))
| Some behavior -> behavior
in
to_string_with_version, of_string, default_sys_behavior
;;
exception Expected_atom of Sexp.t [@@deriving sexp]
let sexp_of_t_with_version t ~version = Sexp.Atom (to_string_with_version t ~version)
let to_string s = to_string_with_version s ~version:2
let sexp_of_t t = sexp_of_t_with_version t ~version:1
let t_of_sexp s =
match s with
| Sexp.Atom s -> of_string s
| _ -> raise (Expected_atom s)
;;
type pid_spec = [ `Use_Signal_unix ]
type sigprocmask_command = [ `Use_Signal_unix ]
let can_send_to = `Use_Signal_unix
let of_system_int = `Use_Signal_unix
let send = `Use_Signal_unix
let send_exn = `Use_Signal_unix
let send_i = `Use_Signal_unix
let sexp_of_pid_spec = `Use_Signal_unix
let sigpending = `Use_Signal_unix
let sigprocmask = `Use_Signal_unix
let sigsuspend = `Use_Signal_unix
let to_system_int = `Use_Signal_unix
module Expert = struct
type behavior =
[ `Default
| `Ignore
| `Handle of t -> unit
]
module Behavior = struct
let of_caml = function
| Caml.Sys.Signal_default -> `Default
| Signal_ignore -> `Ignore
| Signal_handle f -> `Handle f
;;
let to_caml = function
| `Default -> Caml.Sys.Signal_default
| `Ignore -> Signal_ignore
| `Handle f -> Signal_handle (fun t -> Exn.handle_uncaught_and_exit (fun () -> f t))
;;
end
let signal t behavior = Behavior.of_caml (Caml.Sys.signal t (Behavior.to_caml behavior))
let set t behavior = ignore (signal t behavior : behavior)
let handle t f = set t (`Handle f)
end
open Expert
let handle_default t = set t `Default
let ignore t = set t `Ignore
module Stable = struct
module V2 = struct
type nonrec t = t [@@deriving bin_io, compare]
let t_of_sexp = t_of_sexp
let sexp_of_t t = sexp_of_t_with_version t ~version:2
end
module V1 = struct
type nonrec t = t [@@deriving bin_io, compare]
let t_of_sexp = t_of_sexp
let sexp_of_t t = sexp_of_t_with_version t ~version:1
end
end