module File = struct

  (** [string_of_file] returns the contents of [filename] as a string. *)
  let string_of_file filename =
    let input_chan ichan =
      let result = ref "" in
      try
	while true do result := !result ^ (input_line ichan) ^ "\n" done; !result
      with
	End_of_file -> !result in

    let in_chan = Unix.in_channel_of_descr (Unix.openfile filename [Unix.O_RDONLY] 0) in
    input_chan in_chan

  (** [string_to_file] writes [str] to [filename] *)
  let string_to_file str filename =
    let out_chan =
      open_out_gen [ Open_creat ; Open_trunc ; Open_wronly  ] 0o0644 filename in
    output_string out_chan str ;
    close_out out_chan

end

module Util = struct

  let tassoc key alist =
    let (w, v) = List.assoc key alist in v

end

open Unixutils
open Log
open Fargs


(* A rewrite of kill-by-cwd.  Testing it here first, then will move it
   back to unixutils. *)
module Kill = struct

  let kill_by_cwd path = 
    let proc = Unix.opendir "/proc" in
    let kill pid =
      let cwd_opt = try Some (Unix.readlink ("/proc" ^/^ pid ^/^ "cwd")) with _ -> None in
      match cwd_opt with
	Some cwd ->
	  if Pcre.pmatch ~pat:(path ^ ".*") cwd then
	    begin
	      let exe_opt = try Some (Unix.readlink ("/proc" ^/^ pid ^/^ "exe")) with _ -> None in
	      begin
		match exe_opt with
		  Some exe ->
		    begin
		      Printf.printf "Killing: %10s %s\n" pid exe;
		      Unix.kill (int_of_string pid) 15
		    end
		| None ->
		    begin
		      Printf.printf "Killing: %10s %s\n" pid "unknown";
		      Unix.kill (int_of_string pid) 15
		    end
	      end
	    end
      | None -> ()
    in
    let rec loop f dh =
      let pid = Unix.readdir dh in
      let _ = if Pcre.pmatch ~pat:"[0-9]+" pid then
	kill pid in
      loop f dh in
    try
      loop kill proc
    with End_of_file -> ()
end



exception Undead_files of (string * string) list
exception File_mismatch of (string * string)
exception Break of int

let rec uniq same_fun list =
  match list with
    (a::b::rest) -> 
      if same_fun a b then
	uniq same_fun (a :: rest)
      else
	a :: uniq same_fun (b :: rest)
    | o -> o

(* Here are the steps used to build a base system from a sources.list:
   
   (1) Download the packages file from the fake sources list, (or the real sources list, if a fake one was not specified.)
   (2) Find all the packages that have the "Essential: yes" field.
   (3) Run the apt-get install --download-only to download the essential packages AND their dependencies.
   (4) Use 'dpkg -x' to extract all the packages without updating the status file or running the control scripts
   (5) Populate the status file with hacked up entries for all of the packages just extracted
   (6) Chroot to the build environtmont and run 'dpkg --unpack' to unpack all the debs and create real entries in the
   status, but don't configure them
   (7) Move start-stop-daemon and invoke-rc.d out of the way
   (8) Apt-get install build-essentials. This will install all the build essential packages AND configure 
   all the packages that have not been configured yet.
*)

(* Configure logging *)
let log_config = (stdout,stderr,chatty,true)
let log = Log.log log_config
let log_append = Log.log log_config
let log_nl level = Log.log log_config level "\n"

