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