Source

ocaml-bert / bert.ml

open Str;;

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
  | Nil;;

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

exception Not_supported;;
exception Unknown_type;;

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 = 

  (* decoding tuple, traverses the list twice: first when parsing 
     (and pushes each term to stack list), second when reversing *)
  let rec decode_tuple len binary list = 
    if len=0 then Ok(Tuple(List.rev list), binary)
    else
      begin match local_decode binary with
	| Ok(term, remain) -> 
	    decode_tuple (len-1) remain (term::list);
	| other -> other;
      end 

  (* decoding list, traverses the list twice: first when parsing 
     (and pushes each term to stack list), second when reversing *)
  and decode_list len binary list = 
    begin match local_decode binary with
      | Ok(Nil, remain) when len=0 -> 
	  Ok(List(List.rev list), remain);
      | Ok(term, remain) when len=0 ->
	  Ok(List(List.rev (term::list)), remain );
      | Ok(term, remain) -> 
	  decode_list (len-1) remain (term::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 2)
      | '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 *)
	  let len = (int_of_char (String.get local_bin 1))*256 + (int_of_char (String.get local_bin 2)) in
	    Ok( Atom( String.sub local_bin 3 len ), Str.string_after local_bin (len+3) );
      | '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_tuple 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_tuple len (Str.string_after local_bin 5) []; (* is it OK to use list? *)
      | 'j' -> (* NIL_EXT *)
	  Ok( Nil, Str.string_after local_bin 1);
      | '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 ), 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) 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) 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 *)
	  let len = int_of_char (String.get local_bin 1) in   
	    Ok( Atom( String.sub local_bin 3 len ), Str.string_after local_bin (len+3) );
      | '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 (Str.string_after bin 1);
      | _ -> 
	  raise Unknown_type;
    end;;

let print_binary bin = 
  let rec to_inverse_list bin_ list = 
    if (String.length bin_)>0 then
      to_inverse_list (Str.string_after bin_ 1) ((int_of_char (String.get bin_ 0))::list)
    else list
  in
  let strs = List.fold_left (fun l c-> (Printf.sprintf "%.2x" c)::l ) [] (to_inverse_list bin []) in
  let s = String.concat "," strs in
    Printf.printf "<<%s>>" s;;

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
      | Nil ->
	  print_string "Nil";
      | 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_char '"';
	  print_string str;
	  print_char '"';
      | Binary(bin)->
	  print_binary bin;
      | Atom(atom)->
	  print_string atom;
(*      | _->
	  raise Unknown_type; *)
    end in
    print_term term;
    print_char '.';;

let print_binary_string bin = 
  let width = 16 in
  let rec print_ n =
    if n < String.length bin then begin
      if (n mod width) = 0 then Printf.printf "%.4X: " n;
      Printf.printf "%.2X " (int_of_char (String.get bin n));
      if (n mod width) = (width-1) then print_endline "";
      print_ (n+1);
    end else 
      print_endline ""
  in
    print_ 0;;


(* encode to BERT binary: erlterm -> string
   In future, this should be in C code *)
let encode term = function 
  | Int(i) when i < 256 -> (* SMALL_INTEGER_EXT *)
      Printf.sprintf "a%.2c" (char_of_int i);
  | Int(i) when i < 0xFFFFFFFF -> (* SMALL_INTEGER_EXT *)
      Printf.sprintf "b%d" i;
  | Float(f) -> (* FLOAT_EXT *)
      "c";
  | Atom(atom) when String.length atom > 255 -> (* ATOM_EXT *) "d";
  | Tuple(t) when List.length t < 256 -> (* SMALL_TUPLE_EXT *)
      "h";
  | Tuple(t) -> (* LARGE_TUPLE_EXT *)
      "i";
  | String(str)-> (* STRING_EXT *) "k";
  | List(list)->  (* LIST_EXT *) "l";
  | Binary(bin)-> (* BINARY_EXT *) "m";
  | Int(i) -> (* SMALL_BIG_EXT *) "n"; (* LARGE_BIG_EXT -> "o" *)
  | Atom(atom) -> (* SMALL_ATOM_EXT *) "q";
  | _ -> raise Unknown_type;;
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.