Source

ocaml-bert / bert.ml

open Str;;

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

type erlterm =
    Int of int
  | Float of float
      (*  | Atom of string *) 
  | Tuple of erlterm list (* type of tuple is different btw Erlang and OCaml *)
  | List of erlterm list 
  | String of string
  | Binary of string
  | None;;

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

exception Not_supported;;
exception Unknown_type;;

let print_bin bin = 
  let rec print_ n =
    if n < String.length bin then begin 
      Printf.printf "%.2X " (int_of_char (String.get bin n));
      print_ (n+1);
    end else 
      print_endline ""
  in
    print_string "binary: ";
    print_ 0;;

let make_small_bigint bin len =
  let rec make_small_bigint_ i prod v = 
    if i < len then
      let p = prod lsl 8 in
      let n = int_of_char (String.get bin i) in
	make_small_bigint_ (i+1) p (v  + p * n)
    else v in
    make_small_bigint_ 0 1 0;;

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

(* 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 len binary list = 
    if len = 0 then
      Ok(List(list), binary)
    else 
      begin match local_decode binary with
	| Ok(t, remain) ->  decode_list (len-1) remain (t::list);
	| other -> other;
      end
  and local_decode local_bin = 
      (* 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)), Str.string_after local_bin 1)
      | 'b' ->  (* INTEGER_EXT *)
	  Ok( Int( make_int32 (String.sub local_bin 1 5)), Str.string_after local_bin 5);
      | 'c' -> (* FLOAT_EXT *)
	  let v = Scanf.sscanf (String.sub local_bin 1 32) "%f" (fun x->x) in
	    Ok( Float( v ), Str.string_after local_bin 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 *)
	  let len = int_of_char (String.get local_bin 1) in
	    decode_list len (Str.string_after local_bin 2) []; (* is it OK to use list? *)
      | 'i' -> (* LARGE_TUPLE_EXT *)
	  let len = make_int32 (String.sub local_bin 1 5) in
	    decode_list len (Str.string_after local_bin 5) []; (* is it OK to use list? *)
      | 'j' -> (* NIL_EXT *)
	  None;
      | 'k' -> (* STRING_EXT *)
	  let len = (int_of_char (String.get local_bin 1))*256 + (int_of_char (String.get local_bin 2)) in
	    Ok( String( String.sub local_bin 3 (len+3) ), Str.string_after local_bin (len+3) );
      | 'l' -> (* LIST_EXT *)
	  let len = make_int32 (String.sub local_bin 1 5) in
	    decode_list len (Str.string_after local_bin 5) [];
	  (*raise Not_supported; *)
      | 'm' -> (* BINARY_EXT *)
	  let len = make_int32 (String.sub local_bin 1 5) in
	  let remain = Str.string_after local_bin 5 in (* TODO: you'd better use Str.split *)
	    Ok( Binary( Str.string_before remain len ),  Str.string_after remain len );
      | 'n' -> (* SMALL_BIG_EXT *)
	  let n = int_of_char (String.get local_bin 1) in
	  let sign = int_of_char  (String.get local_bin 2) in
	  let result = make_small_bigint (String.sub local_bin 3 (n+3)) n in
	    if sign=0 then 
	      Ok( Int(result), Str.string_after local_bin (n+3) )
	    else if sign=1 then
	      Ok( Int(-result), Str.string_after local_bin (n+3) )
	    else 
	      raise Unknown_type;
      | 'o' -> (* LARGE_BIG_EXT *)
	  let n = make_int32 local_bin in
	  let sign = int_of_char  (String.get local_bin 5) in
	  let result = make_small_bigint (String.sub local_bin 6 (n+6)) n in
	    if sign=0 then 
	      Ok( Int(result), Str.string_after local_bin (n+6) )
	    else if sign=1 then
	      Ok( Int(-result), Str.string_after local_bin (n+6) )
	    else 
	      raise Unknown_type;
      | 'p' -> (* NEW_REFERENCE_EXT *)
	  raise Not_supported;
      | 'q' -> (* SMALL_ATOM_EXT *)
	  raise Not_supported;	    
      | 'r' -> (* FUN_EXT *)
	  raise Not_supported;	    
      | 's' -> (* NEW_FUN_EXT *)
	  raise Not_supported;	    
      | 't' -> (* EXPORT_EXT *)
	  raise Not_supported;	    
      | 'M' -> (* BIT_BINARY_EXT *)
	  raise Not_supported;
      | 'F' -> (* NEW_FLOAT_EXT *)
	  raise Not_supported;
      | _-> raise Unknown_type;
    end in
    begin match int_of_char (String.get bin 0) with
      | 131 -> (* magic number for BERT term; *)
	  local_decode (String.sub bin 1 ((String.length bin)-1)); 
      | _ -> raise Unknown_type;
    end;;

let print_binary bin = 
  let rec p_bin i =
    if i < (String.length bin) then begin
      Printf.printf " %c" (String.get bin i);
      p_bin (i+1)
    end in
    p_bin 0 ;;

let print_erlterm term = 
  let rec print_termlist rhs list =
    begin match list with
      | [] -> print_char rhs;
      | a::[] -> begin 
	  print_term a;
	  print_char rhs;
	end;
      | hd::tl -> begin
	  print_term hd;
	  print_string ", ";   (* erlang way *)
	  print_termlist rhs tl;
	end;
    end
  and print_term t = 
    begin match t with
      | Int(i)-> Printf.printf "%d" i;
      | Float(f)-> Printf.printf "%f" f;
      | Tuple(tpl)-> begin
	  print_char '{';  (* erlang way *)
	  print_termlist '}' tpl;
	end;
      | List(list)-> begin
	  print_char '[';    (* erlang way *)
	  print_termlist ']' list; 
	end;
      | String(str)->
	  print_string str;
      | Binary(bin)-> begin
	  print_string "<<";
	  print_binary bin ;
	  print_string ">>";
	end;
(*      | None ->
	  print_string "Nil"; *)
      | _->
	  raise Unknown_type;
    end in
    print_term term;
    print_char '.';;
Tip: Filter by directory path e.g. /media app.js to search for public/media/app.js.
Tip: Use camelCasing e.g. ProjME to search for ProjectModifiedEvent.java.
Tip: Filter by extension type e.g. /repo .js to search for all .js files in the /repo directory.
Tip: Separate your search with spaces e.g. /ssh pom.xml to search for src/ssh/pom.xml.
Tip: Use ↑ and ↓ arrow keys to navigate and return to view the file.
Tip: You can also navigate files with Ctrl+j (next) and Ctrl+k (previous) and view the file with Ctrl+o.
Tip: You can also navigate files with Alt+j (next) and Alt+k (previous) and view the file with Alt+o.