package gapi-ocaml

You can search for identifiers within the package.
in-package search v0.2.0
gapi-ocaml
Legend:
Page
Library
Module
Module type
Parameter
Class
Class type
Source
Source file `netsys_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
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
(* $Id$ *)

open Printf

external _exit : int -> unit = "netsys__exit";;
(* needed here to avoid dep on Netsys *)

type action =
    [ `Callback of int -> unit
    | `Install of unit -> unit
    ]


type entry =
    { sig_number : int;
      sig_library : string option;
      sig_priority : int;
      sig_keep_default : bool;
      sig_name : string;
      sig_action : action;
    }


module Debug = struct
  let enable = ref false
end

let dlog = Netlog.Debug.mk_dlog "Netsys_signal" Debug.enable
let dlogr = Netlog.Debug.mk_dlogr "Netsys_signal" Debug.enable

let () =
  Netlog.Debug.register_module "Netsys_signal" Debug.enable


let is_win32 =
  match Sys.os_type with
    | "Win32" -> true
    | _ -> false


let sig_enable = Hashtbl.create 30
  (** Maps signal number to [`Unchanged], [`Enabled], [`Disabled], or
      [`Exclusive].
      [`Unchanged] is the same as if there was no entry for the signal 
      number and means that [Sys.set_signal] has not been called yet.
      [`Enabled] means this function has been called. [`Disabled] means
      that the signal is on the "keep away list". [`Exclusive] is like
      [`Enabled] for exclusive handlers.
   *)

let sig_definition = Hashtbl.create 30
  (** Maps signal number to [entry] in priority order. *)

let otp = !Netsys_oothr.provider

let mutex = otp # create_mutex()


let while_locked f =
  Netsys_oothr.serialize mutex f ()

let lethal_default_actions =
  [ Sys.sighup; Sys.sigint; Sys.sigquit; Sys.sigill; Sys.sigabrt;
    Sys.sigfpe; (* Sys.sigkill *) Sys.sigsegv; (* Sys.sigpipe *)
    Sys.sigalrm; Sys.sigterm; Sys.sigusr1; Sys.sigusr2; 
  ]

let handle signo =
  dlogr (fun () -> sprintf "handle %d" signo);
  let entries =
    try Hashtbl.find sig_definition signo
    with Not_found -> [] in
  let emulate_default = ref true in
  List.iter
    (fun entry ->
       emulate_default := !emulate_default && entry.sig_keep_default;
       try
	 match entry.sig_action with
	   | `Install _ -> ()
	   | `Callback cb ->
	       dlogr (fun () -> 
			sprintf "signal %d calling back %s handler '%s'"
			  signo
			  (match entry.sig_library with 
			     | None -> "application"
			     | Some lib -> "library '" ^ lib ^ "'")
			  entry.sig_name
		     );
	       cb signo
       with _ -> ()
	 (* Be hard with exceptions here! *)
    )
    entries;
  if !emulate_default then (
    dlogr (fun () -> sprintf "signal %d emulating default" signo);
    (* If the default signal action is not "ignore", it is an action that
       will terminate the process. So we can emulate it by setting the
       signal handler again, and by sending the signal to the process.
     *)
    if List.mem signo lethal_default_actions then (
      _exit 126;
      (*  - This does not reliably work in multi-threaded programs: *)
      (*
      ignore(Sys.signal signo Sys.Signal_default);
      Unix.kill (Unix.getpid()) signo;
      (* The signal signo is pending but usually blocked because this function
       * is called from within the signal handler for signo. To force that
       * the signal is delivered we must unblock the signal.
       *)
      ignore(Unix.sigprocmask Unix.SIG_UNBLOCK [ signo ]);
      (* Wait for any signal - at least signo will happen! *)
      while true do Unix.pause() done;
      (* Never return to this point of execution! *)
      assert false
       *)
    )
  )


let sig_manage signo =  
  (* must not be called for `Exclusive handlers! *)
  let is_disabled =
    try Hashtbl.find sig_enable signo = `Disabled
    with Not_found -> false in
  if not is_disabled then (
    ( try
	dlogr (fun () -> sprintf "signal %d installing normal handler" signo);
	Sys.set_signal signo (Sys.Signal_handle handle)
      with Invalid_argument _ -> ()
    );
    Hashtbl.replace sig_enable signo `Enabled
  )

let sig_install entry =
  (* only for `Exclusive handlers! *)
  let is_disabled =
    try Hashtbl.find sig_enable entry.sig_number = `Disabled
    with Not_found -> false in
  if not is_disabled then (
    match entry.sig_action with
      | `Callback _ -> assert false
      | `Install f -> 
	  dlogr (fun () -> 
		   sprintf "signal %d installing excl handler" 
		     entry.sig_number);
	  f();
	  Hashtbl.replace sig_enable entry.sig_number `Exclusive
  )
	

