(* $Id: xdr_mstring.ml 1560 2011-03-04 22:05:14Z gerd $ *)

open Netsys_mem

class type mstring =
object
  method length : int
  method blit_to_string : int -> string -> int -> int -> unit
  method blit_to_memory : int -> memory -> int -> int -> unit
  method as_string : string * int
  method as_memory : memory * int
  method preferred : [ `Memory | `String ]
end


class type mstring_factory =
object
  method create_from_string : string -> int -> int -> bool -> mstring
  method create_from_memory : memory -> int -> int -> bool -> mstring
end

type named_mstring_factories =
    (string, mstring_factory) Hashtbl.t

let sbm s pos len : mstring =
  if len < 0 || pos < 0 || pos > String.length s - len then
    invalid_arg "Xdr_mstring.sbm";
  ( object
      method length = len
      method blit_to_string mpos u upos l =
	if l < 0 then
	  invalid_arg "Xdr_mstring#blit_to_string";
	if mpos < 0 || mpos > len - l then
	  invalid_arg "Xdr_mstring#blit_to_string";
	if upos < 0 || upos > String.length u - l then
	  invalid_arg "Xdr_mstring#blit_to_string";
	String.blit s (pos+mpos) u upos l
      method blit_to_memory mpos u upos l =
	if l < 0 then
	  invalid_arg "Xdr_mstring#blit_to_memory";
	if mpos < 0 || mpos > len - l then
	  invalid_arg "Xdr_mstring#blit_to_memory";
	if upos < 0 || upos > Bigarray.Array1.dim u - l then
	  invalid_arg "Xdr_mstring#blit_to_memory";
	Netsys_mem.blit_string_to_memory s (pos+mpos) u upos l
      method as_string = (s,pos)
      method as_memory =
	let m = Bigarray.Array1.create Bigarray.char Bigarray.c_layout len in
	Netsys_mem.blit_string_to_memory s pos m 0 len;
	(m,0)
      method preferred = `String
    end
  )


let mbm m pos len : mstring =
  if len < 0 || pos < 0 || pos > Bigarray.Array1.dim m - len then
    invalid_arg "Xdr_mstring.mbm";
  ( object
      method length = len
      method blit_to_string mpos u upos l =
	if l < 0 then
	  invalid_arg "Xdr_mstring#blit_to_string";
	if mpos < 0 || mpos > len - l then
	  invalid_arg "Xdr_mstring#blit_to_string";
	if upos < 0 || upos > String.length u - l then
	  invalid_arg "Xdr_mstring#blit_to_string";
	Netsys_mem.blit_memory_to_string m (pos+mpos) u upos l
      method blit_to_memory mpos u upos l =
	if l < 0 then
	  invalid_arg "Xdr_mstring#blit_to_memory";
	if mpos < 0 || mpos > len - l then
	  invalid_arg "Xdr_mstring#blit_to_memory";
	if upos < 0 || upos > Bigarray.Array1.dim u - l then
	  invalid_arg "Xdr_mstring#blit_to_memory";
	Bigarray.Array1.blit
	  (Bigarray.Array1.sub m (pos+mpos) l)
	  (Bigarray.Array1.sub u upos l)
      method as_string =
	let s = String.create len in
	Netsys_mem.blit_memory_to_string m pos s 0 len;
	(s,0)
      method as_memory = (m,pos)
      method preferred = `Memory
    end
  )


let string_based_mstrings : mstring_factory =
  ( object
      method create_from_string s pos len must_copy =
	if must_copy then
	  let s' = String.sub s pos len in
	  sbm s' 0 len
	else
	  sbm s pos len
      method create_from_memory m pos len must_copy =
	let s = String.create len in
	Netsys_mem.blit_memory_to_string m pos s 0 len;
	sbm s 0 len
    end
  )


let string_to_mstring ?(pos=0) ?len s =
  let s_len = String.length s in
  let len = match len with Some n -> n | None -> s_len - pos in
  string_based_mstrings # create_from_string s pos len false
	  

