(* $Id: netsys_pmanage.ml 1774 2012-04-03 21:28:51Z gerd $ *)

type pm_obj =
    [ `File of string
    | `Posix_shm of string
    | `Posix_sem of string
    | `Sem_cont of string
    ]



class type pmanage =
object
  method register_file : string -> unit
  method unregister_file : string -> unit
  method register_posix_shm : string -> unit
  method unregister_posix_shm : string -> unit
  method register_posix_sem : string -> unit
  method unregister_posix_sem : string -> unit
  method register_sem_cont : string -> unit
  method unregister_sem_cont : string -> unit
  method registered : pm_obj list
  method register : pm_obj list -> unit
  method unlink : unit -> unit
end

module PmSet = Set.Make(struct type t = pm_obj let compare = compare end)


let unlink_this =
  function
    | `File p ->
        ( try Unix.unlink p with _ -> () )
    | `Posix_shm p ->
        ( try Netsys_posix.shm_unlink p with _ -> () )
    | `Posix_sem p ->
        ( try Netsys_posix.sem_unlink p with _ -> () )
    | `Sem_cont p ->
        ( try Netsys_sem.unlink p with _ -> () )


let mutex = !Netsys_oothr.provider # create_mutex()


let read_pm pm_path trunc_flag =
  let fd =
    Unix.openfile pm_path [Unix.O_RDWR; Unix.O_CREAT] 0o600 in
  try
    Unix.lockf fd Unix.F_LOCK 0;
    let file = Unix.in_channel_of_descr fd in
    let set = ref PmSet.empty in
    ( try
        while true do
          let (op, res) =
            Scanf.fscanf file "%c %s %S\n"
              (fun op_s res_kind res_detail ->
                 let op =
                   match op_s with
                     | 'R' -> `Register
                     | 'U' -> `Unregister
                     | _ -> failwith "Netsys_pmanage.read_pm" in
                 let res =
                   match res_kind with
                     | "FILE" -> `File res_detail
                     | "POSIX_SHM" -> `Posix_shm res_detail
                     | "POSIX_SEM" -> `Posix_sem res_detail
                     | "SEM_CONT" -> `Sem_cont res_detail
                     | _ -> failwith "Netsys_pmanage.read_pm" in
                 (op, res)
              ) in
          match op with
            | `Register ->
                set := PmSet.add res !set
            | `Unregister ->
                set := PmSet.remove res !set
        done;
        assert false
      with
        | End_of_file ->
            if trunc_flag then Unix.ftruncate fd 0;
            Unix.close fd;
            !set
    )
  with
    | error ->
        Unix.close fd;
        raise error


let read_pm_mt pm_path =
  Netsys_oothr.serialize
    mutex
    read_pm pm_path


let write_pm pm_path op pm_obj_list =
  let fd =
    Unix.openfile pm_path [Unix.O_RDWR; Unix.O_CREAT; Unix.O_APPEND] 0o600 in
  try
    Unix.lockf fd Unix.F_LOCK 0;
    let file = Unix.out_channel_of_descr fd in
    let op_s =
      match op with
        | `Register -> "R"
        | `Unregister -> "U" in
    List.iter
      (fun pm_obj ->
         let res_kind, res_detail =
           match pm_obj with
             | `File p -> "FILE", p
             | `Posix_shm p -> "POSIX_SHM", p
             | `Posix_sem p -> "POSIX_SEM", p
             | `Sem_cont p -> "SEM_CONT", p in
         Printf.fprintf file "%s %s %S\n" op_s res_kind res_detail;
      )
      pm_obj_list;
    flush file;
    Unix.close fd
  with
    | error ->
        Unix.close fd;
        raise error

let write_pm_mt pm_path op pm_obj_list =
  Netsys_oothr.serialize
    mutex
    (write_pm pm_path op) pm_obj_list


let check p =
  if p = "" || p.[0] <> '/' then
    failwith "Netsys_pmanage: path must be absolute"


let pmanage pm_path : pmanage =
  let reg obj_l =
    write_pm_mt pm_path `Register obj_l in
  let unreg obj_l =
    write_pm_mt pm_path `Unregister obj_l in
object (self)
  method register_file p = 
    check p; reg [`File p]
  method unregister_file p = 
    check p; unreg [`File p]
  method register_posix_shm p = 
    check p; reg [`Posix_shm p]
  method unregister_posix_shm p = 
    check p; unreg [`Posix_shm p]
  method register_posix_sem p = 
    check p; reg [`Posix_sem p]
  method unregister_posix_sem p = 
    check p; unreg [`Posix_sem p]
  method register_sem_cont p = 
    check p; reg [`Sem_cont p]
  method unregister_sem_cont p = 
    check p; unreg [`Sem_cont p]
  method registered =
    let set = read_pm_mt pm_path false in
    PmSet.elements set
  method register l =
    reg l
  method unlink() =
    let set = read_pm_mt pm_path true in
    PmSet.iter unlink_this set
end


let fake_pmanage () : pmanage =
  let set = ref PmSet.empty in
  let reg obj_l =
    List.iter
      (fun obj -> set := PmSet.add obj !set)
      obj_l in
  let unreg obj_l =
    List.iter
      (fun obj -> set := PmSet.remove obj !set)
      obj_l in
object (self)
  method register_file p = 
    check p; reg [`File p]
  method unregister_file p = 
    check p; unreg [`File p]
  method register_posix_shm p = 
    check p; reg [`Posix_shm p]
  method unregister_posix_shm p = 
    check p; unreg [`Posix_shm p]
  method register_posix_sem p = 
    check p; reg [`Posix_sem p]
  method unregister_posix_sem p = 
    check p; unreg [`Posix_sem p]
  method register_sem_cont p = 
    check p; reg [`Sem_cont p]
  method unregister_sem_cont p = 
    check p; unreg [`Sem_cont p]
  method registered =
    PmSet.elements !set
  method register l =
    reg l
  method unlink() =
    PmSet.iter unlink_this !set;
    set := PmSet.empty
    
end