├── .gitignore ├── LICENSE ├── Makefile ├── README.md ├── erlterm_tests ├── bar.et ├── bignum.et ├── bignum2.et ├── bignum3.et ├── bits.et ├── float-1.2.et ├── float0.et ├── float1.2.et ├── foo.et ├── fun.et ├── out.et ├── ref1.et ├── ref2.et └── ref3.et ├── ocaml-erlang-port ├── ErlangPort.ml ├── ErlangPort.mli ├── ErlangTerm.ml ├── ErlangTerm.mli ├── ErlangTerm_Check.ml ├── META └── Makefile ├── rebar ├── rebar.config └── src ├── ocaml_erlang_port.app.src └── portserver.erl /.gitignore: -------------------------------------------------------------------------------- 1 | ocaml-erlang-port/*.o 2 | ocaml-erlang-port/*.a 3 | ocaml-erlang-port/*.cm* 4 | erlterm_check 5 | ebin 6 | deps 7 | .eunit 8 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2008, 2009 JackNyfe, Inc. (dba Echo) http://aboutecho.com/ 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without 5 | modification, are permitted provided that the following conditions 6 | are met: 7 | 1. Redistributions of source code must retain the above copyright 8 | notice, this list of conditions and the following disclaimer. 9 | 2. Redistributions in binary form must reproduce the above copyright 10 | notice, this list of conditions and the following disclaimer in the 11 | documentation and/or other materials provided with the distribution. 12 | 13 | THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND 14 | ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 15 | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 16 | ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE 17 | FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 18 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 19 | OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 20 | HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 21 | LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY 22 | OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF 23 | SUCH DAMAGE. 24 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | all: 2 | $(REBAR) compile 3 | 4 | install: 5 | cd ocaml-erlang-port; $(MAKE) install 6 | 7 | install-package: 8 | cd ocaml-erlang-port; $(MAKE) install-package 9 | 10 | uninstall: 11 | cd ocaml-erlang-port; $(MAKE) uninstall 12 | 13 | ocaml-check: 14 | cd ocaml-erlang-port; $(MAKE) check 15 | 16 | ocaml: 17 | cd ocaml-erlang-port; $(MAKE) 18 | 19 | clean-ocaml: 20 | cd ocaml-erlang-port; $(MAKE) clean 21 | 22 | check: ocaml-check 23 | $(REBAR) eunit 24 | 25 | clean: clean-ocaml 26 | $(REBAR) clean 27 | 28 | .PHONY: ocaml clean-ocaml ocaml-check 29 | 30 | REBAR ?= $(shell which ./rebar) 31 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | ocaml-erlang-port 2 | ================= 3 | 4 | Installation 5 | ------------ 6 | 7 | $ ocaml setup.ml -configure 8 | $ ocaml setup.ml -build 9 | $ ocaml setup.ml -install 10 | 11 | 12 | Examples 13 | -------- 14 | 15 | ### OCaml 16 | 17 | ```ocaml 18 | open ErlangTerm 19 | 20 | let port_command_dispatcher old_value = function 21 | | ET_Tuple [ET_Atom "forget"; _] -> 22 | None, ET_Atom "ok" 23 | | ET_Tuple [ET_Atom "set"; term] -> 24 | Some term, ET_Atom "ok" 25 | | ET_Tuple [ET_Atom "get"; _] -> 26 | old_value, begin match old_value with 27 | | None -> ET_Tuple [ET_Atom "error"; ET_Atom "no_value"] 28 | | Some term -> ET_Tuple [ET_Atom "ok"; term] 29 | end 30 | | _ -> raise (Failure "Unknown command") 31 | ;; 32 | 33 | ErlangPort.erlang_port_interact_with_key port_command_dispatcher None 34 | ``` 35 | 36 | To compile the code above run: 37 | 38 | $ cd examples/ 39 | $ ocamlfind ocamlopt -package ocaml-erlang-port -linkpkg -o port_sample port_sample.ml 40 | 41 | 42 | ### Erlang 43 | 44 | Make sure you have [mavg](https://github.com/EchoTeam/mavg) package 45 | installed. Then launch the `port_sample` binary using `portserver.erl`. 46 | 47 | 1> c(portserver). 48 | {ok,portserver} 49 | 2> portserver:start_link({local, ocaml}, "./port_sample"). 50 | {ok,<0.40.0>} 51 | 3> portserver:call(ocaml, get, []). 52 | {error,no_value} 53 | 4> portserver:call(ocaml, set, {foo,bar}). 54 | ok 55 | 5> portserver:call(ocaml, get, []). 56 | {ok,{foo,bar}} 57 | 6> portserver:call(ocaml, forget, []). 58 | ok 59 | 7> portserver:call(ocaml, get, []). 60 | {error,no_value} 61 | 8> portserver:ping(ocaml). 62 | pong 63 | 9> 64 | 65 | -------------------------------------------------------------------------------- /erlterm_tests/bar.et: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/EchoTeam/ocaml-erlang-port/5b4d7f073a2525d5f9f6c44af634a5db14088313/erlterm_tests/bar.et -------------------------------------------------------------------------------- /erlterm_tests/bignum.et: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/EchoTeam/ocaml-erlang-port/5b4d7f073a2525d5f9f6c44af634a5db14088313/erlterm_tests/bignum.et -------------------------------------------------------------------------------- /erlterm_tests/bignum2.et: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/EchoTeam/ocaml-erlang-port/5b4d7f073a2525d5f9f6c44af634a5db14088313/erlterm_tests/bignum2.et -------------------------------------------------------------------------------- /erlterm_tests/bignum3.et: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/EchoTeam/ocaml-erlang-port/5b4d7f073a2525d5f9f6c44af634a5db14088313/erlterm_tests/bignum3.et -------------------------------------------------------------------------------- /erlterm_tests/bits.et: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/EchoTeam/ocaml-erlang-port/5b4d7f073a2525d5f9f6c44af634a5db14088313/erlterm_tests/bits.et -------------------------------------------------------------------------------- /erlterm_tests/float-1.2.et: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/EchoTeam/ocaml-erlang-port/5b4d7f073a2525d5f9f6c44af634a5db14088313/erlterm_tests/float-1.2.et -------------------------------------------------------------------------------- /erlterm_tests/float0.et: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/EchoTeam/ocaml-erlang-port/5b4d7f073a2525d5f9f6c44af634a5db14088313/erlterm_tests/float0.et -------------------------------------------------------------------------------- /erlterm_tests/float1.2.et: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/EchoTeam/ocaml-erlang-port/5b4d7f073a2525d5f9f6c44af634a5db14088313/erlterm_tests/float1.2.et -------------------------------------------------------------------------------- /erlterm_tests/foo.et: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/EchoTeam/ocaml-erlang-port/5b4d7f073a2525d5f9f6c44af634a5db14088313/erlterm_tests/foo.et -------------------------------------------------------------------------------- /erlterm_tests/fun.et: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/EchoTeam/ocaml-erlang-port/5b4d7f073a2525d5f9f6c44af634a5db14088313/erlterm_tests/fun.et -------------------------------------------------------------------------------- /erlterm_tests/out.et: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/EchoTeam/ocaml-erlang-port/5b4d7f073a2525d5f9f6c44af634a5db14088313/erlterm_tests/out.et -------------------------------------------------------------------------------- /erlterm_tests/ref1.et: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/EchoTeam/ocaml-erlang-port/5b4d7f073a2525d5f9f6c44af634a5db14088313/erlterm_tests/ref1.et -------------------------------------------------------------------------------- /erlterm_tests/ref2.et: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/EchoTeam/ocaml-erlang-port/5b4d7f073a2525d5f9f6c44af634a5db14088313/erlterm_tests/ref2.et -------------------------------------------------------------------------------- /erlterm_tests/ref3.et: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/EchoTeam/ocaml-erlang-port/5b4d7f073a2525d5f9f6c44af634a5db14088313/erlterm_tests/ref3.et -------------------------------------------------------------------------------- /ocaml-erlang-port/ErlangPort.ml: -------------------------------------------------------------------------------- 1 | 2 | open ErlangTerm 3 | 4 | (* A temporary read/write buffer, used internally *) 5 | let ep_tmp_buffer = Buffer.create 256000;; 6 | 7 | (* Shrink buffer if it is deemed too large *) 8 | let ep_maybe_shrink_buffer () = 9 | if Buffer.length ep_tmp_buffer > 10200300 10 | then Buffer.reset ep_tmp_buffer;; 11 | 12 | (* Get an Erlang term from the port channel *) 13 | let erlang_port_read in_channel = 14 | let len = try input_binary_int in_channel with 15 | End_of_file -> exit 0 (* Closing port *) 16 | in 17 | let b = ep_tmp_buffer in 18 | Buffer.clear b; 19 | Buffer.add_channel b in_channel len; 20 | (* Could have used \textsl{binary\_to\_term\_in} here, 21 | * but can not be 100% sure the frame length 22 | * precisely matches framed content length. *) 23 | let term = binary_to_term_buf b in 24 | ep_maybe_shrink_buffer (); 25 | term;; 26 | 27 | (* Serialize the given term into the port channel *) 28 | let erlang_port_write out_channel term = 29 | let b = ep_tmp_buffer in 30 | Buffer.clear b; 31 | term_to_binary_buf b term; 32 | (* Spewing out 4-byte BE prefix to satisfy {packet, 4} flag in Erlang *) 33 | output_binary_int out_channel (Buffer.length b); 34 | Buffer.output_buffer out_channel b; 35 | flush stdout; 36 | ep_maybe_shrink_buffer () 37 | ;; 38 | 39 | 40 | (* Get Erlang Terms on stdin, invoke the specified functions 41 | * and send back the produced Erlang terms. This function never returns. *) 42 | let erlang_port_interact_with_key (f : 'a -> erlang_term -> 'a * erlang_term) key0 = 43 | set_binary_mode_in stdin true; 44 | set_binary_mode_out stdout true; 45 | let transform key = function 46 | | ET_Atom "stop" -> exit 0 47 | | ET_Atom "ping" -> key, ET_Atom "pong" 48 | | term -> 49 | (* Return {error, {OriginalTerm, exception, string()}} *) 50 | try f key term with exn -> key, ET_Tuple [ 51 | ET_Atom "error"; 52 | ET_Tuple [ 53 | term; 54 | ET_Atom "exception"; 55 | ET_String (Printexc.to_string exn) 56 | ] 57 | ] 58 | in 59 | let rec interact key = 60 | let term = erlang_port_read stdin in 61 | let updatedkey, replyterm = transform key term in 62 | erlang_port_write stdout replyterm; 63 | interact updatedkey in 64 | interact key0;; 65 | 66 | (* Simpler form of erlang_port_interact_with_key, not threading the key *) 67 | let erlang_port_interact (f : erlang_term -> erlang_term) = 68 | erlang_port_interact_with_key (fun a t -> a, f t) 0;; 69 | 70 | let list_of_term = function 71 | | ET_List l -> l 72 | | _ -> raise (Invalid_argument "Not ET_List") ;; 73 | 74 | let tuple_of_term = function 75 | | ET_Tuple l -> l 76 | | _ -> raise (Invalid_argument "Not ET_Tuple") ;; 77 | 78 | let buffer_of_term = function 79 | | ET_Binary b -> b 80 | | _ -> raise (Invalid_argument "Not ET_Binary") ;; 81 | 82 | let string_of_term = function 83 | | ET_Atom s -> s 84 | | ET_String s -> s 85 | | ET_Binary b -> Buffer.contents b 86 | | ET_List [] -> "" 87 | | ET_Int i -> string_of_int i 88 | | _ -> raise (Invalid_argument "Not ET_Atom|ET_String|ET_Binary|ET_Int") ;; 89 | 90 | (* Convert an Erlang list of terms into (string, erlang_term) pairs *) 91 | let erlang_port_proplist term = 92 | let et_tuple_to_pair term acc = try match term with 93 | | ET_Tuple [k; v] -> (string_of_term k, v) :: acc 94 | | ET_Atom a -> (a, ET_Atom "true") :: acc 95 | | ET_String s -> (s, ET_Atom "true") :: acc 96 | | _ -> raise (Invalid_argument "Invalid property") 97 | with Invalid_argument _ -> acc in 98 | List.fold_right et_tuple_to_pair (list_of_term term) [];; 99 | 100 | (* Convert an Erlang property list into (string, string) pairs *) 101 | let erlang_port_kvpairs_of_proplist proplist = 102 | let stringify_value (s, e) acc = try (s, string_of_term e) :: acc 103 | with Invalid_argument _ -> acc in 104 | List.fold_right stringify_value proplist [];; 105 | 106 | (* Convert an OCaml key-value list into a proplist *) 107 | let proplist_of_string_kvpairs : (string * string) list -> erlang_term = 108 | let f (k, v) = ET_Tuple [ET_Atom k; ET_String v] in 109 | function list -> ET_List (List.map f list);; 110 | 111 | (* Convert an OCaml key-value list into a proplist *) 112 | let proplist_of_int_kvpairs : (string * int) list -> erlang_term = 113 | let f (k, v) = ET_Tuple [ET_Atom k; ET_Int v] in 114 | function list -> ET_List (List.map f list);; 115 | 116 | let proplist_of : (string * erlang_term) list -> erlang_term = 117 | let f (k, v) = ET_Tuple [ET_Atom k; v] in 118 | function list -> ET_List (List.map f list);; 119 | 120 | let proplists_concat : erlang_term list -> erlang_term = 121 | function list -> ET_List (List.flatten (List.map list_of_term list));; 122 | 123 | let proplist_of_labeled_string_list : (string * (string list)) -> erlang_term = 124 | function (a, l) -> ET_List [ET_Tuple [ET_Atom a; 125 | ET_List (List.map (fun e -> ET_String e) l) 126 | ]];; 127 | -------------------------------------------------------------------------------- /ocaml-erlang-port/ErlangPort.mli: -------------------------------------------------------------------------------- 1 | val erlang_port_read : in_channel -> ErlangTerm.erlang_term 2 | val erlang_port_write : out_channel -> ErlangTerm.erlang_term -> unit 3 | val erlang_port_interact : 4 | (ErlangTerm.erlang_term -> ErlangTerm.erlang_term) -> unit 5 | val erlang_port_interact_with_key : 6 | ('a -> ErlangTerm.erlang_term -> ('a * ErlangTerm.erlang_term)) -> 'a -> unit 7 | 8 | val list_of_term : ErlangTerm.erlang_term -> ErlangTerm.erlang_term list 9 | val tuple_of_term : ErlangTerm.erlang_term -> ErlangTerm.erlang_term list 10 | val buffer_of_term : ErlangTerm.erlang_term -> Buffer.t 11 | val string_of_term : ErlangTerm.erlang_term -> string 12 | val erlang_port_proplist : 13 | ErlangTerm.erlang_term -> (string * ErlangTerm.erlang_term) list 14 | val erlang_port_kvpairs_of_proplist : 15 | ('a * ErlangTerm.erlang_term) list -> ('a * string) list 16 | val proplist_of_string_kvpairs : 17 | (string * string) list -> ErlangTerm.erlang_term 18 | val proplist_of_int_kvpairs : (string * int) list -> ErlangTerm.erlang_term 19 | val proplist_of : 20 | (string * ErlangTerm.erlang_term) list -> ErlangTerm.erlang_term 21 | val proplists_concat : ErlangTerm.erlang_term list -> ErlangTerm.erlang_term 22 | val proplist_of_labeled_string_list : 23 | string * string list -> ErlangTerm.erlang_term 24 | -------------------------------------------------------------------------------- /ocaml-erlang-port/ErlangTerm.ml: -------------------------------------------------------------------------------- 1 | open Buffer 2 | open Num 3 | 4 | (* The erlang_term type describes what we exchange with an Erlang node. *) 5 | type erlang_term = ET_Int of int 6 | | ET_Atom of string 7 | | ET_String of string (* NOTE: string can also come as ET_List! *) 8 | | ET_List of erlang_term list 9 | | ET_Tuple of erlang_term list 10 | | ET_Float of float 11 | | ET_Binary of Buffer.t 12 | | ET_BitBinary of Buffer.t * int 13 | | ET_Bignum of num 14 | | ET_PID_EXT of string * int * int * int 15 | | ET_PORT_EXT of string * int * int 16 | | ET_EXPORT_EXT of string * string * int 17 | | ET_REFERENCE_EXT of string * int * int 18 | | ET_NEW_REFERENCE_EXT of string * int * (int list) 19 | | ET_FUN_EXT of fun_ext 20 | | ET_NEW_FUN_EXT of new_fun_ext 21 | and fun_ext = { 22 | fe_pid: erlang_term; 23 | fe_module: string; 24 | fe_index: int; 25 | fe_uniq: int; 26 | fe_freeVars: erlang_term list 27 | } 28 | and new_fun_ext = { 29 | nf_arity: int; 30 | nf_uniq: string; 31 | nf_index: int; 32 | nf_numFree: int; 33 | nf_module: string; 34 | nf_oldIndex: int; 35 | nf_oldUniq: int; 36 | nf_rest: string 37 | };; 38 | 39 | (* Print values of the list interspersed with a given function. *) 40 | let rec interleave inBetween print = function 41 | | h :: [] -> print h 42 | | h :: t -> print h; inBetween (); interleave inBetween print t 43 | | [] -> () 44 | ;; 45 | 46 | let atom_escape = function 47 | | "" -> "''" 48 | | s -> 49 | let b = Buffer.create 64 in 50 | let esc = function 51 | | '\n' -> add_string b "\\n" 52 | | '\r' -> add_string b "\\r" 53 | | '\t' -> add_string b "\\t" 54 | | '\\' -> add_string b "\\\\" 55 | | '\'' -> add_string b "\\\'" 56 | | c -> add_char b c 57 | in 58 | Buffer.add_char b '\''; 59 | String.iter esc s; 60 | if s = Buffer.sub b 1 (Buffer.length b - 1) 61 | then s 62 | else let _ = Buffer.add_char b '\'' in Buffer.contents b 63 | ;; 64 | 65 | (* Output Erlang term in a human readable format *) 66 | let rec erlang_term_format astr abuf = 67 | let recurse x = erlang_term_format astr abuf x in 68 | let comma () = astr "," in 69 | function 70 | | ET_Int n -> astr (string_of_int n) 71 | | ET_Atom s -> astr (atom_escape s) 72 | | ET_String s -> astr "\""; astr (String.escaped s); astr "\"" 73 | | ET_List l -> astr "["; interleave comma recurse l; astr "]" 74 | | ET_Tuple l -> astr "{"; interleave comma recurse l; astr "}" 75 | | ET_Float f -> astr (string_of_float f) 76 | | ET_Binary bin -> astr "<<\""; abuf bin; astr "\">>" (* TODO: escaping *) 77 | | ET_BitBinary (bin, bits) -> 78 | astr "<<\""; abuf bin; astr ("\":"^ string_of_int bits ^">>") (* TODO: escaping *) 79 | | ET_Bignum num -> astr (string_of_num num) 80 | | ET_EXPORT_EXT (m, f, arity) -> 81 | List.iter astr ["#Fun<"; atom_escape m; "."; atom_escape f; "."; string_of_int arity; ">"] 82 | | ET_PID_EXT (node, id, serial, creation) -> 83 | astr "<["; 84 | astr node; 85 | astr "]:"; 86 | interleave (fun() -> astr ".") astr (List.map string_of_int [id; serial; creation]); 87 | astr ">" 88 | | ET_PORT_EXT (node, id, creation) -> 89 | astr "#Port<["; 90 | astr (atom_escape node); 91 | astr "]:"; 92 | interleave (fun() -> astr ".") astr (List.map string_of_int [creation; id]); 93 | astr ">" 94 | | ET_REFERENCE_EXT (node, id, creation) -> 95 | astr "#Ref<["; 96 | astr (atom_escape node); 97 | astr "]:"; 98 | interleave (fun() -> astr ".") astr (List.map string_of_int [creation; id]); 99 | astr ">" 100 | | ET_NEW_REFERENCE_EXT (node, creation, ids) -> 101 | astr "#Ref<["; 102 | astr (atom_escape node); 103 | astr "]:"; 104 | interleave (fun() -> astr ".") astr (string_of_int creation :: List.rev (List.map string_of_int ids)); 105 | astr ">" 106 | | ET_FUN_EXT r -> 107 | astr "#Fun<"; 108 | astr (atom_escape r.fe_module); 109 | astr "."; 110 | astr (string_of_int r.fe_index); 111 | astr "."; 112 | astr (string_of_int r.fe_uniq); 113 | astr ">"; 114 | | ET_NEW_FUN_EXT r -> 115 | astr "#Fun<"; 116 | astr (atom_escape r.nf_module); 117 | astr "."; 118 | astr (string_of_int r.nf_oldIndex); 119 | astr "."; 120 | astr (string_of_int r.nf_oldUniq); 121 | astr ">" 122 | ;; 123 | 124 | let rec read_bignum ibyte = function 125 | | 0 -> num_of_int 0 126 | | n -> let b = ibyte () in 127 | let rest = mult_num (num_of_int 256) 128 | (read_bignum ibyte (n - 1)) in 129 | add_num (num_of_int b) rest 130 | ;; 131 | 132 | (* Low level term reader. Use \textsl{binary\_to\_term} instead. *) 133 | let rec erlang_term_decode ibyte iint istr ibuf () = 134 | let decode_term = erlang_term_decode ibyte iint istr ibuf in 135 | let rec list_of f = function 136 | | n when n > 0 -> let el = f () in el :: list_of f (n - 1) 137 | | 0 -> [] 138 | | _ -> failwith "Negative list size" in 139 | match ibyte () with 140 | (* 8.2 SMALL_INTEGER_EXT *) 141 | | 97 -> ET_Int (ibyte ()) 142 | (* 8.3 INTEGER_EXT *) 143 | | 98 -> ET_Int (iint ()) 144 | (* 8.4 FLOAT_EXT *) 145 | | 99 -> 146 | let s' = istr 31 in 147 | let zeros = String.index s' (char_of_int 0) in 148 | let s = String.sub s' 0 zeros in 149 | ET_Float (float_of_string s) 150 | (* 8.5 ATOM_EXT, 8.12 STRING_EXT *) 151 | | (100 | 107) as c -> 152 | let len2 = ibyte () in 153 | let len1 = ibyte () in 154 | let len = 256 * len2 + len1 in 155 | let s = istr len in 156 | if c == 100 then ET_Atom s else ET_String s 157 | ; ; 158 | (* 8.6 REFERENCE_EXT *) 159 | | 101 -> 160 | let node = decode_term () in 161 | let id = iint () in 162 | let creation = ibyte () in 163 | let node' = match node with 164 | ET_Atom s -> s 165 | | _ -> failwith "Unexpected REFERENCE_EXT format" in 166 | ET_REFERENCE_EXT (node', id, creation) 167 | (* 8.7 PORT_EXT *) 168 | | 102 -> 169 | let node = decode_term () in 170 | let id = iint () in 171 | let creation = ibyte () in 172 | let node' = match node with 173 | ET_Atom s -> s 174 | | _ -> failwith "Unexpected PORT_EXT format" in 175 | ET_PORT_EXT (node', id, creation) 176 | (* 8.8 PID_EXT *) 177 | | 103 -> 178 | let node = decode_term () in 179 | let id = iint () in 180 | let serial = iint () in 181 | let creation = ibyte () in 182 | let node' = match node with 183 | ET_Atom s -> s 184 | | _ -> failwith "Unexpected PID_EXT format" in 185 | ET_PID_EXT (node', id, serial, creation) 186 | (* 8.9 SMALL_TUPLE_EXT *) 187 | | 104 -> let arity = ibyte () in ET_Tuple (list_of decode_term arity) 188 | (* 8.10 LARGE_TUPLE_EXT *) 189 | | 105 -> let arity = iint () in ET_Tuple (list_of decode_term arity) 190 | (* 8.11 NIL_EXT *) 191 | | 106 -> ET_List [] 192 | (* 8.13 LIST_EXT *) 193 | | 108 -> let len = iint () in 194 | let term = ET_List (list_of decode_term len) in 195 | match ibyte () with 196 | 106 -> term 197 | | _ -> failwith "Improper list received" 198 | ; ; 199 | (* 8.14 BINARY_EXT *) 200 | | 109 -> let len = iint () in ET_Binary (ibuf len) 201 | (* 8.15 SMALL_BIG_EXT *) 202 | | 110 -> 203 | let n = ibyte () in 204 | let sign = ibyte () in 205 | let num = read_bignum ibyte n in 206 | ET_Bignum (if sign > 0 then minus_num num else num) 207 | (* 8.16 LARGE_BIG_EXT *) 208 | | 111 -> 209 | let n = iint () in 210 | let sign = ibyte () in 211 | let num = read_bignum ibyte n in 212 | ET_Bignum (if sign > 0 then minus_num num else num) 213 | (* 8.19 NEW_REFERENCE_EXT *) 214 | | 114 -> 215 | let len2 = ibyte () in 216 | let len1 = ibyte () in 217 | let len = 256 * len2 + len1 in 218 | let node = decode_term () in 219 | let creation = ibyte () in 220 | let ids = list_of iint len in 221 | let node' = match node with 222 | ET_Atom s -> s 223 | | _ -> failwith "Unexpected NEW_REFERENCE_EXT format" in 224 | ET_NEW_REFERENCE_EXT (node', creation, ids) 225 | (* 8.20 FUN_EXT *) 226 | | 117 -> 227 | let numFree = iint () in 228 | let pid = decode_term () in 229 | let module' = decode_term () in 230 | let index' = decode_term () in 231 | let uniq' = decode_term () in 232 | let freeVars = list_of decode_term numFree in 233 | match (module', index', uniq') with 234 | | (ET_Atom m, ET_Int index, ET_Int uniq) -> 235 | ET_FUN_EXT { fe_pid = pid; fe_module = m; 236 | fe_index = index; fe_uniq = uniq; 237 | fe_freeVars = freeVars } 238 | | _ -> failwith "Invalid FUN_EXT" 239 | ; ; 240 | (* 8.21 NEW_FUN_EXT *) 241 | | 112 -> 242 | let size = iint () in 243 | let arity = ibyte () in 244 | let uniq = istr 16 in 245 | let index = iint () in 246 | let numFree = iint () in 247 | let module' = decode_term () in 248 | let oldIndex' = decode_term () in 249 | let oldUniq' = decode_term () in 250 | let impl_module, oldIndex, oldUniq = 251 | match (module', oldIndex', oldUniq') with 252 | | (ET_Atom m, ET_Int oidx, ET_Int ouniq) -> 253 | (m, oidx, ouniq) 254 | | _ -> failwith "Invalid NEW_FUN_EXT" 255 | in 256 | let sizeBase = 4 + 1 + 16 + 4 + 4 257 | + 3+(String.length impl_module) 258 | + (if oldIndex >= 0 && oldIndex < 256 then 2 else 5) 259 | + (if oldUniq >= 0 && oldUniq < 256 then 2 else 5) 260 | in 261 | let restLen = size - sizeBase in 262 | let rest = istr restLen in 263 | ET_NEW_FUN_EXT { nf_arity = arity; nf_uniq = uniq; 264 | nf_index = index; nf_numFree = numFree; 265 | nf_module = impl_module; 266 | nf_oldIndex = oldIndex; nf_oldUniq = oldUniq; 267 | nf_rest = rest } 268 | (* 8.22 EXPORT_EXT *) 269 | | 113 -> 270 | let m = decode_term () in 271 | let f = decode_term () in 272 | let a = decode_term () in 273 | match (m, f, a) with 274 | (ET_Atom m', ET_Atom f', ET_Int a') -> ET_EXPORT_EXT (m', f', a') 275 | | _ -> failwith "EXPORT_EXT format error" 276 | ; ; 277 | (* 8.23 BIT_BINARY_EXT *) 278 | | 77 -> 279 | let len = iint () in 280 | let bits = ibyte () in 281 | ET_BitBinary (ibuf len, bits) 282 | | n -> failwith ("Unknown term format: " ^ string_of_int n) 283 | ;; 284 | 285 | let rec split_bignum num = 286 | let n256 = num_of_int 256 in 287 | match eq_num num (num_of_int 0) with 288 | true -> [] 289 | | false -> 290 | let q = quo_num num n256 in 291 | let m = mod_num num n256 in 292 | int_of_num m :: split_bignum q 293 | ;; 294 | 295 | let rec erlang_term_encode abyte aint astr abuf term = 296 | let encode_term = erlang_term_encode abyte aint astr abuf in 297 | match term with 298 | | ET_Int n when n >= 0 && n < 256 -> abyte 97; abyte n 299 | | ET_Int n -> abyte 98; aint n 300 | | ET_Atom s -> match String.length s with 301 | | len when len < 256 -> 302 | abyte 100; 303 | abyte 0; 304 | abyte len; 305 | astr s 306 | | _ -> failwith "Length of Atom exceeds limit" 307 | ; ; 308 | | ET_String s -> match String.length s with 309 | | len when len < 65536 -> let a, b = len / 256, len mod 256 in 310 | abyte 107; 311 | abyte a; 312 | abyte b; 313 | astr s 314 | | len -> 315 | abyte 108; 316 | aint len; 317 | String.iter (fun c -> abyte 97; abyte (int_of_char c)) s; 318 | abyte 106 (* NIL_EXT *) 319 | ; ; 320 | | ET_Tuple l -> match List.length l with 321 | | len when len < 256 -> 322 | abyte 104; 323 | abyte len; 324 | List.iter encode_term l 325 | | len -> 326 | abyte 105; 327 | aint len; 328 | List.iter encode_term l 329 | ; ; 330 | | ET_List [] -> abyte 106 331 | | ET_List l -> 332 | abyte 108; 333 | aint (List.length l); 334 | List.iter (encode_term) l; 335 | abyte 106 (* NIL_EXT *) 336 | | ET_Float f -> 337 | let s = Printf.sprintf "%.20e" f in 338 | let pad = String.make (31 - String.length s) (char_of_int 0) in 339 | abyte 99; 340 | astr s; 341 | astr pad 342 | | ET_Binary buf -> 343 | abyte 109; 344 | aint (Buffer.length buf); 345 | abuf buf 346 | | ET_BitBinary (buf, 0) -> encode_term (ET_Binary buf) 347 | | ET_BitBinary (buf, bits) -> 348 | abyte 77; 349 | aint (Buffer.length buf); 350 | abyte bits; 351 | abuf buf 352 | | ET_Bignum num -> 353 | let sign = match sign_num num with -1 -> 1 | _ -> 0 in 354 | let ds = split_bignum (abs_num num) in 355 | match List.length ds with 356 | len when len < 256 -> 357 | abyte 110; 358 | abyte len; 359 | abyte sign; 360 | List.iter (abyte) ds 361 | | len -> 362 | abyte 111; 363 | aint len; 364 | abyte sign; 365 | List.iter (abyte) ds 366 | ; ; 367 | | ET_REFERENCE_EXT (node, id, creation) -> 368 | abyte 101; 369 | encode_term (ET_Atom node); 370 | aint id; 371 | abyte creation 372 | | ET_PORT_EXT (node, id, creation) -> 373 | abyte 102; 374 | encode_term (ET_Atom node); 375 | aint id; 376 | abyte creation 377 | | ET_PID_EXT (node, id, serial, creation) -> 378 | abyte 103; 379 | encode_term (ET_Atom node); 380 | aint id; 381 | aint serial; 382 | abyte creation 383 | | ET_NEW_REFERENCE_EXT (node, creation, ids) -> 384 | let idlen = List.length ids in 385 | let a, b = idlen / 256, idlen mod 256 in 386 | abyte 114; 387 | abyte a; 388 | abyte b; 389 | encode_term (ET_Atom node); 390 | abyte creation; 391 | List.iter (aint) ids 392 | | ET_EXPORT_EXT (m,f,a) -> 393 | abyte 113; 394 | encode_term (ET_Atom m); 395 | encode_term (ET_Atom f); 396 | encode_term (ET_Int a) 397 | | ET_FUN_EXT r -> 398 | abyte 117; 399 | aint (List.length r.fe_freeVars); 400 | encode_term r.fe_pid; 401 | encode_term (ET_Atom r.fe_module); 402 | encode_term (ET_Int r.fe_index); 403 | encode_term (ET_Int r.fe_uniq); 404 | List.iter encode_term r.fe_freeVars 405 | | ET_NEW_FUN_EXT r -> 406 | let size = 4 + 1 + 16 + 4 + 4 407 | + 3 + (String.length r.nf_module) 408 | + (if r.nf_oldIndex >= 0 && r.nf_oldIndex < 256 then 2 else 5) 409 | + (if r.nf_oldUniq >= 0 && r.nf_oldUniq < 256 then 2 else 5) 410 | + (String.length r.nf_rest) 411 | in 412 | abyte 112; 413 | aint size; 414 | abyte r.nf_arity; 415 | astr r.nf_uniq; 416 | aint r.nf_index; 417 | aint r.nf_numFree; 418 | encode_term (ET_Atom r.nf_module); 419 | encode_term (ET_Int r.nf_oldIndex); 420 | encode_term (ET_Int r.nf_oldUniq); 421 | astr r.nf_rest 422 | ;; 423 | 424 | 425 | (* Specify \textit{erlang\_term\_format} to print Erlang term on the screen *) 426 | let print_erlang_term term = 427 | let astr = print_string in 428 | let abuf = Buffer.output_buffer stdout in 429 | erlang_term_format astr abuf term;; 430 | 431 | (* Specify \textit{erlang\_term\_format} to form a Buffer out of Erlang term *) 432 | let buffer_of_erlang_term term = 433 | let buf = Buffer.create 1024 in 434 | let astr = Buffer.add_string buf in 435 | let abuf = Buffer.add_buffer buf in 436 | erlang_term_format astr abuf term; 437 | buf;; 438 | 439 | (* Convert Erlang term into a human readable string *) 440 | let string_of_erlang_term term = Buffer.contents (buffer_of_erlang_term term);; 441 | 442 | (* Get a single Erlang term from a given input channel *) 443 | let binary_to_term_in in_channel = 444 | let ibyte () = input_byte in_channel in 445 | let iint () = input_binary_int in_channel in 446 | let istr len = let s = String.create len in 447 | really_input in_channel s 0 len; 448 | s in 449 | let ibuf len = let b = Buffer.create len in 450 | Buffer.add_channel b in_channel len; 451 | b in 452 | match ibyte () with 453 | 131 -> erlang_term_decode ibyte iint istr ibuf () 454 | | _ -> failwith "Erlang binary does not start with 131" 455 | ;; 456 | 457 | (* Get all individually serialized terms from the channel, 458 | * ignoring the errors and exceptions. *) 459 | let rec binaries_to_terms_in in_channel = 460 | try 461 | let term = binary_to_term_in in_channel in 462 | term :: binaries_to_terms_in in_channel 463 | with _ -> [];; 464 | 465 | (* Get an Erlang term from a given buffer, using an offset. 466 | * Not quite a functional interface since it takes a reference to the offset, 467 | * and definitely moves it if it has to throw an exception (not a good style 468 | * of interface programming!) ... but it can be abstracted out by the user 469 | * if needed. The reverse is harder: making an interface which allows 470 | * to determine where exactly in the buffer a problem has occurred is not 471 | * possible without devising a new custom exception type. 472 | *) 473 | let binary_to_term_buf2 off buf = 474 | let ibyte () = let byte = int_of_char (Buffer.nth buf !off) in 475 | incr off; 476 | byte in 477 | let iint () = Int32.( 478 | to_int ( 479 | List.fold_left (fun a e -> add a (shift_left (of_int (ibyte ())) e)) 480 | zero [24; 16; 8; 0] 481 | ) 482 | ) in 483 | let istr len = let s = Buffer.sub buf !off len in 484 | off := !off + len; 485 | s in 486 | let ibuf len = let b = Buffer.create len in 487 | let s = istr len in 488 | Buffer.add_string b s; 489 | b in 490 | match ibyte () with 491 | 131 -> erlang_term_decode ibyte iint istr ibuf () 492 | | _ -> 493 | output_string stderr (string_of_int !off); 494 | String.iter (fun x -> output_string stderr "\n"; output_string stderr (string_of_int (int_of_char x))) (Buffer.contents buf); 495 | flush stderr; 496 | failwith "Erlang binary does not start with 131" 497 | ;; 498 | 499 | (* Get a single Erlang term from a given buffer *) 500 | let binary_to_term_buf buf = binary_to_term_buf2 (ref 0) buf;; 501 | 502 | (* Get all individually serialized terms from the buffer, 503 | * ignoring the errors and exceptions. *) 504 | let binaries_to_terms_buf = 505 | let off = ref 0 in 506 | let rec b2t buf = try 507 | let term = binary_to_term_buf2 off buf in 508 | term :: b2t buf 509 | with _ -> [] in 510 | b2t;; 511 | 512 | (* Serialize an Erlang term into a given channel *) 513 | let term_to_binary_out out_channel term = 514 | let abyte = output_byte out_channel in 515 | let aint = output_binary_int out_channel in 516 | let astr s = output out_channel s 0 (String.length s) in 517 | let abuf = Buffer.output_buffer out_channel in 518 | abyte 131; 519 | erlang_term_encode abyte aint astr abuf term;; 520 | 521 | (* Serialize an Erlang term and return a Buffer *) 522 | let term_to_binary_buf buffer term = 523 | let abyte x = Buffer.add_char buffer (char_of_int x) in 524 | let aint x = 525 | let x32 = Int32.of_int x in 526 | List.iter (fun n -> 527 | abyte Int32.(to_int (logand (shift_right_logical x32 n) 0xFFl)) 528 | ) [24; 16; 8; 0] in 529 | let astr = Buffer.add_string buffer in 530 | let abuf = Buffer.add_buffer buffer in 531 | abyte 131; 532 | erlang_term_encode abyte aint astr abuf term;; 533 | 534 | let term_to_binary_bufs term = 535 | let aref = ref [] in 536 | let new_buffer size = Buffer.create size in 537 | let current_size = ref (10000) in 538 | let buffer = ref (new_buffer !current_size) in 539 | let wrapper f x = 540 | let wr f0 x0 = 541 | aref := !buffer :: !aref; 542 | if !current_size < 246000 then 543 | current_size := !current_size * 2; 544 | buffer := new_buffer !current_size; 545 | f !buffer x 546 | in 547 | if (Buffer.length !buffer + 1000 > !current_size) then 548 | wr f x 549 | else 550 | try f !buffer x with _ -> wr f x 551 | in 552 | let abyte x = wrapper Buffer.add_char (char_of_int x) in 553 | let aint x = 554 | let x32 = Int32.of_int x in 555 | List.iter (fun n -> 556 | abyte Int32.(to_int (logand (shift_right_logical x32 n) 0xFFl)) 557 | ) [24; 16; 8; 0] in 558 | let astr = wrapper Buffer.add_string in 559 | let abuf = wrapper Buffer.add_buffer in 560 | abyte 131; 561 | erlang_term_encode abyte aint astr abuf term; 562 | List.rev (!buffer :: !aref);; 563 | 564 | (* Return a fresh Buffer containing the serialized Erlang term *) 565 | let term_to_binary term = 566 | let b = Buffer.create 1024 in 567 | let () = term_to_binary_buf b term in 568 | b;; 569 | 570 | exception ExceptionTerm of erlang_term 571 | 572 | -------------------------------------------------------------------------------- /ocaml-erlang-port/ErlangTerm.mli: -------------------------------------------------------------------------------- 1 | (** Encoding and encoding of Erlang terms. 2 | 3 | This module defines functions for encoding and decoding Erlang 4 | terms as described in Erlang External Term format. See link below 5 | for details: http://erlang.org/doc/apps/erts/erl_ext_dist.html. 6 | 7 | Not implemented: 8 | 9 | - NEW_FLOAT_EXT (generated by term_to_binary/2 with [{minor_version, 1}]) 10 | - NEW_CACHE, CACHED_ATOM (used between Erlang nodes only) 11 | *) 12 | 13 | (** A single Erlang term. *) 14 | type erlang_term = 15 | ET_Int of int 16 | | ET_Atom of string 17 | | ET_String of string 18 | | ET_List of erlang_term list 19 | | ET_Tuple of erlang_term list 20 | | ET_Float of float 21 | | ET_Binary of Buffer.t 22 | | ET_BitBinary of Buffer.t * int 23 | | ET_Bignum of Num.num 24 | | ET_PID_EXT of string * int * int * int 25 | | ET_PORT_EXT of string * int * int 26 | | ET_EXPORT_EXT of string * string * int 27 | | ET_REFERENCE_EXT of string * int * int 28 | | ET_NEW_REFERENCE_EXT of string * int * int list 29 | | ET_FUN_EXT of fun_ext 30 | | ET_NEW_FUN_EXT of new_fun_ext 31 | and fun_ext = { 32 | fe_pid : erlang_term; 33 | fe_module : string; 34 | fe_index : int; 35 | fe_uniq : int; 36 | fe_freeVars : erlang_term list; 37 | } 38 | and new_fun_ext = { 39 | nf_arity : int; 40 | nf_uniq : string; 41 | nf_index : int; 42 | nf_numFree : int; 43 | nf_module : string; 44 | nf_oldIndex : int; 45 | nf_oldUniq : int; 46 | nf_rest : string; 47 | } 48 | val print_erlang_term : erlang_term -> unit 49 | val buffer_of_erlang_term : erlang_term -> Buffer.t 50 | val string_of_erlang_term : erlang_term -> string 51 | val binary_to_term_in : in_channel -> erlang_term 52 | val binaries_to_terms_in : in_channel -> erlang_term list 53 | val binary_to_term_buf : Buffer.t -> erlang_term 54 | val binaries_to_terms_buf : Buffer.t -> erlang_term list 55 | val term_to_binary_out : out_channel -> erlang_term -> unit 56 | val term_to_binary_buf : Buffer.t -> erlang_term -> unit 57 | val term_to_binary_bufs : erlang_term -> Buffer.t list 58 | val term_to_binary : erlang_term -> Buffer.t 59 | exception ExceptionTerm of erlang_term 60 | -------------------------------------------------------------------------------- /ocaml-erlang-port/ErlangTerm_Check.ml: -------------------------------------------------------------------------------- 1 | 2 | open ErlangTerm 3 | 4 | let someBuf = let b = Buffer.create 4 in 5 | let () = Buffer.add_string b "test" in 6 | b;; 7 | 8 | let complexTerm = ET_List [ 9 | ET_List [] 10 | ; ET_Tuple [] 11 | ; ET_Tuple [ET_Int 0] 12 | ; ET_Tuple [ET_Int (-1); ET_Int 1000000000] 13 | ; ET_List [ET_Int (-1000000000)] 14 | ; ET_List [ET_Atom ""; ET_Atom "f'o\"o"] 15 | ; ET_Tuple [ET_String ""; ET_String "f'o\"o"] 16 | ; ET_Bignum (Num.num_of_string "0") 17 | ; ET_Binary someBuf 18 | ; ET_BitBinary (someBuf, 7) 19 | ; ET_PID_EXT ("foo", 1, 0, 1) 20 | ; ET_PID_EXT ("", 0, 1, 0) 21 | ; ET_PORT_EXT ("some", 1, 0) 22 | ; ET_PORT_EXT ("", 0, 1) 23 | ; ET_EXPORT_EXT ("module", "fun", 1) 24 | ; ET_REFERENCE_EXT ("", 0, 1) 25 | ; ET_REFERENCE_EXT ("bar", 1, 0) 26 | ; ET_FUN_EXT { 27 | fe_pid = ET_PID_EXT ("", 0, 0, 0); 28 | fe_module = ""; 29 | fe_index = 256; 30 | fe_uniq = 3984; 31 | fe_freeVars = [] 32 | } 33 | ; ET_FUN_EXT { 34 | fe_pid = ET_PID_EXT ("smth", 0, 0, 1); 35 | fe_module = "mod"; 36 | fe_index = 256; 37 | fe_uniq = 3984; 38 | fe_freeVars = [ET_List []; ET_Tuple []] 39 | } 40 | ; ET_NEW_FUN_EXT { 41 | nf_arity = 5; 42 | nf_uniq = "0123456789abcdef"; 43 | nf_index = 123; 44 | nf_numFree = 2; 45 | nf_module = "some_module"; 46 | nf_oldIndex = 35; 47 | nf_oldUniq = 12312; 48 | nf_rest = "" 49 | } 50 | ];; 51 | 52 | (* 53 | * Bignum check is separate because bignum is not responding well to the generic 54 | * comparison function (=). It throws. Therefore, we check Bignum using 55 | * Num's own equality function \textsl{eq\_num}. 56 | *) 57 | let bignum_check_positive () = 58 | let num = Num.num_of_string "5000000000000000000" in 59 | let bignum = ET_Bignum num in 60 | match binary_to_term_buf (term_to_binary bignum) with 61 | ET_Bignum n when Num.eq_num n num -> () 62 | | _ -> failwith "Bignum test failed" 63 | ;; 64 | (* Bignum check again, now with negative number *) 65 | let bignum_check_negative () = 66 | let num = Num.num_of_string "-7000000000000000000" in 67 | let bignum = ET_Bignum num in 68 | match binary_to_term_buf (term_to_binary bignum) with 69 | ET_Bignum n when Num.eq_num n num -> () 70 | | _ -> failwith "Bignum test failed" 71 | ;; 72 | 73 | let bigbuffer_check () = 74 | let a = ref [] in 75 | for v = 1 to 100000 do 76 | a := complexTerm :: !a 77 | done; 78 | ET_List !a;; 79 | 80 | (* Check that the given Erlang term passes the round-trip encode/decode test *) 81 | let check_round_trip op term = 82 | let rewrittenTerm = binary_to_term_buf (term_to_binary term) in 83 | if op rewrittenTerm term then () else 84 | let _ = print_string "Failed to compare terms: " in 85 | let _ = print_erlang_term term in 86 | let _ = print_string " => " in 87 | let _ = print_erlang_term rewrittenTerm in 88 | let _ = print_string "\n" in 89 | failwith "Term mismatch";; 90 | 91 | (* Check that the contents given file passess round-trip encode/decode test *) 92 | let check_round_trip_file filename = 93 | let ch = open_in filename in 94 | let term = binary_to_term_in ch in 95 | let cmp = match term with 96 | ET_Bignum _ -> 97 | fun a b -> let cmp stuff = match stuff with 98 | (ET_Bignum n, ET_Bignum n') -> Num.eq_num n n' 99 | | _ -> false 100 | in cmp (a, b) 101 | | _ -> (=) in 102 | print_erlang_term term; 103 | print_newline (); 104 | check_round_trip cmp term;; 105 | 106 | let try_check_round_trip_file filename = 107 | try check_round_trip_file filename with exc -> 108 | print_string ("While evaluating \"" 109 | ^ String.escaped filename ^ "\":\n"); 110 | raise exc 111 | ;; 112 | 113 | let selfcheck () = 114 | bignum_check_positive (); 115 | bignum_check_negative (); 116 | print_string "Checking 50k string\n"; 117 | check_round_trip (=) (ET_String (String.make 55000 '.')); 118 | print_string "Checking 65k-1 string\n"; 119 | check_round_trip (=) (ET_String (String.make 65535 '.')); 120 | print_string "Checking 65k string\n"; 121 | check_round_trip (<>) (ET_String (String.make 65536 '.')); 122 | print_string "Checking 70k string\n"; 123 | check_round_trip (<>) (ET_String (String.make 77000 '.')); 124 | print_erlang_term complexTerm; 125 | print_newline (); 126 | check_round_trip (=) complexTerm; 127 | 128 | ignore(term_to_binary_bufs (bigbuffer_check ())); 129 | 130 | (* do not check it on 64bit system as 131 | * Sys.max_string_length = 144115188075855863 132 | * it's too long to generate assertion 133 | *) 134 | if Sys.word_size == 32 then 135 | let b = Buffer.create 1024 in 136 | try 137 | term_to_binary_buf b (bigbuffer_check ()); 138 | assert(false) 139 | with Failure "Buffer.add: cannot grow buffer" -> (); 140 | 141 | print_string "Selfcheck OK\n";; 142 | 143 | let _ = 144 | match Array.to_list Sys.argv with 145 | | [] | [_] -> selfcheck () 146 | | (_ :: args) -> List.iter try_check_round_trip_file args 147 | ;; 148 | 149 | -------------------------------------------------------------------------------- /ocaml-erlang-port/META: -------------------------------------------------------------------------------- 1 | description = "Parse Erlang External Term Format. Run stuff as Erlang port." 2 | version = "1.0" 3 | archive(byte) = "ocaml-erlang-port.cma" 4 | archive(native) = "ocaml-erlang-port.cmxa" 5 | requires = "num" 6 | -------------------------------------------------------------------------------- /ocaml-erlang-port/Makefile: -------------------------------------------------------------------------------- 1 | # If nothing works, try `ocamlmklib -o $(PACKAGE) *.ml` 2 | 3 | PACKAGE=ocaml-erlang-port 4 | LIBSRCS=ErlangTerm.ml ErlangPort.ml 5 | LIBCMIS=${LIBSRCS:.ml=.cmi} 6 | LIBCMOS=${LIBSRCS:.ml=.cmo} 7 | LIBCMXS=${LIBSRCS:.ml=.cmx} 8 | 9 | LIBS=$(PACKAGE).cma $(PACKAGE).cmxa $(PACKAGE).a lib$(PACKAGE).a 10 | 11 | all: $(LIBCMIS) $(LIBS) 12 | 13 | install: 14 | @echo "Use install-package if you want to do a system-wide install" 15 | 16 | install-package: uninstall $(LIBCMIS) $(LIBS) 17 | ocamlfind install $(PACKAGE) $(LIBS) $(LIBCMIS) META 18 | 19 | uninstall: 20 | ocamlfind remove $(PACKAGE) 21 | 22 | $(PACKAGE).cma: $(LIBCMIS) $(LIBCMOS) 23 | ocamlmklib -o $(PACKAGE) $(LIBCMOS) 24 | 25 | $(PACKAGE).cmxa: $(LIBCMIS) $(LIBCMXS) 26 | ocamlmklib -o $(PACKAGE) $(LIBCMXS) 27 | 28 | lib$(PACKAGE).a: $(LIBCMIS) $(LIBCMXS) 29 | ocamlmklib -o lib$(PACKAGE) $(LIBCMXS) 30 | 31 | check: erlterm_check 32 | @echo "Running embedded self-check" 33 | ./erlterm_check 34 | @echo "Running external tests" 35 | ./erlterm_check ../erlterm_tests/*.et 36 | @echo "make check: OK" 37 | 38 | erlterm_check: $(LIBCMXS) ErlangTerm_Check.cmx 39 | ocamlfind ocamlopt -package num -linkpkg -o erlterm_check $(LIBCMXS) ErlangTerm_Check.cmx 40 | 41 | .SUFFIXES: .ml .mli .cmx .cmo .cmi 42 | 43 | .ml.cmx: 44 | ocamlfind ocamlopt -warn-error A -o $@ -c $< 45 | 46 | .ml.cmo: 47 | ocamlfind ocamlc -warn-error A -o $@ -c $< 48 | 49 | .mli.cmi: 50 | ocamlfind ocamlc -warn-error A -o $@ $< 51 | 52 | clean: 53 | rm -f *.cm* *.[ao] 54 | rm -f erlterm_check 55 | -------------------------------------------------------------------------------- /rebar: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/EchoTeam/ocaml-erlang-port/5b4d7f073a2525d5f9f6c44af634a5db14088313/rebar -------------------------------------------------------------------------------- /rebar.config: -------------------------------------------------------------------------------- 1 | {erl_opts, [no_debug_info, warnings_as_errors]}. 2 | 3 | {deps, [ 4 | {mavg, "1.0.*", {git, "https://github.com/EchoTeam/mavg", {tag, "v1.0.1"}}} 5 | ]}. 6 | 7 | {pre_hooks, [{compile, "make ocaml"}]}. 8 | {post_hooks, [{clean, "make clean-ocaml"}]}. 9 | 10 | -------------------------------------------------------------------------------- /src/ocaml_erlang_port.app.src: -------------------------------------------------------------------------------- 1 | {application, ocaml_erlang_port, 2 | [ 3 | {description, ""}, 4 | {vsn, "1.0.3"}, 5 | {registered, []}, 6 | {applications, []}, 7 | {env, []} 8 | ]}. 9 | -------------------------------------------------------------------------------- /src/portserver.erl: -------------------------------------------------------------------------------- 1 | %%% vim: set ts=4 sts=4 sw=4 et: 2 | 3 | -module(portserver). 4 | 5 | -export([ 6 | start/1, 7 | start/2, 8 | start/3, 9 | start_link/1, 10 | start_link/2, 11 | start_link/3, 12 | stop/1 13 | ]). 14 | 15 | -export([ 16 | code_change/3, 17 | handle_call/3, 18 | init/1, 19 | terminate/2, 20 | handle_info/2, 21 | handle_cast/2 22 | ]). 23 | 24 | -export([ 25 | call/3, 26 | call/4, 27 | status/1, 28 | ping/1 29 | ]). 30 | 31 | -behaviour(gen_server). 32 | 33 | start(PortCommand) -> 34 | gen_server:start(?MODULE, PortCommand, []). 35 | 36 | start_link(PortCommand) -> 37 | gen_server:start_link(?MODULE, PortCommand, []). 38 | 39 | start(ServerName, PortCommand) -> 40 | gen_server:start(ServerName, ?MODULE, PortCommand, []). 41 | 42 | start_link(ServerName, PortCommand) -> 43 | gen_server:start_link(ServerName, ?MODULE, PortCommand, []). 44 | 45 | start(ServerName, PortCommand, Options) -> 46 | gen_server:start(ServerName, ?MODULE, PortCommand, Options). 47 | 48 | start_link(ServerName, PortCommand, Options) -> 49 | gen_server:start_link(ServerName, ?MODULE, PortCommand, Options). 50 | 51 | stop(ServerRef) -> 52 | case gen_server:call(ServerRef, stop) of 53 | ok -> ok; 54 | {error, port_closed} -> ok; 55 | {error, port_closing} = E -> E 56 | end. 57 | 58 | call(ServerRef, Command, Args) -> 59 | gen_server:call(ServerRef, {Command, Args}). 60 | 61 | call(ServerRef, Command, Args, Timeout) -> 62 | gen_server:call(ServerRef, {Command, Args}, Timeout). 63 | 64 | status(ServerRef) -> 65 | gen_server:call(ServerRef, status). 66 | 67 | ping(ServerRef) -> 68 | gen_server:call(ServerRef, ping). 69 | 70 | -define(QUEUE_OVERLOAD_LENGTH, 1000). 71 | -record(state, { status = running, port, q = queue:new(), qlen = 0, portcmd, 72 | overloads = jn_mavg:new_mavg(3600, [{history_length, 48}]) }). 73 | 74 | init(PortCommand) -> 75 | process_flag(trap_exit, true), 76 | P = open_port({spawn, PortCommand}, [{packet, 4}, binary, exit_status]), 77 | {Status, Port} = try port_command(P, term_to_binary(ping)) of 78 | true -> receive 79 | % The port started under ?MODULE must respond to 'ping' events 80 | % with a 'pong' answer at any time. 81 | {P, {data, <<131,100,0,4,"pong">>}} -> {running, P}; 82 | {P, _} -> {start_failure, undefined}; 83 | {'EXIT', P, _} -> {start_failure, undefined} 84 | after 5000 -> throw(start_timeout) 85 | end 86 | catch 87 | error:badarg -> {start_failure, undefined} 88 | end, 89 | process_flag(trap_exit, false), 90 | case Status of 91 | running -> 92 | {ok, #state{status = Status, port = Port, portcmd = PortCommand }}; 93 | start_failure -> 94 | error_logger:error_msg("Failed to start ~p~n", [PortCommand]), 95 | {stop, start_failure} 96 | end. 97 | 98 | % First thing, check out that we are not overloaded. 99 | handle_call(Query, From, #state{status = running, port = Port, 100 | qlen = QLen, portcmd = PortCmd, overloads = Mavg } = State) 101 | when is_tuple(Query), QLen >= ?QUEUE_OVERLOAD_LENGTH -> 102 | NewState = State#state{ overloads = jn_mavg:bump_mavg(Mavg, 1) }, 103 | if 104 | QLen > 2 * ?QUEUE_OVERLOAD_LENGTH -> 105 | {reply, {error, {queue_overload, QLen}}, NewState}; 106 | true -> 107 | port_command(Port, term_to_binary(Query)), 108 | case jn_mavg:history(Mavg) of 109 | {0, _, _} -> error_logger:warning_msg("Port ~p overloaded: ~p~n", 110 | [PortCmd, element(2, handle_call(status, From, NewState))]); 111 | _ -> ok % Do not print anything too frequently 112 | end, 113 | {noreply, enqueue_request(From, NewState)} 114 | end; 115 | 116 | % Send the Query into the port. 117 | handle_call(Query, From, #state{status = running, port = Port} = State) when is_tuple(Query) -> 118 | port_command(Port, term_to_binary(Query)), 119 | {noreply, enqueue_request(From, State)}; 120 | 121 | %% Initiate a graceful port termination: 122 | %% * No new requests are accepted 123 | %% * All outstanding requests are processed in order 124 | %% * An appropriate value is returned to portserver:stop/1 125 | handle_call(stop, _From, #state{qlen = 0} = State) -> 126 | {stop, normal, ok, State}; 127 | handle_call(stop, From, #state{status = running, port = Port} = State) -> 128 | port_command(Port, term_to_binary(stop)), 129 | timer:send_after(10000, force_stop), 130 | {noreply, enqueue_request(From, State#state{status = closing})}; 131 | 132 | %% Ping feature is necessary for end-to-end testing. 133 | %% External port is expected to respond with "pong". 134 | handle_call(ping, From, #state{status = running, port = Port} = State) -> 135 | port_command(Port, term_to_binary(ping)), 136 | {noreply, enqueue_request(From, State)}; 137 | 138 | %% Produce a set of status and health values. 139 | handle_call(status, _From, #state{status = Status, qlen = QLen } = State) -> 140 | Reply = [{status, Status}, {queue_length, QLen}] 141 | ++ case queue:peek(State#state.q) of 142 | {value, {T, _}} -> [{wait_time, 143 | now2ms(now()) - now2ms(T)}]; 144 | empty -> [] 145 | end 146 | ++ case jn_mavg:history(State#state.overloads) of 147 | {Current, _, Archived} when Current + Archived =:= 0 -> []; 148 | {C, H, A} -> [{overloads, [C|H] ++ (C+A)}] % Sic! 149 | end, 150 | {reply, Reply, State}; 151 | 152 | handle_call(_Q, _From, #state{status = closing} = State) -> 153 | {reply, {error, port_closing}, State}. 154 | 155 | handle_cast(_, State) -> 156 | {noreply, State}. 157 | 158 | handle_info({Port, {data, Data}}, #state{port = Port} = State) -> 159 | NewState = case queue:out(State#state.q) of 160 | {{value, {_T, From}}, Q} -> 161 | gen_server:reply(From, binary_to_term(Data)), 162 | State#state{q = Q, qlen = State#state.qlen - 1}; 163 | {empty, _} -> State 164 | end, 165 | {noreply, NewState}; 166 | handle_info({Port, _}, #state{status = closing, port = Port} = State) -> 167 | {stop, normal, respond_to_waiting(State, {error, port_closed})}; 168 | handle_info({Port, _}, #state{status = running, port = Port} = State) -> 169 | {stop, port_closed, respond_to_waiting(State, {error, port_closed})}; 170 | handle_info(force_stop, #state{status = closing} = State) -> 171 | {stop, normal, respond_to_waiting(State, {error, port_closed})}; 172 | handle_info(force_stop, #state{status = running} = State) -> 173 | {stop, port_closed, respond_to_waiting(State, {error, port_closed})}; 174 | handle_info(_Info, State) -> 175 | error_logger:warning_msg("Port ~p received unexpected message ~p~n", 176 | [State#state.portcmd, _Info]), 177 | {noreply, State}. 178 | 179 | code_change(_, State, _) -> 180 | {ok, State}. 181 | 182 | terminate(_, _) -> 183 | ok. 184 | 185 | %%% INTERNAL FUNCTIONS 186 | 187 | enqueue_request(From, #state{q = Q, qlen = QLen } = State) -> 188 | State#state{ q = queue:in({now(), From}, Q), qlen = QLen + 1 }. 189 | 190 | respond_to_waiting(#state{q = Q} = State, WithMessage) -> 191 | [gen_server:reply(From, WithMessage) || {_, From} <- queue:to_list(Q)], 192 | State#state{ q = queue:new(), qlen = 0 }. 193 | 194 | now2ms(Now) -> now2micro(Now) div 1000. 195 | 196 | now2micro({Mega, Sec, Micro}) -> Mega * 1000000000000 + Sec * 1000000 + Micro. 197 | --------------------------------------------------------------------------------