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 (* $Id$ *)
  27
  28 let logger = fun mark ->
  29   match mark with
  30   | `Error -> HLog.error
  31   | `Warning -> HLog.warn
  32   | `Debug -> HLog.debug
  33   | `Message -> HLog.message
  34 ;;
  35
  36 type development =
  37   { root: string ; name: string }
  38
  39 let developments = ref []
  40
  41 let pool () = Helm_registry.get "matita.basedir" ^ "/matitamake/" ;;
  42 let rootfile = "/root" ;;
  43
  44 let ls_dir dir =
  45   try
  46     let d = Unix.opendir dir in
  47     let content = ref [] in
  48     try
  49       while true do
  50         let name = Unix.readdir d in
  51         if name <> "." && name <> ".." then
  52           content := name :: !content
  53       done;
  54       Some []
  55     with End_of_file -> Unix.closedir d; Some !content
  56   with Unix.Unix_error _ -> None
  57
  58 let initialize () =
  59   (* create a base env if none *)
  60   HExtlib.mkdir (pool ());
  61   (* load developments *)
  62   match ls_dir (pool ()) with
  63   | None -> logger `Error ("Unable to list directory " ^ pool ())
  64   | Some l ->
  65       List.iter
  66         (fun name ->
  67           let root =
  68             try
  69               Some (HExtlib.input_file (pool () ^ name ^ rootfile))
  70             with Unix.Unix_error _ ->
  71               logger `Warning ("Malformed development " ^ name);
  72               None
  73           in
  74           match root with
  75           | None -> ()
  76           | Some root ->
  77               developments := {root = root ; name = name} :: !developments)
  78       l
  79
  80 (* finds the makefile path for development devel *)
  81 let makefile_for_development devel =
  82   let develdir = pool () ^ devel.name in
  83   develdir ^ "/makefile"
  84 ;;
  85
  86 (* given a dir finds a development that is radicated in it or below *)
  87 let development_for_dir dir =
  88   let is_prefix_of d1 d2 =
  89     let len1 = String.length d1 in
  90     let len2 = String.length d2 in
  91     if len2 < len1 then
  92       false
  93     else
  94       let pref = String.sub d2 0 len1 in
  95       pref = d1
  96   in
  97   (* it must be unique *)
  98   try
  99     Some (List.find (fun d -> is_prefix_of d.root dir) !developments)
 100   with Not_found -> None
 101 ;;
 102
 103 let development_for_name name =
 104   try
 105     Some (List.find (fun d -> d.name = name) !developments)
 106   with Not_found -> None
 107
 108 (* dumps the deveopment to disk *)
 109 let dump_development devel =
 110   let devel_dir = pool () ^ devel.name in
 111   HExtlib.mkdir devel_dir;
 112   HExtlib.output_file ~filename:(devel_dir ^ rootfile) ~text:devel.root
 113 ;;
 114
 115 let list_known_developments () =
 116   List.map (fun r -> r.name,r.root) !developments
 117
 118 let am_i_opt () =
 119   if Pcre.pmatch ~pat:"\\.opt$" Sys.argv.(0) then ".opt" else ""
 120
 121 let rebuild_makefile development =
 122   let makefilepath = makefile_for_development development in
 123   let template =
 124     HExtlib.input_file BuildTimeConf.matitamake_makefile_template
 125   in
 126   let cc = BuildTimeConf.runtime_base_dir ^ "/matitac" ^ am_i_opt () in
 127   let rm = BuildTimeConf.runtime_base_dir ^ "/matitaclean" ^ am_i_opt () in
 128   let mm = BuildTimeConf.runtime_base_dir ^ "/matitadep" ^ am_i_opt () in
 129   let df = pool () ^ development.name ^ "/depend" in
 130   let template = Pcre.replace ~pat:"@ROOT@" ~templ:development.root template in
 131   let template = Pcre.replace ~pat:"@CC@" ~templ:cc template in
 132   let template = Pcre.replace ~pat:"@DEP@" ~templ:mm template in
 133   let template = Pcre.replace ~pat:"@DEPFILE@" ~templ:df template in
 134   let template = Pcre.replace ~pat:"@CLEAN@" ~templ:rm template in
 135   HExtlib.output_file ~filename:makefilepath ~text:template
 136
 137 (* creates a new development if possible *)
 138 let initialize_development name dir =
 139   let name = Pcre.replace ~pat:" " ~templ:"_" name in
 140   let dev = {name = name ; root = dir} in
 141   match development_for_dir dir with
 142   | Some d ->
 143       logger `Error
 144         ("Directory " ^ dir ^ " is already handled by development " ^ d.name);
 145       logger `Error
 146         ("Development " ^ d.name ^ " is rooted in " ^ d.root);
 147       logger `Error
 148         (dir ^ " is a subdir of " ^ d.root);
 149       None
 150   | None ->
 151       dump_development dev;
 152       rebuild_makefile dev;
 153       developments := dev :: !developments;
 154       Some dev
 155
 156 let make chdir args =
 157   let old = Unix.getcwd () in
 158   try
 159     Unix.chdir chdir;
 160     let rc =
 161       Unix.system
 162         (String.concat " " ("make"::(List.map Filename.quote args)))
 163     in
 164     Unix.chdir old;
 165     match rc with
 166     | Unix.WEXITED 0 -> true
 167     | Unix.WEXITED i -> logger `Error ("make returned " ^ string_of_int i);false
 168     | _ -> logger `Error "make STOPPED or SIGNALED!";false
 169   with Unix.Unix_error (_,cmd,err) ->
 170     logger `Warning ("Unix Error: " ^ cmd ^ ": " ^ err);
 171     false
 172
 173 let call_make development target make =
 174   rebuild_makefile development;
 175   let makefile = makefile_for_development development in
 176   let nodb =
 177     Helm_registry.get_opt_default Helm_registry.bool ~default:false "db.nodb"
 178   in
 179   let flags = if nodb then ["NODB=true"] else [] in
 180   make development.root
 181     (["--no-print-directory"; "-s"; "-k"; "-f"; makefile; target]
 182     @ flags)
 183
 184 let build_development ?(target="all") development =
 185   call_make development target make
 186
 187 (* not really good vt100 *)
 188 let vt100 s =
 189   let rex = Pcre.regexp "\e\\[[0-9;]+m" in
 190   let rex_i = Pcre.regexp "^Info" in
 191   let rex_w = Pcre.regexp "^Warning" in
 192   let rex_e = Pcre.regexp "^Error" in
 193   let rex_d = Pcre.regexp "^Debug" in
 194   let rex_noendline = Pcre.regexp "\\n" in
 195   let s = Pcre.replace ~rex:rex_noendline s in
 196   let tokens = Pcre.split ~rex s in
 197   let logger = ref HLog.message in
 198   let rec aux =
 199     function
 200     | [] -> ()
 201     | s::tl ->
 202         (if Pcre.pmatch ~rex:rex_i s then
 203           logger := HLog.message
 204         else if Pcre.pmatch ~rex:rex_w s then
 205           logger := HLog.warn
 206         else if Pcre.pmatch ~rex:rex_e s then
 207           logger := HLog.error
 208         else if Pcre.pmatch ~rex:rex_d s then
 209           logger := HLog.debug
 210         else
 211           !logger s);
 212         aux tl
 213   in
 214   aux tokens
 215
 216
 217 let mk_maker refresh_cb =
 218   (fun chdir args ->
 219     let out_r,out_w = Unix.pipe () in
 220     let err_r,err_w = Unix.pipe () in
 221     let pid = ref ~-1 in
 222     ignore(Sys.signal Sys.sigchld (Sys.Signal_ignore));
 223     try
 224       let argv = Array.of_list ("make"::args) in
 225       pid := Unix.create_process "make" argv Unix.stdin out_w err_w;
 226       Unix.close out_w;
 227       Unix.close err_w;
 228       let buf = String.create 1024 in
 229       let rec aux = function
 230         | f::tl ->
 231             let len = Unix.read f buf 0 1024 in
 232             if len = 0 then
 233               raise
 234                 (Unix.Unix_error
 235                   (Unix.EPIPE,"read","len = 0 (matita internal)"));
 236             vt100 (String.sub buf 0 len);
 237             aux tl
 238         | _ -> ()
 239       in
 240       while true do
 241         let r,_,_ = Unix.select [out_r; err_r] [] [] (-. 1.) in
 242         aux r;
 243         refresh_cb ()
 244       done;
 245       true
 246     with
 247     | Unix.Unix_error (_,"read",_)
 248     | Unix.Unix_error (_,"select",_) -> true)
 249
 250 let build_development_in_bg ?(target="all") refresh_cb development =
 251   call_make development target (mk_maker refresh_cb)
 252 ;;
 253
 254 let clean_development development =
 255   call_make development "clean" make
 256
 257 let clean_development_in_bg refresh_cb development =
 258   call_make development "clean" (mk_maker refresh_cb)
 259
 260 let destroy_development_aux development clean_development =
 261   let delete_development development =
 262     let unlink file =
 263       try
 264         Unix.unlink file
 265       with Unix.Unix_error _ -> logger `Debug ("Unable to delete " ^ file)
 266     in
 267     let rmdir dir =
 268       try
 269         Unix.rmdir dir
 270       with Unix.Unix_error _ ->
 271         logger `Warning ("Unable to remove dir " ^ dir);
 272         match ls_dir dir with
 273         | None -> logger `Error ("Unable to list directory " ^ dir)
 274         | Some [] -> ()
 275         | Some l -> logger `Error ("The directory is not empty")
 276     in
 277     unlink (makefile_for_development development);
 278     unlink (pool () ^ development.name ^ rootfile);
 279     unlink (pool () ^ development.name ^ "/depend");
 280     rmdir (pool () ^ development.name);
 281     developments :=
 282       List.filter (fun d -> d.name <> development.name) !developments
 283   in
 284   if not(clean_development development) then
 285     begin
 286       logger `Warning "Unable to clean the development problerly.";
 287       logger `Warning "This may cause garbage."
 288     end;
 289   delete_development development
 290
 291 let destroy_development development =
 292   destroy_development_aux development clean_development
 293
 294 let destroy_development_in_bg refresh development =
 295   destroy_development_aux development (clean_development_in_bg refresh)
 296
 297 let root_for_development development = development.root
 298 let name_for_development development = development.name
 299