blob: d12ae6f5c00c79f42b8eadb6fced771a9b5a80c0 (
plain)
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
|
(* $Id$ *)
type binding
type client
type client_event = Connected | Disconnected
type cb = client -> string array -> unit
type client_cb = client -> client_event -> unit
external send : string -> unit = "ivy_sendMsg"
external stop : unit -> unit = "ivy_stop"
external ext_init : string -> string -> string -> unit = "ivy_init"
let gensym = let n = ref 0 in fun p -> incr n; p ^ string_of_int !n
let cb_register = fun closure ->
let s = gensym "callback_" in
Callback.register s closure;
s
let init = fun name ready ccb ->
ext_init name ready (cb_register ccb)
external start : string -> unit = "ivy_start"
external ext_bind : string -> string -> binding = "ivy_bindMsg"
let bind = fun (cb:cb) regexp ->
ext_bind (cb_register cb) regexp
external unbind : binding -> unit = "ivy_unbindMsg"
external name_of_client : client -> string = "ivy_name_of_client"
external host_of_client : client -> string = "ivy_host_of_client"
let marshal_tag = "MARSHAL"
let hexa_char = fun c ->
assert(0 <= c && c < 16);
if c < 10 then
Char.chr (c + Char.code '0')
else
Char.chr (c + Char.code 'A' - 10)
let hexa_code = fun c ->
if '0' <= c && c <= '9' then
Char.code c - Char.code '0'
else if 'A' <= c && c <= 'F' then
Char.code c - Char.code 'A' + 10
else failwith (Printf.sprintf "hexa_code: %c" c)
let hexa_of_string = fun s ->
let n = String.length s in
let h = Bytes.create (n*2) in
for i = 0 to n - 1 do
let c = Char.code s.[i] in
Bytes.set h (2*i) (hexa_char (c lsr 4));
Bytes.set h (2*i+1) (hexa_char (c land 0xf))
done;
Bytes.to_string h
let string_of_hexa = fun h ->
let n = String.length h / 2 in
let s = Bytes.create n in
for i = 0 to n - 1 do
Bytes.set s i (Char.chr (hexa_code h.[2*i] lsl 4 + hexa_code h.[2*i+1]))
done;
Bytes.to_string s
let send_data = fun tag value ->
let s = hexa_of_string (Marshal.to_string value []) in
send (Printf.sprintf "%s %s %s" marshal_tag tag s)
let data_bind = fun cb tag ->
let r = Printf.sprintf "%s %s (.*)" marshal_tag tag in
bind (fun c a -> cb c (Marshal.from_string (string_of_hexa a.(0)) 0)) r
|