(* command-line options *)
let opts = [ (OPT_PARAM_REQ ("fakesrcslist",["-f" ; "--fake-sources-list"], "fake sources.list file to build environment from"))
	   ; (OPT_BOOL      ("force-exists",["--force-exists"], "do not abort if output directory already exists."))
	   ; (OPT_BOOL      ("no-update",["--no-update"], "assume apt files in build environment have already been updated.\n" ^
			       "     Implies --force-exists. Overrides --srcslist."))
	   ; (OPT_BOOL      ("no-essential",["--no-essential"], "assume that essential packages are already installed."))
	   ; (OPT_BOOL      ("no-build-essential",["--no-build-essential"], "do not install build essential packages."))
	   ; (OPT_BOOL      ("force-overwrite",["--force-overwrite"], "use dpkg --force-overwrite for essential packages."))
	   ; (OPT_BOOL      ("mirrored",["-m";"--mirrored"], "automatically replace 'fullpool' with 'mirrored'"))
	   ; (OPT_PARAM_REQ ("output",["-o" ; "--output"], "directory to build environment in"))
	   ; (OPT_PARAM_REQ ("srcslist",["-s" ; "--sources-list"], "sources.list file to build environment from"))
	   ; (OPT_PARAM_REQ ("preferences",["-p" ; "--preferences"], "apt preferences file to use"))
	   ; (OPT_PARAM_REQ ("archive-dir",["--archive-dir"], "deb archive directory to mount --bind inside build environment"))
	   ; (OPT_COMMAND   ("with",[],("[packages]","A list of extra packages to install.")))
	   ; (OPT_COMMAND   ("include",[],("[files_of_package_names]","A list of files containing the list of extra packages to install.")))
	   ; (OPT_BOOL      ("help",["-h";"--help"], "print help"))
	   ]

let rec apt_get_update srcs_urls srcs_local =
  match srcs_urls,srcs_local with
    (url::url_tl),(local::local_tl) ->
      Aptmethod.fetch url local ;
      apt_get_update url_tl local_tl
  | _ -> ()

let command str =
  let _ = log debug ("-> " ^ str ^ "\n") in
  let result = Sys.command str in
  if result != 0 then raise (Failure (str ^ "-> " ^ (string_of_int result)))

let print_help () =
  help ("Usage: " ^ (Filename.basename argv0) ^ " [options].\n\nBuild-env creates a directory containing a clean build environment.\nUse use-env to use the environtment.\n\nCurrently, the Packages files in the fullpool have had the Essential: lines removed, so you will need to construct a fake sources.list file that points to the mirrored pool so that the program can calculate the Essential packages to install from the fullpool.\n\nExamples:\n\n\tbuild-env -m -s marlin.list -o marlin with ssh\n\nOptions:\n") opts

let fail_with_help bad_opt =
  print_help () ;
  failwith bad_opt

let add_dot_slash path =
  if (not (Pcre.pmatch ~pat:"^.?/" path)) then
    ("./"^path)
  else
    path

let cleanup output_dir =
    (* unmount the stuff we mounted up before exiting *)
    log normal ("Killing all process with cwd under " ^ output_dir ^ " ...\n") ;
    Kill.kill_by_cwd output_dir ;
    log normal ("Unmounting anything mounted under " ^ output_dir ^ " ...\n") ;
    List.iter (fun mp -> log normal (mp ^ "\n")) (Unixutils.umount_below output_dir) ;
    Debian.rmtmp ()


let sameInode file1 file2 =
  let file1_lstat = Unix.lstat file1
  and file2_lstat = Unix.lstat file2 in
    file1_lstat.Unix.st_ino = file2_lstat.Unix.st_ino

let sameMd5sum file1 file2 =
  let md5sum file = 
    List.hd 
      (Pcre.split ~pat:" "
	 (List.hd (get_process_output ("md5sum \""^ file ^"\""))))
  in
  let file1_md5sum = md5sum file1
  and file2_md5sum = md5sum file2 in
    file1_md5sum = file2_md5sum

let check_and_restore file =
  if sameInode file "/bin/true" then
    begin
      log normal ("Restoring " ^ file ^ "\n") ;
      Unix.rename (file ^ ".real") file ;
      None
    end
  else
    Some (file,"/bin/true")