let memory_based_mstrings_1 create : mstring_factory =
  ( object
      method create_from_string s pos len must_copy =
	let m = create len in
	Netsys_mem.blit_string_to_memory s pos m 0 len;
	mbm m 0 len
      method create_from_memory m pos len must_copy =
	if must_copy then (
	  let m' = create len in
	  Bigarray.Array1.blit
	    (Bigarray.Array1.sub m pos len)
	    (Bigarray.Array1.sub m' 0 len);
	  mbm m' 0 len
	)
	else
	  mbm m pos len
    end
  )

let memory_based_mstrings =
  memory_based_mstrings_1  
    (Bigarray.Array1.create Bigarray.char Bigarray.c_layout)

let memory_to_mstring ?(pos=0) ?len m =
  let m_len = Bigarray.Array1.dim m in
  let len = match len with Some n -> n | None -> m_len - pos in
  memory_based_mstrings # create_from_memory m pos len false
	  

let paligned_memory_based_mstrings =
  memory_based_mstrings_1
    (fun n ->
       Netsys_mem.alloc_memory_pages n
    )

let memory_pool_based_mstrings pool =
  memory_based_mstrings_1
    (fun n ->
       if n <= Netsys_mem.pool_block_size pool then
	 Netsys_mem.pool_alloc_memory pool
       else
	 failwith "memory_pool_based_mstrings: string too large for pool"
    )


let length_mstrings mstrings =
  List.fold_left (fun acc ms -> acc + ms#length) 0 mstrings

let concat_mstrings (mstrings : mstring list) =
  match mstrings with
    | [] -> ""
    | _ ->
	let length = length_mstrings mstrings in
	let s = String.create length in
	let p = ref 0 in
	List.iter
	  (fun ms ->
	     let l = ms#length in
	     ms # blit_to_string 0 s !p l;
	     p := !p + l
	  )
	  mstrings;
	s

let prefix_mstrings mstrings n =
  let length = length_mstrings mstrings in
  if n < 0 || n > length then failwith "prefix_mstrings";
  let s = String.create n in
  let p = ref 0 in
  ( try
      List.iter
	(fun ms ->
	   if !p >= n then raise Exit;
	   let l = ms#length in
	   let l' = min l (n - !p) in
	   ms # blit_to_string 0 s !p l';
	   p := !p + l'
	)
	mstrings
    with Exit -> ()
  );
  s

let blit_mstrings_to_memory mstrings mem =
  let length = length_mstrings mstrings in
  if length > Bigarray.Array1.dim mem then
    failwith "blit_mstrings_to_memory";
  let p = ref 0 in
  List.iter
    (fun ms ->
       let l = ms#length in
       ms # blit_to_memory 0 mem !p l;
       p := !p + l
    )
    mstrings


let shared_sub_mstring (ms : mstring)
                       sub_pos sub_len : mstring =
  (* Returns an mstring that accesses the substring of ms at sub_pos
     with length sub_len. The returned mstring shares the representation
     with ms
   *)
  let ms_len = ms#length in
  if sub_len < 0 || sub_pos < 0 || sub_pos > ms_len - sub_len then
    invalid_arg "Xdr_mstring.shared_sub_mstring";
  ( object(self)
      method length = sub_len
      method blit_to_string mpos s spos len =
        ms#blit_to_string (sub_pos+mpos) s spos len
      method blit_to_memory mpos mem mempos len =
        ms#blit_to_memory (sub_pos+mpos) mem mempos len
      method as_string =
        let (s,pos) = ms#as_string in
        (s,pos+sub_pos)
      method as_memory =
        let (m,pos) = ms#as_memory in
        (m,pos+sub_pos)
      method preferred =
        ms#preferred
    end
  )

let shared_sub_mstrings l sub_pos sub_len =
  let l_len = length_mstrings l in
  if sub_len < 0 || sub_pos < 0 || sub_pos > l_len - sub_len then
    invalid_arg "Xdr_mstring.shared_sub_mstrings";
  let sub_pos' = sub_pos + sub_len in
  let rec map l pos =
    match l with
      | ms :: l' ->
	  let len = ms#length in
	  let pos' = pos+len in
	  let cond1 = pos' > sub_pos in
	  let cond2 = pos < sub_pos' in
	  if cond1 && cond2 && len > 0 then (
	    let ms' =
	      if pos < sub_pos then
		let q = min (pos' - sub_pos) sub_len in
		shared_sub_mstring ms (sub_pos - pos) q
	      else
		if pos' > sub_pos' then
		  shared_sub_mstring ms 0 (sub_pos' - pos)
		else
		  ms
	    in
	    ms' :: map l' pos'
	  )
	  else
	    map l' pos'
      | [] -> []
  in
  map l 0


let copy_mstring ms =
  let len = ms#length in
  match ms#preferred with
    | `String ->
	let (s, pos) = ms#as_string in
	string_based_mstrings#create_from_string s pos len true
    | `Memory ->
	let (m, pos) = ms#as_memory in
	memory_based_mstrings#create_from_memory m pos len true


let copy_mstrings l =
  List.map copy_mstring l