1 (* Copyright (C) 2005, HELM Team.
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.
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.
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.
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,
22 * For details, see the HELM World-Wide-Web page,
23 * http://helm.cs.unibo.it/
30 let logger = fun mark ->
32 | `Error -> HLog.error
33 | `Warning -> HLog.warn
34 | `Debug -> HLog.debug
35 | `Message -> HLog.message
39 { root: string ; name: string }
41 let developments = ref []
43 let pool () = Helm_registry.get "matita.basedir" ^ "/matitamake/" ;;
44 let rootfile = "/root" ;;
48 let d = Unix.opendir dir in
49 let content = ref [] in
52 let name = Unix.readdir d in
53 if name <> "." && name <> ".." then
54 content := name :: !content
57 with End_of_file -> Unix.closedir d; Some !content
58 with Unix.Unix_error _ -> None
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 ())
71 Some (HExtlib.input_file (pool () ^ name ^ rootfile))
72 with Unix.Unix_error _ ->
73 logger `Warning ("Malformed development " ^ name);
79 developments := {root = root ; name = name} :: !developments)
82 (* finds the makefile path for development devel *)
83 let makefile_for_development devel =
84 let develdir = pool () ^ devel.name in
85 develdir ^ "/makefile"
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
96 let pref = String.sub d2 0 len1 in
99 (* it must be unique *)
101 Some (List.find (fun d -> is_prefix_of d.root dir) !developments)
102 with Not_found -> None
105 let development_for_name name =
107 Some (List.find (fun d -> d.name = name) !developments)
108 with Not_found -> None
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
117 let list_known_developments () =
118 List.map (fun r -> r.name,r.root) !developments
121 if Pcre.pmatch ~pat:"\\.opt$" Sys.argv.(0) then ".opt" else ""
123 let rebuild_makefile development =
124 let makefilepath = makefile_for_development development in
126 HExtlib.input_file BuildTimeConf.matitamake_makefile_template
128 let cc = BuildTimeConf.runtime_base_dir ^ "/matitac" ^ am_i_opt () in
129 let rm = BuildTimeConf.runtime_base_dir ^ "/matitaclean" ^ am_i_opt () in
130 let mm = BuildTimeConf.runtime_base_dir ^ "/matitadep" ^ am_i_opt () in
131 let df = pool () ^ development.name ^ "/depend" in
132 let template = Pcre.replace ~pat:"@ROOT@" ~templ:development.root template in
133 let template = Pcre.replace ~pat:"@CC@" ~templ:cc template in
134 let template = Pcre.replace ~pat:"@DEP@" ~templ:mm template in
135 let template = Pcre.replace ~pat:"@DEPFILE@" ~templ:df template in
136 let template = Pcre.replace ~pat:"@CLEAN@" ~templ:rm template in
137 HExtlib.output_file ~filename:makefilepath ~text:template
139 (* creates a new development if possible *)
140 let initialize_development name dir =
141 let name = Pcre.replace ~pat:" " ~templ:"_" name in
142 let dev = {name = name ; root = dir} in
143 match development_for_dir dir with
146 ("Directory " ^ dir ^ " is already handled by development " ^ d.name);
148 ("Development " ^ d.name ^ " is rooted in " ^ d.root);
150 (dir ^ " is a subdir of " ^ d.root);
153 dump_development dev;
154 rebuild_makefile dev;
155 developments := dev :: !developments;
158 let make chdir args =
159 let old = Unix.getcwd () in
164 (String.concat " " ("make"::(List.map Filename.quote args)))
168 | Unix.WEXITED 0 -> true
169 | Unix.WEXITED i -> logger `Error ("make returned " ^ string_of_int i);false
170 | _ -> logger `Error "make STOPPED or SIGNALED!";false
171 with Unix.Unix_error (_,cmd,err) ->
172 logger `Warning ("Unix Error: " ^ cmd ^ ": " ^ err);
175 let call_make development target make =
176 rebuild_makefile development;
177 let makefile = makefile_for_development development in
179 Helm_registry.get_opt_default Helm_registry.bool ~default:false "db.nodb"
182 let flags = flags @ if nodb then ["NODB=true"] else [] in
185 flags @ [ sprintf "MATITA_FLAGS=\"%s\"" (Sys.getenv "MATITA_FLAGS") ]
186 with Not_found -> flags in
187 make development.root
188 (["--no-print-directory"; "-s"; "-k"; "-f"; makefile; target]
191 let build_development ?(target="all") development =
192 call_make development target make
194 (* not really good vt100 *)
196 let rex = Pcre.regexp "
\e\\[[0-9;]+m" in
197 let rex_i = Pcre.regexp "^Info" in
198 let rex_w = Pcre.regexp "^Warning" in
199 let rex_e = Pcre.regexp "^Error" in
200 let rex_d = Pcre.regexp "^Debug" in
201 let rex_noendline = Pcre.regexp "\\n" in
202 let s = Pcre.replace ~rex:rex_noendline s in
203 let tokens = Pcre.split ~rex s in
204 let logger = ref HLog.message in
209 (if Pcre.pmatch ~rex:rex_i s then
210 logger := HLog.message
211 else if Pcre.pmatch ~rex:rex_w s then
213 else if Pcre.pmatch ~rex:rex_e s then
215 else if Pcre.pmatch ~rex:rex_d s then
224 let mk_maker refresh_cb =
226 let out_r,out_w = Unix.pipe () in
227 let err_r,err_w = Unix.pipe () in
229 ignore(Sys.signal Sys.sigchld (Sys.Signal_ignore));
231 let argv = Array.of_list ("make"::args) in
232 pid := Unix.create_process "make" argv Unix.stdin out_w err_w;
235 let buf = String.create 1024 in
236 let rec aux = function
238 let len = Unix.read f buf 0 1024 in
242 (Unix.EPIPE,"read","len = 0 (matita internal)"));
243 vt100 (String.sub buf 0 len);
248 let r,_,_ = Unix.select [out_r; err_r] [] [] (-. 1.) in
254 | Unix.Unix_error (_,"read",_)
255 | Unix.Unix_error (_,"select",_) -> true)
257 let build_development_in_bg ?(target="all") refresh_cb development =
258 call_make development target (mk_maker refresh_cb)
261 let clean_development development =
262 call_make development "clean" make
264 let clean_development_in_bg refresh_cb development =
265 call_make development "clean" (mk_maker refresh_cb)
267 let destroy_development_aux development clean_development =
268 let delete_development development =
272 with Unix.Unix_error _ -> logger `Debug ("Unable to delete " ^ file)
277 with Unix.Unix_error _ ->
278 logger `Warning ("Unable to remove dir " ^ dir);
279 match ls_dir dir with
280 | None -> logger `Error ("Unable to list directory " ^ dir)
282 | Some l -> logger `Error ("The directory is not empty")
284 unlink (makefile_for_development development);
285 unlink (pool () ^ development.name ^ rootfile);
286 unlink (pool () ^ development.name ^ "/depend");
287 rmdir (pool () ^ development.name);
289 List.filter (fun d -> d.name <> development.name) !developments
291 if not(clean_development development) then
293 logger `Warning "Unable to clean the development problerly.";
294 logger `Warning "This may cause garbage."
296 delete_development development
298 let destroy_development development =
299 destroy_development_aux development clean_development
301 let destroy_development_in_bg refresh development =
302 destroy_development_aux development (clean_development_in_bg refresh)
304 let root_for_development development = development.root
305 let name_for_development development = development.name