(** [neuter_file (file, must_exist)] backup [file] as [file].real and replace it with hardlink to /bin/true 

  If must_exist is true, then the function will raise Not_found is
  file does not exist. If must_exist is false, then the function does
  nothing if the file does not exist.
*)
let neuter_file (file, must_exist) =
  log normal ("Neutering file " ^ file ^ "\n") ;
  if Unixutils.exists file then
    begin
      if sameInode file "/bin/true" then
	log normal "File already a hardlink to /bin/true\n"
      else
	begin
	  if (Unixutils.exists (file ^ ".real")) then
	    if sameMd5sum file (file ^ ".real") then
	      begin
		log normal "File already backed up. Unlinking.\n" ;
		Unix.unlink file
	      end
	    else
	      begin
		log normal ("Error: " ^ file ^ " and " ^ file ^ ".real are not the same file.\n") ;
		raise (File_mismatch (file, file^".real"))
	      end
	  else
	    begin
	      log normal "Backing up file.\n" ;
	      Unix.rename file (file ^ ".real")
	    end ;
	  log normal "hardlinking to /bin/true.\n" ;
	  Unix.link "/bin/true" file
	end
    end
  else
    if must_exist then
      begin
	log normal "Could not neuter non-existant file.\n" ;
	raise Not_found 
      end
    else
      log normal "File does not exists, nothing to do...\n"
	
let build_from_sources_list output_dir parsed =

  (* Generate values based on the command-line options specified *)
  (* TODO -- need to make (fake)srsclist and no-update mutually exclusive *)
  let srcs_list_fn = try get_opt_param "srcslist" parsed with Invalid_Option _ -> (fail_with_help "You must specify --sources-list") in
  let fake_srcs_list_fn = try get_opt_param "fakesrcslist" parsed with Invalid_Option _ -> srcs_list_fn in
  let preferences_fn = try get_opt_param "preferences" parsed with Invalid_Option _ -> "/dev/null" in
  let archive_dir = try get_opt_param "archive-dir" parsed with Invalid_Option _ -> "none" in
  let no_update = has_opt "no-update" parsed in
  let no_essential = has_opt "no-essential" parsed in
  let install_build_essentials = not (has_opt "no-build-essential" parsed) in
  let cache_dir = Debian.tmpdir () ^/^ "cache" in
  let apt_opts = " -o=Dir::State::status=" ^ (add_dot_slash output_dir) ^/^ "/var/lib/dpkg/status" ^
    " -o=Dir::State::Lists=" ^ (add_dot_slash output_dir) ^/^ "/var/lib/apt/lists" ^
    " -o=Dir::Cache::Archives=" ^ (add_dot_slash output_dir) ^/^ "/var/cache/apt/archives" ^
    " -o=Dir::Etc::SourceList=" ^ (add_dot_slash srcs_list_fn) ^ " " ^
    " -o=Dir::Etc::Preferences=" ^ (add_dot_slash preferences_fn) ^ " " in
  let overwrite = has_opt "force-overwrite" parsed
  in
  let extra_packages = 
    try
      begin
	match get_command parsed with
	  ("with",parsed) ->
	    let packages = get_other parsed in
	    String.concat " " packages
	| ("include",parsed) ->
	    let package_files = get_other parsed in
	    String.concat " " (
	      List.concat (List.map Textfile.to_list package_files))
	| (name,_) -> fail_with_help ("Unimplemented command: " ^ name)
      end
    with
      No_Command -> ""
  in

  let apt_get cmd =
    command ("DEBIAN_FRONTEND=noninteractive apt-get -q " ^ apt_opts ^  cmd) 
  in
  (* Actual build of build environment starts here. *)
  begin
    if (not (has_opt "force-exists" parsed)) && (exists output_dir) then
      failwith ("Sorry, a directory or file named " ^ output_dir ^ " already exists.")
  end ;
  
  (* create minimal directory structure *)
  begin
    let new_dirs = [ cache_dir 
		   ; (output_dir ^/^ "etc")
		   ; (output_dir ^/^ "/usr/info")
		   ; (output_dir ^/^ "/var/lib/dpkg")
		   ; (output_dir ^/^ "/var/cache/apt/archives/partial")
		   ; (output_dir ^/^ "/var/lib/apt/lists/partial")
		   ; (output_dir ^/^ "/var/backups")
		   ; (output_dir ^/^ "/usr/lib/locale")
		   ]
    in
    let new_files = [ (output_dir ^ "/var/lib/dpkg/status")
		    ; (output_dir ^ "/var/lib/dpkg/available")
		    ]
    in
    List.iter (Unixutils.mkdir ~opts:["-p"]) new_dirs ;
    List.iter Unixutils.touch new_files;
    if has_opt "archive-dir" parsed then
      sh_mount ~opts:["--bind"] archive_dir (output_dir ^/^ "/var/cache/apt/archives")

  end ;

  (* These should be cleaned out at the end. *)
  if not no_update then
    begin
      cp "/etc/timezone" (output_dir ^/^ "/etc/timezone") ;
      (* Add code to only cp if the source file exists *)
      cp "/etc/resolv.conf" (output_dir ^/^ "/etc/resolv.conf") ;
      cp "/etc/hosts" (output_dir ^/^ "/etc/hosts") ;
      if Sys.file_exists "/usr/lib/locale/locale-archive" then cp "/usr/lib/locale/locale-archive" (output_dir ^/^ "/usr/lib/locale/locale-archive");
    end;

  (* The dir_file should probably be read from somewhere instead of hardcoded, but this works for now *)
  begin
    let dir_file = "-*- Text -*-
