Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Fetching contributors…

Cannot retrieve contributors at this time

214 lines (184 sloc) 6.982 kb
(*
Copyright © 2011 MLstate
This file is part of OPA.
OPA is free software: you can redistribute it and/or modify it under the
terms of the GNU Affero General Public License, version 3, as published by
the Free Software Foundation.
OPA is distributed in the hope that it will be useful, but WITHOUT ANY
WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for
more details.
You should have received a copy of the GNU Affero General Public License
along with OPA. If not, see <http://www.gnu.org/licenses/>.
*)
(* THIS FILE HAS A DOCUMENTED MLI *)
(* error reporting *)
type error = int * string
let error_code = fst
let error_message = snd
exception Error of error
(* epoll descriptor *)
type epoll_descriptor = int
#<Ifstatic:MLSTATE_WINDOWS .*>
let last_error_message _ = assert false
let last_error_code _ = assert false
let ep_create _ = assert false
let ep_close _ = assert false
let ep_in _ = assert false
let ep_out _ = assert false
let ep_err _ = assert false
let ep_hup _ = assert false
let _on_mac _ = assert false
let on_mac = false
#<Else>
external last_error_message : unit -> string = "error_msg"
external last_error_code : unit -> int = "error_value"
external ep_create : int -> epoll_descriptor = "ep_create"
external ep_close : epoll_descriptor -> int = "ep_close"
external ep_in : unit -> int = "ep_EPOLLIN"
external ep_out : unit -> int = "ep_EPOLLOUT"
external ep_err : unit -> int = "ep_EPOLLERR"
external ep_hup : unit -> int = "ep_EPOLLHUP"
external _on_mac : unit -> bool = "on_mac"
let on_mac = _on_mac ()
#<End>
(* check_ret factory *)
let check_ret str ret =
if ret = -1 then
let message = Printf.sprintf "%s: %s" str (last_error_message ()) in
let code = last_error_code () in
Logger.error "Epoll error %d: %s" code message(* ; *)
(* raise (Error (code, message)) *)
(* events *)
type supported_event = In | Out | Hup | Err | Unsupported of int
type event = int
type event_mask = int
let event_in, event_out, event_in_out, event_hup, event_err =
let u() =(ep_in(), ep_out(), (ep_in() lor ep_out()), ep_hup(), ep_err()) in
let z()= (0, 0, 0, 0, 0) in
Mlstate_platform.platform_dependent
~unix:u
~cygwin:z
~windows:z
() ()
let event_mask_to_list event_mask =
(* Frequent cases have to be memoized *)
if event_mask = event_in then [In] else
if event_mask = event_out then [Out] else
if event_mask = (event_in lor event_out) then [In; Out]
else begin
let f (r, l) (ie, ee) = if ((ie land r) = ie) then ((ie lxor r), ee::l) else (r, l) in
let rec aux (event_mask, event_list) events =
if event_mask = 0 then event_list
else (
match events with
| [] -> (Unsupported event_mask)::event_list
| h::t -> aux (f (event_mask, event_list) h) t
)
in
aux (event_mask, []) [(event_in, In); (event_out, Out); (event_hup, Hup); (event_err, Err)]
end
let event_list_to_mask event_list =
List.fold_left
(fun e_mask ee ->
let ie =
match ee with
| In -> event_in
| Out -> event_out
| Err -> event_err
| Hup -> event_hup
| Unsupported e -> e
in
ie lor e_mask
) 0 event_list
(* requests *)
(* low level : private *)
#<Ifstatic:MLSTATE_WINDOWS .*>
let ep_add _ _ _ = assert false
let ep_del _ _ _ = assert false
let ep_mod _ _ _ = assert false
let ep_wait _ ~maxevents ~timeout =
let _ = ignore (maxevents, timeout) in
assert false
#<Else>
external ep_add : epoll_descriptor -> Unix.file_descr -> event_mask-> int = "ep_add"
external ep_del : epoll_descriptor -> Unix.file_descr -> event_mask -> int = "ep_del"
external ep_mod : epoll_descriptor -> Unix.file_descr -> event_mask -> int = "ep_mod"
external ep_wait : epoll_descriptor -> maxevents : int -> timeout : int -> (Unix.file_descr * event_mask) array = "ep_wait"
#<End>
(* high level : exported *)
(* The test [if int_of_filedesc fd >= 0 then] is there because weblib is also used with
dummy_connection (cf doc in mli). Dummy connections build negative file descriptor
In this case, Epoll ignore these file descriptors.
*)
external int_of_filedesc : Unix.file_descr -> int = "%identity"
external filedesc_of_int : int -> Unix.file_descr = "%identity"
external int_of_epoll_descriptor : epoll_descriptor -> int = "%identity"
external epoll_descriptor_of : int -> epoll_descriptor = "%identity"
let combine =
List.fold_left (lor) 0
let create size =
Mlstate_platform.on_windows (fun()->failwith "ep_create on windows");
let ret = ep_create size in
check_ret "epoll_create" ret;
epoll_descriptor_of ret (* normally useless ?? *)
let close ed = check_ret "epoll_close" (ep_close ed)
let del epfd fd =
Mlstate_platform.on_windows (fun()->failwith "ep_del on windows");
if int_of_filedesc fd >= 0 then
let ret =
if on_mac then (
let _ = ep_del epfd fd event_in in
ep_del epfd fd event_out )
else
ep_del epfd fd 0
in
check_ret "epoll_del" ret
let listen_in_out epfd ?(is_new_fd=false) fd =
if int_of_filedesc fd >= 0 then
let ret =
if on_mac then (
let _ = ep_add epfd fd event_in in
ep_add epfd fd event_out )
else (
if is_new_fd then
ep_add epfd fd event_in_out
else
ep_mod epfd fd event_in_out )
in
check_ret "listen_in_out" ret
let listen_x_only x y epfd is_new_fd fd =
if int_of_filedesc fd >= 0 then
let ret =
if on_mac then (
let _ = ep_del epfd fd y in
ep_add epfd fd x )
else (
if is_new_fd then
ep_add epfd fd x
else
ep_mod epfd fd x )
in
check_ret "listen_x_only" ret
let listen_in_only epfd is_new_fd fd = listen_x_only event_in event_out epfd is_new_fd fd
let listen_out_only epfd is_new_fd fd = listen_x_only event_out event_in epfd is_new_fd fd
let wait ?tout:(timeout = -1) epfd maxevents =
Mlstate_platform.on_windows (fun()->failwith "ep_wait on windows");
let a = ep_wait epfd ~maxevents ~timeout in
Array.map (fun (fd, events) -> (fd, event_mask_to_list events)) a
module Debug =
struct
(* This functions are used only for printing file descriptors and events (useful for debugging) *)
(* http://caml.inria.fr/pub/ml-archives/caml-list/2002/06/b0e3d11df12ca90608634197c0792939.en.html *)
external int_of_filedescr : Unix.file_descr -> int = "%identity"
external filedescr_of_int : int -> Unix.file_descr = "%identity"
external int_of_events : event_mask -> int = "%identity"
external int_of_epoll_descriptor : epoll_descriptor -> int = "%identity"
(* tests *)
(* let test() = *)
(* let fd = create (10) in *)
(* add fd Unix.stdout event_in; *)
(* add fd Unix.stdin event_in; *)
(* let arr = wait fd 10 in *)
(* Printf.printf "Got: %d\n" (Array.length arr) *)
end
Jump to Line
Something went wrong with that request. Please try again.