helm/matita/matitamakeLib.ml

   1 (* Copyright (C) 2005, HELM Team.
   2  *
   3  * This file is part of HELM, an Hypertextual, Electronic
   4  * Library of Mathematics, developed at the Computer Science
   5  * Department, University of Bologna, Italy.
   6  *
   7  * HELM is free software; you can redistribute it and/or
   8  * modify it under the terms of the GNU General Public License
   9  * as published by the Free Software Foundation; either version 2
  10  * of the License, or (at your option) any later version.
  11  *
  12  * HELM is distributed in the hope that it will be useful,
  13  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  14  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15  * GNU General Public License for more details.
  16  *
  17  * You should have received a copy of the GNU General Public License
  18  * along with HELM; if not, write to the Free Software
  19  * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
  20  * MA  02111-1307, USA.
  21  *
  22  * For details, see the HELM World-Wide-Web page,
  23  * http://helm.cs.unibo.it/
  24  *)
  25
  26 let logger = fun mark ->
  27   match mark with
  28   | `Error -> MatitaLog.error
  29   | `Warning -> MatitaLog.warn
  30   | `Debug -> MatitaLog.debug
  31   | `Message -> MatitaLog.message
  32 ;;
  33
  34 type development =
  35   { root: string ; name: string }
  36
  37 let developments = ref []
  38
  39 let pool () = Helm_registry.get "matita.basedir" ^ "/matitamake/" ;;
  40 let rootfile = "/root" ;;
  41
  42 let ls_dir dir =
  43   try
  44     let d = Unix.opendir dir in
  45     let content = ref [] in
  46     try
  47       while true do
  48         let name = Unix.readdir d in
  49         if name <> "." && name <> ".." then
  50           content := name :: !content
  51       done;
  52       Some []
  53     with End_of_file -> Unix.closedir d; Some !content
  54   with Unix.Unix_error _ -> None
  55
  56 let initialize () =
  57   (* create a base env if none *)
  58   MatitaMisc.mkdir (pool ());
  59   (* load developments *)
  60   match ls_dir (pool ()) with
  61   | None -> logger `Error ("Unable to list directory " ^ pool ())
  62   | Some l ->
  63       List.iter
  64         (fun name ->
  65           let root =
  66             try
  67               Some (MatitaMisc.input_file (pool () ^ name ^ rootfile))
  68             with Unix.Unix_error _ ->
  69               logger `Warning ("Malformed development " ^ name);
  70               None
  71           in
  72           match root with
  73           | None -> ()
  74           | Some root ->
  75               developments := {root = root ; name = name} :: !developments)
  76       l
  77
  78 (* finds the makefile path for development devel *)
  79 let makefile_for_development devel =
  80   let develdir = pool () ^ devel.name in
  81   develdir ^ "/makefile"
  82 ;;
  83
  84 (* given a dir finds a development that is radicated in it or below *)
  85 let development_for_dir dir =
  86   let is_prefix_of d1 d2 =
  87     let len1 = String.length d1 in
  88     let len2 = String.length d2 in
  89     if len2 < len1 then
  90       false
  91     else
  92       let pref = String.sub d2 0 len1 in
  93       pref = d1
  94   in
  95   (* it must be unique *)
  96   try
  97     Some (List.find (fun d -> is_prefix_of d.root dir) !developments)
  98   with Not_found -> None
  99 ;;
 100
 101 let development_for_name name =
 102   try
 103     Some (List.find (fun d -> d.name = name) !developments)
 104   with Not_found -> None
 105
 106 (* dumps the deveopment to disk *)
 107 let dump_development devel =
 108   let devel_dir = pool () ^ devel.name in
 109   MatitaMisc.mkdir devel_dir;
 110   MatitaMisc.output_file devel.root (devel_dir ^ rootfile);
 111 ;;
 112
 113 let list_known_developments () =
 114   List.map (fun r -> r.name,r.root) !developments
 115
 116 let am_i_opt () =
 117   if Pcre.pmatch ~pat:"\\.opt$" Sys.argv.(0) then ".opt" else ""
 118
 119 let rebuild_makefile development =
 120   let makefilepath = makefile_for_development development in
 121   let template =
 122     MatitaMisc.input_file BuildTimeConf.matitamake_makefile_template
 123   in
 124   let cc = BuildTimeConf.runtime_base_dir ^ "/matitac" ^ am_i_opt () in
 125   let rm = BuildTimeConf.runtime_base_dir ^ "/matitaclean" ^ am_i_opt () in
 126   let mm = BuildTimeConf.runtime_base_dir ^ "/matitadep" ^ am_i_opt () in
 127   let df = pool () ^ development.name ^ "/depend" in
 128   let dfs = pool () ^ development.name ^ "/depend.short" in
 129   let template = Pcre.replace ~pat:"@ROOT@" ~templ:development.root template in
 130   let template = Pcre.replace ~pat:"@CC@" ~templ:cc template in
 131   let template = Pcre.replace ~pat:"@DEP@" ~templ:mm template in
 132   let template = Pcre.replace ~pat:"@DEPFILE@" ~templ:df template in
 133   let template = Pcre.replace ~pat:"@DEPFILESHORT@" ~templ:dfs template in
 134   let template = Pcre.replace ~pat:"@CLEAN@" ~templ:rm template in
 135   MatitaMisc.output_file template makefilepath
 136
 137 (* creates a new development if possible *)
 138 let initialize_development name dir =
 139   let dev = {name = name ; root = dir} in
 140   match development_for_dir dir with
 141   | Some d ->
 142       logger `Error
 143         ("Directory " ^ dir ^ " is already handled by development " ^ d.name);
 144       logger `Error
 145         ("Development " ^ d.name ^ " is rooted in " ^ d.root);
 146       logger `Error
 147         (dir ^ " is a subdir of " ^ d.root);
 148       None
 149   | None ->
 150       dump_development dev;
 151       rebuild_makefile dev;
 152       developments := dev :: !developments;
 153       Some dev
 154
 155 let make chdir args =
 156   let old = Unix.getcwd () in
 157   try
 158     Unix.chdir chdir;
 159     let rc = Unix.system (String.concat " " ("make"::args)) in
 160     Unix.chdir old;
 161     match rc with
 162     | Unix.WEXITED 0 -> true
 163     | Unix.WEXITED i -> logger `Error ("make returned " ^ string_of_int i);false
 164     | _ -> logger `Error "make STOPPED or SIGNALED!";false
 165   with Unix.Unix_error (_,cmd,err) ->
 166     logger `Warning ("Unix Error: " ^ cmd ^ ": " ^ err);
 167     false
 168
 169 let call_make development target make =
 170   rebuild_makefile development;
 171   let makefile = makefile_for_development development in
 172   make development.root
 173     ["--no-print-directory"; "-s"; "-k"; "-f"; makefile; target]
 174
 175 let build_development ?(target="all") development =
 176   call_make development target make
 177
 178 exception CHILD_DEAD
 179
 180 (* not really good vt100 *)
 181 let vt100 s =
 182   let rex = Pcre.regexp "\e\\[[0-9;]+m" in
 183   let rex_i = Pcre.regexp "^Info" in
 184   let rex_w = Pcre.regexp "^Warning" in
 185   let rex_e = Pcre.regexp "^Error" in
 186   let rex_d = Pcre.regexp "^Debug" in
 187   let rex_noendline = Pcre.regexp "\\n" in
 188   let s = Pcre.replace ~rex:rex_noendline s in
 189   let len = String.length s in
 190   let tokens = Pcre.split ~rex s in
 191   let logger = ref MatitaLog.message in
 192   let rec aux =
 193     function
 194     | [] -> ()
 195     | s::tl ->
 196         (if Pcre.pmatch ~rex:rex_i s then
 197           logger := MatitaLog.message
 198         else if Pcre.pmatch ~rex:rex_w s then
 199           logger := MatitaLog.warn
 200         else if Pcre.pmatch ~rex:rex_e s then
 201           logger := MatitaLog.error
 202         else if Pcre.pmatch ~rex:rex_d s then
 203           logger := MatitaLog.debug
 204         else
 205           !logger s);
 206         aux tl
 207   in
 208   aux tokens
 209
 210
 211 let mk_maker refresh_cb =
 212   (fun chdir args ->
 213     let out_r,out_w = Unix.pipe () in
 214     let err_r,err_w = Unix.pipe () in
 215     let pid = ref ~-1 in
 216     try
 217       let _ =
 218         Sys.signal Sys.sigchld (Sys.Signal_handle (fun _ -> raise CHILD_DEAD))
 219       in
 220       let argv = Array.of_list ("make"::args) in
 221       pid := Unix.create_process "make" argv Unix.stdin out_w err_w;
 222       Unix.close out_w;
 223       Unix.close err_w;
 224       let buf = String.create 1024 in
 225       let rec aux = function
 226         | f::tl ->
 227             let len = Unix.read f buf 0 1024 in
 228             if len = 0 then
 229               raise CHILD_DEAD;
 230             vt100 (String.sub buf 0 len);
 231             aux tl
 232         | _ -> ()
 233       in
 234       while true do
 235         let r,_,_ = Unix.select [out_r; err_r] [] [] (-. 1.) in
 236         aux r;
 237         refresh_cb ()
 238       done;
 239       true
 240     with CHILD_DEAD ->
 241       ignore(Sys.signal Sys.sigchld (Sys.Signal_ignore));
 242       let _, status = Unix.waitpid [] !pid in
 243       match status with | Unix.WEXITED 0 -> true | _ -> false)
 244
 245
 246 let build_development_in_bg ?(target="all") refresh_cb development =
 247   call_make development target (mk_maker refresh_cb)
 248 ;;
 249
 250 let clean_development development =
 251   call_make development "clean" make
 252
 253 let clean_development_in_bg refresh_cb development =
 254   call_make development "clean" (mk_maker refresh_cb)
 255
 256 let destroy_development development =
 257   let delete_development development =
 258     let unlink file =
 259       try
 260         Unix.unlink file
 261       with Unix.Unix_error _ -> logger `Debug ("Unable to delete " ^ file)
 262     in
 263     let rmdir dir =
 264       try
 265         Unix.rmdir dir
 266       with Unix.Unix_error _ ->
 267         logger `Warning ("Unable to remove dir " ^ dir);
 268         match ls_dir dir with
 269         | None -> logger `Error ("Unable to list directory " ^ dir)
 270         | Some [] -> ()
 271         | Some l -> logger `Error ("The directory is not empty")
 272     in
 273     unlink (makefile_for_development development);
 274     unlink (pool () ^ development.name ^ rootfile);
 275     unlink (pool () ^ development.name ^ "/depend");
 276     unlink (pool () ^ development.name ^ "/depend.short");
 277     rmdir (pool () ^ development.name);
 278     developments :=
 279       List.filter (fun d -> d.name <> development.name) !developments
 280   in
 281   if not(clean_development development) then
 282     begin
 283       logger `Warning "Unable to clean the development problerly.";
 284       logger `Warning "This may cause garbage."
 285     end;
 286   delete_development development
 287
 288 let root_for_development development = development.root
 289 let name_for_development development = development.name
 290