This is the file .../info/dir, which contains the topmost node of
the Info hierarchy.  The first time you invoke Info you start off
looking at that node, which is (dir)Top.

File: dir	Node: Top	This is the top of the INFO tree
  This (the Directory node) gives a menu of major topics.  Typing \"d\"
  returns here, \"q\" exits, \"?\" lists all INFO commands, \"h\"  gives a
  primer for first-timers, \"mTexinfo<Return>\" visits Texinfo topic,
  etc.
  Or click mouse button 2 on a menu item or cross reference to select
  it.
  --- PLEASE ADD DOCUMENTATION TO THIS TREE. (See INFO topic first.) ---

In Debian GNU/Linux, Info `dir' entries are added with the command
`install-info'.  Please refer to install-info(8) for usage details.

* Menu: The list of major topics begins on the next line.

Basics
* Finding files: (find). Operating on files matching certain criteria.

Miscellaneous:

Development
* Ipc: (ipc).		 System V interprocess communication facilities

General Commands
* grep: (grep). 	 Print lines matching a pattern.
* sed: (sed).		 Stream EDitor.
* Tar: (tar).		 Making tape (or disk) archives." in
    File.string_to_file dir_file (output_dir ^/^ "/var/backups/infodir.bak") ;
    File.string_to_file dir_file (output_dir ^/^ "/usr/info/dir") (* this line only needed for 4.0, but doesn't hurt anything *)
  end ;

  let srcs_list = 
    if (has_opt "mirrored" parsed) then
      Sourceslist.string_to_sources_list 
	(Pcre.qreplace ~pat:"fullpool" ~templ:"mirrored"
	   (File.string_of_file fake_srcs_list_fn))
    else
      Sourceslist.file_to_sources_list fake_srcs_list_fn
  in
  let srcs_urls = 
    (List.map Sourceslist.to_url
       (List.concat
	  (List.map Sourceslist.split_sections srcs_list)))
  in
  let srcs_local = 
    if no_update then
      List.map (fun u -> output_dir ^/^ "var/lib/apt/lists" ^/^ (Sourceslist.apt_name_mangle_url u)) srcs_urls
    else
      List.map (fun u -> cache_dir ^/^ (Sourceslist.apt_name_mangle_url u)) srcs_urls in
  let needs_ssh =
    let methods =  (List.map (fun u -> Neturl.url_scheme u) srcs_urls) in
    (List.mem "ssh" methods) || (List.mem "rsh" methods)
  in
  
  let packages = 
    if (not no_update) then
      apt_get_update srcs_urls srcs_local;
    List.concat (List.map Debutils.packages_file_to_alist srcs_local)
  in
    (* sort alphabetically, highest version first *)
  let sort_essentials (name1,control1) (name2,control2) =
    if not (name1 = name2) then 
      compare name1 name2 
    else
      let version1 = Util.tassoc "Version" control1 in
      let version2 = Util.tassoc "Version" control2 in
	Debian.version_compare version2 version1
  in

  let essentials = List.find_all (fun (name,control) -> try (Util.tassoc "Essential" control) ; true with Not_found -> false) packages in
  let essentials = List.sort sort_essentials essentials in
  let essentials = uniq (fun (name1,_) (name2,_) -> name1 = name2) essentials in
  List.iter (fun (name,_) -> log normal (name ^"\n")) essentials ;    
  if (not no_update) then apt_get "update -o APT::Cache-Limit=300000000 " ;
  if (not no_essential) then
    begin
      apt_get ("install --yes --force-yes --download-only apt " ^ (if needs_ssh then "ssh" else "") ^" "^ 
		 (String.concat " " (List.map ( fun (n,_) -> n) essentials))) ;
      List.iter (fun deb -> command ("dpkg -x " ^ deb ^ " " ^ output_dir)) 
	(get_process_output ("ls " ^ output_dir ^/^ "/var/cache/apt/archives/*.deb")) ;

    end;
  let reconfigure_later_debs =
    if (not no_essential) then
      begin
	let control deb = 
	  command ("dpkg -f " ^ deb ^ " > " ^ Debian.tmpdir () ^/^ "control") ;
	  List.hd (Debutils.packages_file_to_alist (Debian.tmpdir () ^/^ "control"))
	in
	
	(* there is a hack -- namely only : is url encoded in filenames *)
	let package_deb_name ?(arch="i386") control =
	  let name = Util.tassoc "Package" control in
	  let version = Pcre.replace ~pat:":" ~templ:"%3a" (Util.tassoc "Version" control) in
	  let architecture = Util.tassoc "Architecture" control in
	  (* note the '*' in the version. This is because the fullpool
	     pool may contain cnrX things appended to the version, but
	     the control file we read is from the mirrored pool. Since
	     there should only be one version this ought to work, but
	     it is just a hack to support the 'obsolete' coho stuff --
	     so I don't care to fix it right.  *)
	  if (has_opt "mirrored" parsed) then
	    name ^"_"^ version ^"*_"^ architecture ^".deb"
	  else
	    name ^"_"^ version ^"_"^ architecture ^".deb"
	in
	
	let fake_status_debs = ["/var/cache/apt/archives" ^/^ (package_deb_name (List.assoc "dpkg" essentials))] in
	let fake_status =
	  List.map (fun (n,c) -> (n,
				  [ ("Package", (" ", Util.tassoc "Package" c))
				  ; ("Version", (" ", Util.tassoc "Version" c))
				  ; ("Status", (" ", "install ok installed"))
				  ]
				 ))
	    (List.map control (List.map (fun f -> output_dir ^/^ f) fake_status_debs))
	in
	Debutils.packages_alist_to_file fake_status (output_dir ^/^ "/var/lib/dpkg/status") ;
	List.iter (fun (name,_) -> command ("touch " ^ output_dir ^/^ "/var/lib/dpkg/info/" ^ name ^ ".list")) fake_status ;
	fake_status_debs
      end
    else []
  in

  let ssh_auth_sock_dir = 
    try
      Filename.dirname (Unix.getenv("SSH_AUTH_SOCK"))
    with Not_found -> ""
  in
  let _ = 
    if needs_ssh then
      begin 
	command ("cp -a ~/.ssh " ^ output_dir) ;
	command ("mknod " ^ output_dir ^ "/dev/random c 1 8; mknod " ^ output_dir ^ "/dev/urandom c 1 9");
	if (ssh_auth_sock_dir <> "") then
	  begin
	    mkdir ~opts:["-p"] (output_dir ^/^ ssh_auth_sock_dir) ;
	    sh_mount ~opts:["--bind"] ssh_auth_sock_dir (output_dir ^/^ ssh_auth_sock_dir)
	  end ;
      end ;
  in
  let neuter_files = [	("/sbin/start-stop-daemon", true) ;
			("/usr/sbin/invoke-rc.d", true) ;
			("/sbin/init",true) ;
			("/usr/sbin/policy-rc.d", false)
		     ]
  in

    if (not no_update) then
      (
	command ("cp " ^ srcs_list_fn ^" "^ output_dir ^/^ "/tmp/sources.list") ;
	command ("cp " ^ preferences_fn ^" "^ output_dir ^/^ "/tmp/preferences")
      );

			
  (* Mount /proc and /dev *)
  command ("cd " ^ output_dir ^ " && mkdir -p dev proc sys");
  sh_mount ~opts:["--bind"] "/proc" (output_dir ^/^ "/proc");
  sh_mount ~opts:["--bind"] "/dev" (output_dir ^/^ "/dev");
  sh_mount ~opts:["--bind"] "/sys" (output_dir ^/^ "/sys");
  
    fchroot output_dir (fun () ->
			  if not no_essential then command ("cd /usr/bin && (test -f gawk && ln -s gawk awk) || (test -f mawk && ln -s mawk awk)") ;
			  
			  (* Move start-stop-daemon and invoke-rc.d out of the way, we don't want to start daemons inside the chroot *)
			  if not no_essential then List.iter neuter_file neuter_files ;
			
			(* move ~/.ssh into place if sources.list requires ssh.
			   DSF: I changed the destination from ~/ to /root/ in
			   case $HOME is set to some user that only exists in
			   the outside world. *)
			  if needs_ssh then
			    command ("if [ -d /.ssh ] ; then mv /.ssh/ /root/ ; fi") ;

			  (* apt-get install the essential packages *)
			if (not no_update) then
			  (
			    command ("mv /tmp/sources.list /etc/apt/sources.list") ;
			    command ("mv /tmp/preferences /etc/apt/preferences") ;
			  );
			command ("echo 'APT::Cache-Limit 300000000;' >/etc/apt/apt.conf") ;
			command ("echo 'APT::Get::AllowUnauthenticated 1;' >>/etc/apt/apt.conf") ;
			command ("echo 'Dpkg::MaxArgs 1024;' >>/etc/apt/apt.conf") ;
			command ("echo 'Dpkg::MaxArgBytes 32000;' >>/etc/apt/apt.conf") ;
			command ("touch /var/lib/dpkg/diversions") ;
			if (not no_essential) then
			  begin
			    command ("DEBIAN_FRONTEND=noninteractive apt-get install --yes -o APT::Cache-Limit=300000000 apt " ^
				       (if needs_ssh then "ssh " else "") ^
				       (String.concat " " (List.map (fun (n,_) -> n) essentials))) ;
			
			    (* unpack and configure any debs that had fake
			       status file entries so that they are installed
			       for real 
			    *)
			    List.iter (fun deb -> 
					 command ("dpkg --unpack " ^ deb) ;
					 command ("dpkg --configure --pending")
				      ) reconfigure_later_debs ;
			
			  end;
			(* Move start-stop-daemon and invoke-rc.d out
			   of the way (again), we don't want to start
			   daemons inside the chroot *)
			List.iter neuter_file neuter_files ;


			(* now we should have a fully functional
			   system, so we can apt-get some additional
			   packages *)
			if install_build_essentials then
			  command ("DEBIAN_FRONTEND=noninteractive apt-get install --yes -o APT::Cache-Limit=300000000 build-essential " ^ extra_packages)
			else
			  command ("DEBIAN_FRONTEND=noninteractive apt-get install --yes -o APT::Cache-Limit=300000000 " ^ extra_packages) ;
			
			(* Restore neutered files *)
			begin
			  match (Option.filter
				   (List.map check_and_restore 
				      [ "/sbin/start-stop-daemon" ;
					"/usr/sbin/invoke-rc.d" ;
					"/sbin/init" 
				      ])) with
			      [] -> ()
			    | undead -> raise (Undead_files undead)
			end ;
	
			(* make sure .ssh  does not escape into the wild *)
			if needs_ssh then
			  command ("rm -rf /root/.ssh") ;
		     )

let string_of_signal_number (n : int) =
  match n with
      s when s = Sys.sigabrt -> "sigabrt"
    | s when s = Sys.sigalrm -> "sigalrm"
    | s when s = Sys.sigfpe  -> "sigfpe"
    | s when s = Sys.sighup  -> "sighup"
    | s when s = Sys.sigill  -> "sigill"
    | s when s = Sys.sigint  -> "sigint"
    | s when s = Sys.sigpipe -> "sigpipe"
    | s when s = Sys.sigterm -> "sigterm"
    | s when s = Sys.sigusr1 -> "sigusr1"
    | s when s = Sys.sigusr2 -> "sigusr2"
    | s when s = Sys.sigcont -> "sigcont"
    | s when s = Sys.sigtstp -> "sigtstp"
    | s when s = Sys.sigttin -> "sigttin"
    | s when s = Sys.sigttou -> "sigttou"
    | s when s = Sys.sigvtalrm -> "sigvtalrm"
    | s -> "unknown"

(* Main *)
 let _ =
  (* parse the command-line options, generate an error message if an invalid option was specified. *)
  let parsed = 
    try
      parse_options opts argv 
    with
      Invalid_Option bad_opt -> fail_with_help (bad_opt ^ " is not a valid option")
  in
  if (has_opt "help" parsed) then
    begin
      print_help () ;
      exit 0
    end
  else
    let output_dir = try get_opt_param "output" parsed with Invalid_Option _ -> (fail_with_help "You must specify --output") in
      begin
	(* turn a bunch of signals into exceptions so we can clean-up
	   if one occurs *)
	List.iter
	  (fun s -> Sys.set_signal s (Sys.Signal_handle (fun n -> raise (Break n))))
	  [ Sys.sigabrt ; Sys.sigalrm ; Sys.sigfpe ; Sys.sighup ; Sys.sigill ; 
	    Sys.sigint; Sys.sigpipe ; Sys.sigterm ; Sys.sigusr1 ; 
	    Sys.sigusr2 ; Sys.sigcont ; Sys.sigtstp ;
	    Sys.sigttin ; Sys.sigttou ; Sys.sigvtalrm 
	  ]
      end ;
      try
	build_from_sources_list output_dir parsed ;
	cleanup output_dir ;
	log normal "Success.\n"
      with
	  Undead_files ufs -> 
	    List.iter 
	    (fun (file1,file2) ->
	       log normal ("Neutered file returned from the dead. " ^ file1 ^ " and " ^ file2 ^ " are not the same file.\n")) ufs ;
	    cleanup output_dir ;
	    raise (Undead_files ufs)
	| Break n -> 
	    cleanup output_dir ;
	    log normal ("received signal " ^ (string_of_signal_number n) ^ "(" ^ (string_of_int n) ^ ")\n") ;
	    raise (Break n)
	| e -> 
	    cleanup output_dir ; 
	    log normal "Failure.\n"  ;
	    raise e