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.953 kB
(*
Copyright © 2011 MLstate
This file is part of OPA.
Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at
http://www.apache.org/licenses/LICENSE-2.0
Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
See the License for the specific language governing permissions and
limitations under the License.
*)
(* 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.