Source

ocaml-bert / erbo.ml

type term =
    Int of int
  | Float of float
(*  | Atom of string
  | `Tuple of term list 
  | List of 'term list  *)
  | String of string
  | Binary of string
  | None;;

type result = 
  | Ok of term * string
  | More of int
  | None;;

let bert_version_number = 131;;

(*
class pid = let a in 1;;
class ref = let a in 1;;
class port = Not_supported;;
*)

exception Not_supported;;
exception Unknown_type;;


let make_int32 bin = 
  let rec make_int32_ bin v i =
    if i < 4 then 
      make_int32_ bin ((v*16) + (int_of_char (String.get bin i))) (i+1)
    else v
  in make_int32_ bin 0 0;;

let make_int8 r1 r2 = 
  (int_of_char r1) * 16 + (int_of_char r2);;

(* binary -> (decoded tuple, remain), (more, Length), (error, Reason)
   throws exceptions: Not_supported | Unknown_type
   when more binaries  *)
let decode_binary bin = 
  let rec decode_list count local_bin list = 
    if count=0 then Ok( list, local_bin )
    else
      begin match local_decode local_bin with
	| Ok( term, remain )->
	    decode_list (count-1) remain (term::list);
	| More( length )->
	    More( length );
	| _-> 
	    raise Unknown_type;
      end
  and local_decode local_bin = 
    let length = String.length local_bin in 
      (* see http://www.erlang.org/doc/apps/erts/erl_ext_dist.html for details*)
      begin match (String.get local_bin 0) with
	| 'a' ->  (* SMALL_INTEGER_EXT *)
	    Ok( Int(int_of_char (String.get local_bin 1)), 
		String.sub local_bin 2 (length-2) );
	| 'b' ->  (* INTEGER_EXT *)
	    Ok( Int( make_int32 (String.sub local_bin 1 5)),
		String.sub local_bin 5 (length-5) );
	| 'c' -> (* FLOAT_EXT *)
	    let v = Scanf.sscanf (String.sub local_bin 1 32) "%f" (fun x->x) in
	    Ok( Float( v ), String.sub local_bin 32 (length-32) );
	| 'd' -> (* ATOM_EXT *)
	    raise Not_supported;
	| 'e' -> (* REFERENCE_EXT *)
	    raise Not_supported;
	| 'f' -> (* PORT_EXT *)
	    raise Not_supported;
	| 'g' -> (* PID_EXT *)
	    raise Not_supported;
	| 'h' -> (* SMALL_TUPLE_EXT *)
	    raise Not_supported;
	| 'i' -> (* LARGE_TUPLE_EXT *)
	    raise Not_supported;
	| 'j' -> (* NIL_EXT *)
	    None;
	| 'k' -> (* STRING_EXT *)
	    let len = make_int8 (String.get local_bin 1) (String.get local_bin 2) in
	    Ok( String( String.sub local_bin 3 (len+3) ),
		String.sub local_bin (len+3) (length-len-3) );
	| 'l' -> (* LIST_EXT *)
	    let len = make_int32 (String.sub local_bin 1 5) in
	      
	    raise Unknown_type;
	| 'm' -> (* BINARY_EXT *)
	    raise Unknown_type;
	| 'n' -> (* SMALL_BIG_EXT *)
	    raise Unknown_type;
	| 'o' -> (* LARGE_BIG_EXT *)
	    raise Unknown_type;
	| 'p' -> (* NEW_REFERENCE_EXT *)
	    raise Unknown_type;	    
	| 'q' -> (* SMALL_ATOM_EXT *)
	    raise Unknown_type;	    
	| 'r' -> (* FUN_EXT *)
	    raise Unknown_type;	    
	| 's' -> (* NEW_FUN_EXT *)
	    raise Unknown_type;	    
	| 't' -> (* EXPORT_EXT *)
	    raise Unknown_type;	    
	| 'M' -> (* BIT_BINARY_EXT *)
	    raise Unknown_type;	    
	| 'F' -> (* NEW_FLOAT_EXT *)
	    raise Unknown_type;	    
	| _-> raise Unknown_type;
      end in
    begin match int_of_char (String.get bin 0) with
      | 131 -> local_decode (String.sub bin 1 ((String.length bin)-1)); (* magic number for BERT term; *)
      | _ -> raise Unknown_type;
    end;;