let restore_management signo =
  while_locked
    (fun () ->
       let state =
	 try Hashtbl.find sig_enable signo
	 with Not_found -> `Unchanged in
       match state with
	 | `Enabled -> 
	     sig_manage signo
	 | `Exclusive -> 
	     ( match Hashtbl.find sig_definition signo with
		 | [ e ] -> sig_install e
		 | _ -> assert false
	     )
	 | _ ->
	     ()
    )


let keep_away_from signo =
  while_locked
    (fun () ->
       let state =
	 try Hashtbl.find sig_enable signo
	 with Not_found -> `Unchanged in
       dlogr (fun () -> sprintf "signal %d keep away %s" 
		signo
		( match state with
		    | `Enabled -> 
			"- HANDLER ALREADY DEFINED!"
		    | `Exclusive ->
			"- EXCLUSIVE HANDLER ALREADY INSTALLED!"
		    | _ ->
			""
		)
	     );
       Hashtbl.replace sig_enable signo `Disabled
    )


let register_handler ?library ?priority ?(keep_default=false) 
                     ~name ~signal ~callback () =
  while_locked
    (fun () ->
       let state =
	 try Hashtbl.find sig_enable signal
	 with Not_found -> `Unchanged in
       if state = `Exclusive then
	 failwith ("Netsys_signal.register_handler: \
                    Cannot override an exclusive handler (signal " ^ 
		     string_of_int signal ^ ")");
       let entry =
	 { sig_number = signal;
	   sig_library = library;
	   sig_priority = if library=None then 100 else 0;
	   sig_keep_default = keep_default;
	   sig_name = name;
	   sig_action = `Callback callback
	 } in
       let old_list =
	 try Hashtbl.find sig_definition signal
	 with Not_found -> [] in
       let same_handler e1 e2 =
	 e1.sig_number = e2.sig_number &&
	 e1.sig_library = e2.sig_library &&
	 e1.sig_name = e2.sig_name in
       let hdl_exists = List.exists (fun e -> same_handler entry e) old_list in
       let rm_list =
	 if hdl_exists then
	   List.filter
	     (fun e -> not(same_handler entry e))
	     old_list
	 else
	   old_list in
       let new_list =
	 List.sort
	   (fun e1 e2 ->
	      match compare e1.sig_priority e2.sig_priority with
		| 0 -> compare e1.sig_name e2.sig_name
	   | n -> n
	   )
	   (entry :: rm_list) in
       Hashtbl.replace sig_definition signal new_list;
       sig_manage signal
    )


let register_exclusive_handler ~name ~signal ~install () =
  while_locked
    (fun () ->
       let state =
	 try Hashtbl.find sig_enable signal
	 with Not_found -> `Unchanged in
       if state = `Enabled then
	 failwith ("Netsys_signal.register_exclusive_handler: \
                    There is already a handler definition (signal " ^ 
		     string_of_int signal ^ ")");
       let entry =
	 { sig_number = signal;
	   sig_library = None;
	   sig_priority = 100;
	   sig_keep_default = false;
	   sig_name = name;
	   sig_action = `Install install
	 } in
       Hashtbl.replace sig_definition signal [entry];
       sig_install entry
    )


let list() =
  while_locked
    (fun () ->
       Hashtbl.fold
	 (fun _ l acc -> l @ acc)
	 sig_definition
	 []
    )

let keep_away_list() =
  while_locked
    (fun () ->
       Hashtbl.fold
	 (fun signo state acc ->
	    if state = `Disabled then signo::acc else acc)
	 sig_enable
	 []
    )

let () =
  if is_win32 then (
    (* Disable all except Sys.sigint: *)
    List.iter
      (fun signo -> Hashtbl.add sig_enable signo `Disabled)
      [ Sys.sigabrt; Sys.sigalrm; Sys.sigfpe; Sys.sighup; Sys.sigill;
	Sys.sigkill; Sys.sigpipe; Sys.sigquit; Sys.sigsegv; Sys.sigterm;
	Sys.sigusr1; Sys.sigusr2; Sys.sigchld; Sys.sigcont; Sys.sigstop;
	Sys.sigtstp; Sys.sigttin; Sys.sigttou; Sys.sigvtalrm; Sys.sigprof
      ]
  )

let () =
  register_handler
    ~library:"netsys"
    ~name:"Sigpipe default handler"
    ~signal:Sys.sigpipe
    ~callback:(fun _ -> ())
    ()

let init() = ()
package gapi-ocaml

Source file netsys_signal.ml

Source file `netsys_signal.ml`
