Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 214 lines (184 sloc) 6.982 kb
fccc685 Initial open-source release
MLstate authored
1 (*
2 Copyright © 2011 MLstate
3
4 This file is part of OPA.
5
6 OPA is free software: you can redistribute it and/or modify it under the
7 terms of the GNU Affero General Public License, version 3, as published by
8 the Free Software Foundation.
9
10 OPA is distributed in the hope that it will be useful, but WITHOUT ANY
11 WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
12 FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for
13 more details.
14
15 You should have received a copy of the GNU Affero General Public License
16 along with OPA. If not, see <http://www.gnu.org/licenses/>.
17 *)
18
19 (* THIS FILE HAS A DOCUMENTED MLI *)
20
21 (* error reporting *)
22 type error = int * string
23 let error_code = fst
24 let error_message = snd
25 exception Error of error
26
27 (* epoll descriptor *)
28 type epoll_descriptor = int
29
30 #<Ifstatic:MLSTATE_WINDOWS .*>
31 let last_error_message _ = assert false
32 let last_error_code _ = assert false
33 let ep_create _ = assert false
34 let ep_close _ = assert false
35 let ep_in _ = assert false
36 let ep_out _ = assert false
37 let ep_err _ = assert false
38 let ep_hup _ = assert false
39 let _on_mac _ = assert false
40 let on_mac = false
41 #<Else>
42 external last_error_message : unit -> string = "error_msg"
43 external last_error_code : unit -> int = "error_value"
44 external ep_create : int -> epoll_descriptor = "ep_create"
45 external ep_close : epoll_descriptor -> int = "ep_close"
46 external ep_in : unit -> int = "ep_EPOLLIN"
47 external ep_out : unit -> int = "ep_EPOLLOUT"
48 external ep_err : unit -> int = "ep_EPOLLERR"
49 external ep_hup : unit -> int = "ep_EPOLLHUP"
50 external _on_mac : unit -> bool = "on_mac"
51 let on_mac = _on_mac ()
52 #<End>
53
54 (* check_ret factory *)
55 let check_ret str ret =
56 if ret = -1 then
57 let message = Printf.sprintf "%s: %s" str (last_error_message ()) in
58 let code = last_error_code () in
59 Logger.error "Epoll error %d: %s" code message(* ; *)
60 (* raise (Error (code, message)) *)
61
62 (* events *)
63 type supported_event = In | Out | Hup | Err | Unsupported of int
64
65 type event = int
66 type event_mask = int
67
68 let event_in, event_out, event_in_out, event_hup, event_err =
69 let u() =(ep_in(), ep_out(), (ep_in() lor ep_out()), ep_hup(), ep_err()) in
70 let z()= (0, 0, 0, 0, 0) in
71 Mlstate_platform.platform_dependent
72 ~unix:u
73 ~cygwin:z
74 ~windows:z
75 () ()
76
77 let event_mask_to_list event_mask =
78 (* Frequent cases have to be memoized *)
79 if event_mask = event_in then [In] else
80 if event_mask = event_out then [Out] else
81 if event_mask = (event_in lor event_out) then [In; Out]
82 else begin
83 let f (r, l) (ie, ee) = if ((ie land r) = ie) then ((ie lxor r), ee::l) else (r, l) in
84 let rec aux (event_mask, event_list) events =
85 if event_mask = 0 then event_list
86 else (
87 match events with
88 | [] -> (Unsupported event_mask)::event_list
89 | h::t -> aux (f (event_mask, event_list) h) t
90 )
91 in
92 aux (event_mask, []) [(event_in, In); (event_out, Out); (event_hup, Hup); (event_err, Err)]
93 end
94
95
96 let event_list_to_mask event_list =
97 List.fold_left
98 (fun e_mask ee ->
99 let ie =
100 match ee with
101 | In -> event_in
102 | Out -> event_out
103 | Err -> event_err
104 | Hup -> event_hup
105 | Unsupported e -> e
106 in
107 ie lor e_mask
108 ) 0 event_list
109
110 (* requests *)
111
112 (* low level : private *)
113 #<Ifstatic:MLSTATE_WINDOWS .*>
114 let ep_add _ _ _ = assert false
115 let ep_del _ _ _ = assert false
116 let ep_mod _ _ _ = assert false
117 let ep_wait _ ~maxevents ~timeout =
118 let _ = ignore (maxevents, timeout) in
119 assert false
120 #<Else>
121 external ep_add : epoll_descriptor -> Unix.file_descr -> event_mask-> int = "ep_add"
122 external ep_del : epoll_descriptor -> Unix.file_descr -> event_mask -> int = "ep_del"
123 external ep_mod : epoll_descriptor -> Unix.file_descr -> event_mask -> int = "ep_mod"
124 external ep_wait : epoll_descriptor -> maxevents : int -> timeout : int -> (Unix.file_descr * event_mask) array = "ep_wait"
125 #<End>
126
127 (* high level : exported *)
128
129 (* The test [if int_of_filedesc fd >= 0 then] is there because weblib is also used with
130 dummy_connection (cf doc in mli). Dummy connections build negative file descriptor
131 In this case, Epoll ignore these file descriptors.
132 *)
133 external int_of_filedesc : Unix.file_descr -> int = "%identity"
134 external filedesc_of_int : int -> Unix.file_descr = "%identity"
135 external int_of_epoll_descriptor : epoll_descriptor -> int = "%identity"
136 external epoll_descriptor_of : int -> epoll_descriptor = "%identity"
137
138 let combine =
139 List.fold_left (lor) 0
140
141 let create size =
142 Mlstate_platform.on_windows (fun()->failwith "ep_create on windows");
143 let ret = ep_create size in
144 check_ret "epoll_create" ret;
145 epoll_descriptor_of ret (* normally useless ?? *)
146
147 let close ed = check_ret "epoll_close" (ep_close ed)
148
149 let del epfd fd =
150 Mlstate_platform.on_windows (fun()->failwith "ep_del on windows");
151 if int_of_filedesc fd >= 0 then
152 let ret =
153 if on_mac then (
154 let _ = ep_del epfd fd event_in in
155 ep_del epfd fd event_out )
156 else
157 ep_del epfd fd 0
158 in
159 check_ret "epoll_del" ret
160
161 let listen_in_out epfd ?(is_new_fd=false) fd =
162 if int_of_filedesc fd >= 0 then
163 let ret =
164 if on_mac then (
165 let _ = ep_add epfd fd event_in in
166 ep_add epfd fd event_out )
167 else (
168 if is_new_fd then
169 ep_add epfd fd event_in_out
170 else
171 ep_mod epfd fd event_in_out )
172 in
173 check_ret "listen_in_out" ret
174
175 let listen_x_only x y epfd is_new_fd fd =
176 if int_of_filedesc fd >= 0 then
177 let ret =
178 if on_mac then (
179 let _ = ep_del epfd fd y in
180 ep_add epfd fd x )
181 else (
182 if is_new_fd then
183 ep_add epfd fd x
184 else
185 ep_mod epfd fd x )
186 in
187 check_ret "listen_x_only" ret
188
189 let listen_in_only epfd is_new_fd fd = listen_x_only event_in event_out epfd is_new_fd fd
190 let listen_out_only epfd is_new_fd fd = listen_x_only event_out event_in epfd is_new_fd fd
191
192 let wait ?tout:(timeout = -1) epfd maxevents =
193 Mlstate_platform.on_windows (fun()->failwith "ep_wait on windows");
194 let a = ep_wait epfd ~maxevents ~timeout in
195 Array.map (fun (fd, events) -> (fd, event_mask_to_list events)) a
196
197 module Debug =
198 struct
199 (* This functions are used only for printing file descriptors and events (useful for debugging) *)
200 (* http://caml.inria.fr/pub/ml-archives/caml-list/2002/06/b0e3d11df12ca90608634197c0792939.en.html *)
201 external int_of_filedescr : Unix.file_descr -> int = "%identity"
202 external filedescr_of_int : int -> Unix.file_descr = "%identity"
203 external int_of_events : event_mask -> int = "%identity"
204 external int_of_epoll_descriptor : epoll_descriptor -> int = "%identity"
205
206 (* tests *)
207 (* let test() = *)
208 (* let fd = create (10) in *)
209 (* add fd Unix.stdout event_in; *)
210 (* add fd Unix.stdin event_in; *)
211 (* let arr = wait fd 10 in *)
212 (* Printf.printf "Got: %d\n" (Array.length arr) *)
213 end
Something went wrong with that request. Please try again.