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