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

let encode_int32 i = 
    let j = Int32.of_int i in
    let ff = Int32.of_int 0xFF in
      ((char_of_int (Int32.to_int (Int32.logand ff (Int32.shift_right j 24)))), 
       (char_of_int (Int32.to_int (Int32.logand ff (Int32.shift_right j 16)))),
       (char_of_int (Int32.to_int (Int32.logand ff (Int32.shift_right j 8)))),
       (char_of_int (Int32.to_int (Int32.logand ff j))) );;

(* 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 2 len ), Str.string_after local_bin (len+2) );
      | '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;;

(** these funcs have typical signature:
    [encode_* term buffer offset] -> offset + bytes_written **)

let encode_int i buf ofs =
  if i < 256 then (* SMALL_INTEGER_EXT *)
    begin 
      String.set buf ofs 'a';
      String.set buf (ofs+1) (char_of_int i);
      2+ofs;
    end
  else if i < 0xFFFFFFFF then (* INTEGER_EXT *)
    begin
      let (a,b,c,d) = encode_int32 i in
	String.set buf ofs 'b';
	String.set buf (ofs+1) a;
	String.set buf (ofs+2) b;
	String.set buf (ofs+3) c;
	String.set buf (ofs+4) d;
	5+ofs;
    end
  else (* SMALL_BIG_EXT *) 
    raise Not_supported;;
(**    begin String.set buf ofs 'n'; 1 end;; (* LARGE_BIG_EXT -> "o" *) **)

let encode_float f buf ofs = 
   (* FLOAT_EXT 'c' *)
  let str = Printf.sprintf "c%.20e" f in
  let len = min (String.length buf - ofs) (String.length str) in
    String.blit str 0 buf ofs len;
    32+ofs;;

let encode_atom atom buf ofs=
  let len = String.length atom in
    if len < 256 then (* SMALL_ATOM_EXT *)
      let str = Printf.sprintf "q %s" atom in
	begin 
	  String.set str 1 (char_of_int len);
	  String.blit str 0 buf ofs (len+2);
	  ofs + String.length str;
	end
    else (* ATOM_EXT *)
      let str = Printf.sprintf "d  %s" atom in
	begin
	  String.set str 1 (char_of_int (len/256));
	  String.set str 2 (char_of_int (len mod 256));
	  String.blit str 0 buf ofs (len+3);
	  ofs + String.length str;
	end;;

let encode_string str buf ofs =   (* STRING_EXT *) 
  let len = String.length str in
  let tmp_str = Printf.sprintf "k12%s" str in
    String.set tmp_str 1 (char_of_int (len/256));
    String.set tmp_str 2 (char_of_int (len mod 256));
    String.blit tmp_str 0 buf ofs (len+3);
    ofs + (String.length tmp_str);;

let encode_binary bin buf ofs = (* BINARY_EXT *)
  let str = Printf.sprintf "mabcd%s" bin in
  let (a,b,c,d) = encode_int32 (String.length bin) in
    String.set str 1 a;
    String.set str 2 b;
    String.set str 3 c;
    String.set str 4 d;
    String.blit str 0 buf ofs (String.length str);
    ofs + String.length str;;

let rec encode_tuple tuple buf ofs =
  let rec enc_tuple_ l nofs =
    match l with
      | [] -> nofs;
      | hd::tl -> 
	  let offset = encode_term hd buf nofs in
	    enc_tuple_ tl offset
  in
  let len = List.length tuple in
    if List.length tuple < 256 then begin (* SMALL_TUPLE_EXT *)
      String.set buf 0 'h';
      String.set buf 1 (char_of_int len);
      enc_tuple_ tuple (ofs+2);
    end else begin
      (* LARGE_TUPLE_EXT *)
      let (a,b,c,d) = encode_int32 len in
	String.set buf 0 'i';
	String.set buf 1 a;
	String.set buf 2 b;
	String.set buf 3 c;
	String.set buf 4 d;
	enc_tuple_ tuple (ofs+5);
    end

and encode_list list buf ofs = (* LIST_EXT *)
  let rec enc_list_ l nofs =
    match l with
      | [] -> nofs;
      | hd::tl ->
	  let offset = encode_term hd buf nofs in
	    enc_list_ tl offset 
  in
  let len = List.length list in
    String.set buf 0 'l';
    String.set buf 1 (char_of_int len);
    enc_list_ list (ofs+2)
      
and encode_term term buf ofs =
  String.set buf ofs (char_of_int 131);
  match term with
    | Int(i) ->   encode_int i buf (ofs+1); 
    | Float(f) -> encode_float f buf (ofs+1);
    | Atom(a)->   encode_atom a buf (ofs+1);
    | String(s)-> encode_string s buf (ofs+1);
    | Binary(b)-> encode_binary b buf (ofs+1);
    | Tuple(t)->  encode_tuple t buf (ofs+1);
    | List(l)->   encode_list l buf (ofs+1);
    | _ -> 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.