Source

rebildol / src / common.ml

let failwith fmt = Printf.ksprintf failwith fmt

let input_line_opt inch =
  try Some (input_line inch) with | End_of_file -> None

let failchain e fmt =
  let app_msg =
    match e with
    | Failure inner_msg -> inner_msg
    | e -> Printexc.to_string e
  in
    Printf.ksprintf (fun this_msg -> failwith "%s: %s" this_msg app_msg) fmt

let ( </> ) = Filename.concat

let dbg fmt = Printf.ksprintf (Printf.eprintf "DBG: %s\n%!") fmt

let ( !! ) = Lazy.force

let split_by_last pred str =
  let len = String.length str in
  let rec loop i =
    if i = 0
    then ("", str)
    else
      let i = i - 1 in
      if pred str.[i]
      then (String.sub str 0 i, String.sub str (i+1) (len-i-1))
      else loop i
  in
  loop len

let has_substring str sub =
  let strlen = String.length str
  and sublen = String.length sub in
  if sublen > strlen
  then false
  else
    let ilim = strlen - sublen + 1 in
    let rec check ?(i=0) ofs =
      if i = sublen
      then true
      else
        if str.[ofs+i] = sub.[i]
        then check ~i:(i+1) ofs
        else false
    in
    let rec loop i =
      if i = ilim
      then false
      else
        if check i
        then true
        else loop (i+1)
    in
      loop 0


