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