(**************************************************************************)
(*                   Cameleon                                             *)
(*                                                                        *)
(*      Copyright (C) 2002 Institut National de Recherche en Informatique et   *)
(*      en Automatique. All rights reserved.                              *)
(*                                                                        *)
(*      This program is free software; you can redistribute it and/or modify  *)
(*      it under the terms of the GNU General Public License as published by  *)
(*      the Free Software Foundation; either version 2 of the License, or  *)
(*      any later version.                                                *)
(*                                                                        *)
(*      This program is distributed in the hope that it will be useful,   *)
(*      but WITHOUT ANY WARRANTY; without even the implied warranty of    *)
(*      MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the     *)
(*      GNU General Public License for more details.                      *)
(*                                                                        *)
(*      You should have received a copy of the GNU General Public License  *)
(*      along with this program; if not, write to the Free Software       *)
(*      Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA          *)
(*      02111-1307  USA                                                   *)
(*                                                                        *)
(*      Contact: Maxence.Guesdon@inria.fr                                *)
(**************************************************************************)

(** Convenient function to execute shell commands after a fork *)

let (!!) = Options.(!!)

(** {2 Copied and modified from unix.ml in the OCaml distribution. 
   I 'd like to have a [Unix.kill_process_full] function...} *)

open Unix

let open_proc_full cmd env input output error toclose =
  match fork() with
     0 -> 
       dup2 input stdin; close input;
       dup2 output stdout; close output;
       dup2 error stderr; close error;
       List.iter close toclose;
       execve "/bin/sh" [| "/bin/sh"; "-c"; cmd |] env;
       exit 127;
       0
  | id -> 
      id

let open_process_full cmd env =
  let (in_read, in_write) = pipe() in
  let (out_read, out_write) = pipe() in
  let (err_read, err_write) = pipe() in
  let inchan = in_channel_of_descr in_read in
  let outchan = out_channel_of_descr out_write in
  let errchan = in_channel_of_descr err_read in
  let pid = open_proc_full cmd env 
                 out_read in_write err_write [in_read; out_write; err_read]
  in
  close out_read;
  close in_write;
  close err_write;
  (pid, (inchan, outchan, errchan))

let close_process_full pid (inchan, outchan, errchan) =
  close_in inchan;
  begin try close_out outchan with Sys_error _ -> () end;
  close_in errchan;
  snd(waitpid [] pid)

let kill_process_full pid (inchan, outchan, errchan) =
  close_in inchan;
  begin try close_out outchan with Sys_error _ -> () end;
  close_in errchan;
  kill pid 9 ;
  snd(waitpid [] pid)

(** {2 My functions} *)

(** Fork then exxcute the given command, showing
  the stdout and stderr output. *)
let background_execute ?(width=400) ?(height=300) com () =
  try
    let font = Gdk.Font.load !!Cam_config.font_exec in
    let w = GWindow.window ~title: com ~width ~height 
	~allow_shrink: true
	() 
    in
    let vbox = GPack.vbox ~packing: w#add () in
    let wpane = GPack.paned `VERTICAL ~packing: (vbox#pack ~expand: true) () in
    let wscroll = GBin.scrolled_window 
	~hpolicy: `AUTOMATIC
	~vpolicy: `AUTOMATIC
	~height: (height - 130)
	~packing: (wpane#add1)
	()
    in
    let wtext = GEdit.text ~editable: false ~packing: wscroll#add () in
    let wscroll_err = GBin.scrolled_window 
	~hpolicy: `AUTOMATIC
	~vpolicy: `AUTOMATIC
	~packing: (wpane#add2)
	()
    in
    let wtext_err = GEdit.text ~editable: false ~packing: wscroll_err#add () in
    let hbox = GPack.hbox ~packing: (vbox#pack ~expand: false) () in
    let wl_status = GMisc.label ~text: Cam_messages.running
	~packing: (hbox#pack ~expand: true) ()
    in
    let wb_kill = GButton.button ~label: Cam_messages.kill 
	~packing: (hbox#pack ~expand: true) ()
    in
    let wb_close = GButton.button ~label: Cam_messages.close 
	~packing: (hbox#pack ~expand: true) ()
    in
    let (pid, (outch,inch,errch)) = open_process_full com 
	(Unix.environment ())
    in
    let terminated = ref false in
    let close () =
      if not !terminated then 
	(
	 let status  = close_process_full pid (outch, inch, errch) in
	 let mes = 
	   match status with
	     Unix.WEXITED n -> Cam_messages.return_code n
	   | Unix.WSIGNALED n -> Cam_messages.kill_code n
	   | Unix.WSTOPPED n -> Cam_messages.stop_code n
	 in
	 wl_status#set_text mes;
	 terminated := true
	)
      else
	()
    in

    Okey.add_list w ~mods: [`CONTROL]
      [ GdkKeysyms._c ; GdkKeysyms._C ]
      w#destroy;

    let fd_in = Unix.descr_of_out_channel inch in
    let fd_out = Unix.descr_of_in_channel outch in
    let fd_err = Unix.descr_of_in_channel errch in

    Unix.set_nonblock fd_out;
    Unix.set_nonblock fd_err;

    let stopped = ref false in
    let stop () =
      if not !stopped then
	(
	 stopped := true ;
	 let s_out = Cam_misc.read_from_channel outch in
	 wtext#insert ~font ~foreground: (`NAME !!Cam_config.color_exec_stdout) s_out ;
	 let s_err = Cam_misc.read_from_channel errch in
	 wtext_err#insert ~font ~foreground: (`NAME !!Cam_config.color_exec_stderr) s_err ;
	 close ();
	);
    in

    let kill () =
      if not ! terminated then
	(
	 stopped := true;
	 try
	   let status = kill_process_full pid (outch, inch, errch) in
	   let mes = 
	     match status with
	       Unix.WEXITED n -> Cam_messages.return_code n
	     | Unix.WSIGNALED n -> Cam_messages.kill_code n
	     | Unix.WSTOPPED n -> Cam_messages.stop_code n
	   in
	   wl_status#set_text mes;
	 with _ -> 
	   ()
	);
      terminated := true
    in
      
    let read fd color (wt:GEdit.text) =
      let buf = String.create 128 in
      let continue = ref true in
      while !continue do
	try
	  let len = Unix.read fd buf 0 100 in
	  if len = 0 then
	    stop ()
	  else
	    let s = String.sub buf 0 len in
	    wt#insert ~font ~foreground: (`NAME color) s
	with
	  Unix.Unix_error (Unix.EAGAIN,_,_)
	| Unix.Unix_error (Unix.EWOULDBLOCK,_,_) ->
	    continue := false
	| Unix.Unix_error (Unix.EBADF,_,_) ->
	    continue := false
      done
    in
    let working = ref false in
    ignore (GMain.Timeout.add 500
	      (fun () -> 
		if !working then
		  ()
		else
		  (
		   working := true ;
		   read fd_out !!Cam_config.color_exec_stdout wtext;
		   read fd_err !!Cam_config.color_exec_stderr wtext_err ;
		   working := false
		  );
		not !stopped
	      )
	   );

    ignore (wb_close#connect#clicked w#destroy);
    ignore (wb_kill#connect#clicked kill);
    ignore (w#connect#destroy 
	      (fun () ->
		if not ! terminated then kill ();
		close ()
	      )
	   );

    w#show ()
  with
    Unix.Unix_error (e,s1,s2) ->
      let s = (Unix.error_message e)^s2^" "^s1 in
      GToolbox.message_box Cam_messages.error 
	(com^" :\n"^s)
  
(** Same as [background_execute] but performs substitution
   of %tags in the given command (see {!Cam_misc.substitute}).*)
let background_execute_with_subst ?width ?height com () =
  match Cam_misc.substitute com with
    None -> ()
  | Some s -> background_execute ?width ?height s ()