module Reb_sys
 =
  struct
    let filename_null =
      if Sys.os_type = "Win32" then "NUL" else "/dev/null"

    let null_fd_read = lazy (Unix.openfile filename_null [Unix.O_RDONLY] 0)
    and null_fd_write = lazy (Unix.openfile filename_null [Unix.O_WRONLY] 0)

    let make_exe =
      try Sys.getenv "MAKE" with Not_found -> "make"

    let dump_argv argv =
        (Printf.sprintf "[%s]"
           (String.concat "; "
              (Array.to_list
                 (Array.map (Printf.sprintf "%S") argv)
              )
           )
        )

    let run_gen ~stdin ~show argv =
      if argv = [| |]
      then invalid_arg "Reb_sys.run: empty argv"
      else
      let pid =
        let f = Unix.create_process argv.(0) argv stdin in
        if show
        then f Unix.stdout Unix.stderr
        else let n = Lazy.force null_fd_write in f n n
      in
      let (pid', ps) = Unix.waitpid [] pid in
      let () = assert (pid = pid') in
      match ps with
      | Unix.WEXITED c -> c
      | Unix.WSIGNALED s -> failwith "command %s was killed by signal %i"
          (dump_argv argv) s
      | Unix.WSTOPPED _ -> assert false

    let run =
      run_gen ~stdin:Unix.stdin


    let lines_of_process cmd =
      let ch = Unix.open_process_in cmd in
      let rec loop acc =
        match input_line_opt ch with
        | None -> List.rev acc
        | Some l ->
            (* let () = Printf.eprintf "LOP: %s\n%!" l in *)
            loop (l :: acc)
      in
        let r = loop [] in
        match Unix.close_process_in ch with
        | Unix.WEXITED c ->
            if c = 0
            then r
            else failwith "command %S exited with error code %i" cmd c
        | Unix.WSIGNALED s -> failwith "command %S was killed by signal %i"
            cmd s
        | Unix.WSTOPPED _ -> failwith "process was stopped"


    let rm_rf dir =
      let fail msg = failwith "can't \"rm -rf\" directory %S: %s" dir msg in
      match run ~show:true [| "rm" ; "-rf" ; dir |] with
      | 0 ->
          if Sys.file_exists dir
          then fail "directory still exists"
          else ()
      | c ->
          fail (Printf.sprintf "\"rm -rf\" returned code %i" c)

    let path_abs p =
      if Filename.is_relative p
      then (Sys.getcwd ()) </> p
      else p

    let getenv_or_empty name =
      try Unix.getenv name
      with Not_found -> "" 

    let with_env name valu f =
      let old_valu = getenv_or_empty name in
      let finally () = Unix.putenv name old_valu in
      try
        let () = Unix.putenv name valu in
        let r = f () in
        let () = finally () in
        r
      with
      | e -> (finally (); raise e)

    let with_chdir d f =
      let old_cwd = Sys.getcwd () in
      let finally () = Sys.chdir old_cwd in
      let () = Sys.chdir d in
      try let r = f () in (finally (); r)
      with
      | e -> (finally (); raise e)

    let with_id f = f ()

    type 'a cont = (unit -> 'a) -> 'a

    let (( @+ ) : 'a cont -> 'a cont -> 'a cont) =
      fun w1 w2 f -> w1 (fun () -> w2 f)


    let modify_file infn func =
      if not (Filename.is_relative infn)
      then
        invalid_arg "Reb_sys.modify_file: can work with relative paths only"
      else
        let inch =
          try open_in_bin infn with
          | e -> failchain e "Reb_sys.modify_file: can't open file %S"
                   infn
        in
        let cwd = Sys.getcwd () in
        let temp_prefix = ((Filename.basename infn) ^ ".") in
        let (newfn, outch) =
          Filename.open_temp_file
            ~mode:[Open_binary]
            ~temp_dir:cwd
            temp_prefix ".new"
        in
        let finally () = (close_in inch; close_out outch) in
        let ((was_modified, _user_res) as res) =
          try func inch outch with
          | e ->
              ( finally ()
              ; failchain e
                  "Reb_sys.modify_file: exception from user function"
              )
        in
        let () = finally () in
        if was_modified
        then
          let bakfn = Filename.temp_file ~temp_dir:cwd temp_prefix ".bak" in
          ( Sys.rename infn bakfn
          ; Sys.rename newfn infn
          ; res
          )
        else
          ( Sys.remove newfn
          ; res
          )

    open Unix

    let assure_dir dir =
      let need_create =
        try
          match (stat dir).st_kind with
          | S_DIR -> false
          | S_REG | S_CHR | S_BLK | S_FIFO | S_SOCK ->
              failwith "can't create directory %S, there already exists \
                        entry with the same name" dir
          | S_LNK -> assert false
        with
        | Unix_error (ENOENT, "stat", _) -> true  
      in
        if need_create
        then mkdir dir 0o777
        else ()


    let assure_empty_dir d =
      ( rm_rf d
      ; assert
         (try
            (ignore (stat d); false)
          with
          | Unix_error (ENOENT, "stat", _) -> true
         )
      ; assure_dir d
      )


    let has_command argv =
      127 <> run ~show:false argv

    (* args -- see Filename.temp_file.
       file will be removed on function return. *)
    let with_temp_file ?(leave_on_fail=false) ?temp_dir prefix suffix f =
      let fn = Filename.temp_file ?temp_dir prefix suffix in
      let finally () = Sys.remove fn in
      try
        let r = f fn in
        (finally (); r)
      with
      | e -> ((if leave_on_fail then () else finally ()); raise e)

    let run_ok ~show argv =
      match run ~show argv with
      | 0 -> ()
      | c -> failwith "command %s exited with code %i"
          (dump_argv argv) c

  end


module Oasis
 =
  struct

    let copy_oasis_section inch outch =
      let rec loop ~inside =
        match input_line_opt inch with
        | None -> ()
        | Some line ->
            if line = "(* OASIS_START *)"
            then loop ~inside:true
            else
              if line = "(* OASIS_STOP *)"
              then ()
              else
                ( if inside
                  then Printf.fprintf outch "%s\n" line
                  else ()
                ; loop ~inside
                )
      in
        loop ~inside:false


    let setup_ml = "setup.ml"

    let get_build_deps () =
      let inch =
        try open_in_bin setup_ml
        with
        | (Sys_error _) as e ->
            failchain e "can't open \"setup.ml\" from directory %S"
              (Sys.getcwd ())
      in
      let (tmp_ml, outch) = Filename.open_temp_file
        ~mode:[Open_binary]
        "rebildol_oasis_deps" ".ml"
      in
      ( copy_oasis_section inch outch
      ; close_in inch
      ; output_string outch Templates.oasis_depends_template
      ; close_out outch
      ; let r = Reb_sys.lines_of_process (Printf.sprintf
            "ocaml %s"
            (Filename.quote tmp_ml)
          )
        in
        ( Sys.remove tmp_ml
        ; r
        )
      )


    let chop str =
      let sp = function | ' ' | '\t' | '\r' | '\n' -> true | _ -> false in
      let len = String.length str in
      let rec get_beg i =
        if i = len
        then len
        else if sp str.[i] then get_beg (i + 1) else i
      in
      let beg = get_beg 0 in
      if beg = len
      then ""
      else
      let rec get_end i =
        let i' = i - 1 in
        if sp str.[i']
        then get_end i'
        else i
      in
      let len = (get_end len) - beg in
      String.sub str beg len

    let patch_scanf_setup_ml () : unit =
      if not (Sys.file_exists setup_ml)
      then
        let () = dbg "patch_scanf_setup_ml: no setup.ml, no patching" in
        ()
      else
        let line_search = "Scanf.bscanf scbuf \"%S %S@\\n\""
        and line_replace = "Scanf.bscanf scbuf \"%S %S\\n\"" in
        let (patched, ()) =
          Reb_sys.modify_file setup_ml
            (fun inch outch ->
               let rec loop was_patched =
                 match input_line_opt inch with
                 | None -> (was_patched, ())
                 | Some line ->
                     let (line, line_patched) =
                       if chop line = line_search
                       then (line_replace, true)
                       else (line, false)
                     in
                     ( Printf.fprintf outch "%s\n" line
                     ; loop (was_patched || line_patched)
                     )
               in
                 loop false
            )
        in
          let () = dbg "Oasis.patch_scanf_setup_ml: setup.ml %s patched"
            (if patched then "was" else "was not")
          in
          ()

  end


module Findlib
 =
  struct
    let have_pkg (name : string) =
      0 = Reb_sys.run ~show:false
        [| "ocamlfind" ; "query" ; name |]
  end


let string_map f s =
  let s = String.copy s in
  let imax = String.length s - 1 in
  let () =
    for i = 0 to imax
    do
      s.[i] <- f s.[i]
    done
  in
    s