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
38 { root: string ; name: string }
40 let developments = ref []
42 let pool () = Helm_registry.get "matita.basedir" ^ "/matitamake/" ;;
43 let rootfile = "/root" ;;
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
51 | he::".."::tl -> aux tl
52 | he::"."::tl -> aux (he::tl)
53 | he::tl -> he :: aux tl
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 "")
62 let d = Unix.opendir dir in
63 let content = ref [] in
66 let name = Unix.readdir d in
67 if name <> "." && name <> ".." then
68 content := name :: !content
71 with End_of_file -> Unix.closedir d; Some !content
72 with Unix.Unix_error _ -> None
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 ())
85 Some (HExtlib.input_file (pool () ^ name ^ rootfile))
86 with Unix.Unix_error _ ->
87 logger `Warning ("Malformed development " ^ name);
93 developments := {root = root ; name = name} :: !developments;
94 let inc = Helm_registry.get_list
95 Helm_registry.string "matita.includes" in
96 Helm_registry.set_list Helm_registry.of_string
97 ~key:"matita.includes" ~value:(inc @ [root])
101 (* finds the makefile path for development devel *)
102 let makefile_for_development devel =
103 let develdir = pool () ^ devel.name in
104 develdir ^ "/makefile"
106 let dot_for_development devel =
107 let dot_fname = pool () ^ devel.name ^ "/depend.dot" in
108 if Sys.file_exists dot_fname then Some dot_fname else None
110 (* given a dir finds a development that is radicated in it or below *)
111 let development_for_dir dir =
112 let dir = normalize_path dir in
113 let is_prefix_of d1 d2 =
114 let len1 = String.length d1 in
115 let len2 = String.length d2 in
119 let pref = String.sub d2 0 len1 in
120 pref = d1 && (len1 = len2 || d2.[len1] = '/')
123 Some (List.find (fun d -> is_prefix_of d.root dir) !developments)
124 with Not_found | Failure _ -> None
126 let development_for_name name =
128 Some (List.find (fun d -> d.name = name) !developments)
129 with Not_found -> None
131 (* dumps the deveopment to disk *)
132 let dump_development devel =
133 let devel_dir = pool () ^ devel.name in
134 HExtlib.mkdir devel_dir;
135 HExtlib.output_file ~filename:(devel_dir ^ rootfile) ~text:devel.root
137 let list_known_developments () =
138 List.map (fun r -> r.name,r.root) !developments
140 let am_i_opt = lazy (
141 if Pcre.pmatch ~pat:"\\.opt$" Sys.argv.(0) then ".opt" else "")
143 let rebuild_makefile development =
144 let makefilepath = makefile_for_development development in
146 HExtlib.input_file BuildTimeConf.matitamake_makefile_template
148 let ext = Lazy.force am_i_opt in
150 if HExtlib.is_executable
151 (BuildTimeConf.runtime_base_dir ^ "/matitac" ^ ext)
152 then BuildTimeConf.runtime_base_dir ^ "/" else ""
154 let cc = binpath ^ "matitac" ^ ext in
155 let rm = binpath ^ "matitaclean" ^ ext in
156 let mm = binpath ^ "matitadep" ^ ext in
157 let df = pool () ^ development.name ^ "/depend" in
158 let template = Pcre.replace ~pat:"@ROOT@" ~templ:development.root template in
159 let template = Pcre.replace ~pat:"@CC@" ~templ:cc template in
160 let template = Pcre.replace ~pat:"@DEP@" ~templ:mm template in
161 let template = Pcre.replace ~pat:"@DEPFILE@" ~templ:df template in
162 let template = Pcre.replace ~pat:"@CLEAN@" ~templ:rm template in
163 HExtlib.output_file ~filename:makefilepath ~text:template
165 let rebuild_makefile_devel development =
166 let path = development.root ^ "/makefile" in
167 if not (Sys.file_exists path) then
170 HExtlib.input_file BuildTimeConf.matitamake_makefile_template_devel
173 Pcre.replace ~pat:"@MATITA_RT_BASE_DIR@"
174 ~templ:BuildTimeConf.runtime_base_dir template
176 HExtlib.output_file ~filename:path ~text:template
179 (* creates a new development if possible *)
180 let initialize_development name dir =
181 let dir = normalize_path dir in
182 let name = Pcre.replace ~pat:" " ~templ:"_" name in
183 let dev = {name = name ; root = dir} in
184 dump_development dev;
185 rebuild_makefile dev;
186 rebuild_makefile_devel dev;
187 developments := dev :: !developments;
190 let make chdir args =
191 let old = Unix.getcwd () in
194 let cmd = String.concat " " ("make" :: List.map Filename.quote args) in
195 let rc = Unix.system cmd in
198 | Unix.WEXITED 0 -> true
199 | Unix.WEXITED i -> logger `Error ("make returned " ^ string_of_int i);false
200 | _ -> logger `Error "make STOPPED or SIGNALED!";false
201 with Unix.Unix_error (_,cmd,err) ->
202 logger `Warning ("Unix Error: " ^ cmd ^ ": " ^ err);
205 let call_make ?matita_flags development target make =
207 let already_defined =
208 match matita_flags with
209 | None -> (try Sys.getenv "MATITA_FLAGS" with Not_found -> "")
213 if Helm_registry.get_bool "matita.bench" then "-bench" else ""
215 let csc = try ["SRC=" ^ Sys.getenv "SRC"] with Not_found -> [] in
216 rebuild_makefile development;
217 let makefile = makefile_for_development development in
221 flags @ [ sprintf "MATITA_FLAGS=\"%s\"" matita_flags ]
222 with Not_found -> flags in
223 let flags = flags @ csc in
225 ["--no-print-directory"; "-s"; "-k"; "-f"; makefile; target] @ flags
227 (* prerr_endline (String.concat " " args); *)
228 make development.root args
230 let build_development ?matita_flags ?(target="all") development =
231 call_make ?matita_flags development target make
233 (* not really good vt100 *)
235 let rex = Pcre.regexp "
\e\\[[0-9;]+m" in
236 let rex_i = Pcre.regexp "^Info" in
237 let rex_w = Pcre.regexp "^Warning" in
238 let rex_e = Pcre.regexp "^Error" in
239 let rex_d = Pcre.regexp "^Debug" in
240 let rex_noendline = Pcre.regexp "\\n" in
241 let s = Pcre.replace ~rex:rex_noendline s in
242 let tokens = Pcre.split ~rex s in
243 let logger = ref HLog.message in
248 (if Pcre.pmatch ~rex:rex_i s then
249 logger := HLog.message
250 else if Pcre.pmatch ~rex:rex_w s then
252 else if Pcre.pmatch ~rex:rex_e s then
254 else if Pcre.pmatch ~rex:rex_d s then
263 let mk_maker refresh_cb =
265 let out_r,out_w = Unix.pipe () in
266 let err_r,err_w = Unix.pipe () in
268 let oldhandler = Sys.signal Sys.sigchld (Sys.Signal_ignore) in
270 (* prerr_endline (String.concat " " args); *)
271 let argv = Array.of_list ("make"::args) in
272 pid := Unix.create_process "make" argv Unix.stdin out_w err_w;
275 let buf = String.create 1024 in
276 let rec aux = function
278 let len = Unix.read f buf 0 1024 in
282 (Unix.EPIPE,"read","len = 0 (matita internal)"));
283 vt100 (String.sub buf 0 len);
288 let r,_,_ = Unix.select [out_r; err_r] [] [] (-. 1.) in
292 ignore(Sys.signal Sys.sigchld oldhandler);
295 | Unix.Unix_error (_,"read",_)
296 | Unix.Unix_error (_,"select",_) ->
297 ignore(Sys.signal Sys.sigchld oldhandler);
300 let build_development_in_bg ?matita_flags ?(target="all") refresh_cb development =
301 call_make ?matita_flags development target (mk_maker refresh_cb)
303 let clean_development ?matita_flags development =
304 call_make ?matita_flags development "clean" make
306 let clean_development_in_bg ?matita_flags refresh_cb development =
307 call_make development ?matita_flags "clean" (mk_maker refresh_cb)
309 let destroy_development_aux development clean_development =
310 let delete_development development =
311 let unlink = HExtlib.safe_remove in
315 with Unix.Unix_error _ ->
316 logger `Warning ("Unable to remove dir " ^ dir);
317 match ls_dir dir with
318 | None -> logger `Error ("Unable to list directory " ^ dir)
320 | Some l -> logger `Error ("The directory is not empty")
322 unlink (makefile_for_development development);
323 unlink (pool () ^ development.name ^ rootfile);
324 unlink (pool () ^ development.name ^ "/depend");
325 unlink (pool () ^ development.name ^ "/depend.errors");
326 unlink (pool () ^ development.name ^ "/depend.dot");
327 rmdir (pool () ^ development.name);
329 List.filter (fun d -> d.name <> development.name) !developments
331 if not(clean_development development) then
333 logger `Warning "Unable to clean the development problerly.";
334 logger `Warning "This may cause garbage."
336 delete_development development
338 let destroy_development ?matita_flags development =
339 destroy_development_aux development (clean_development ?matita_flags)
341 let destroy_development_in_bg ?matita_flags refresh development =
342 destroy_development_aux development
343 (clean_development_in_bg refresh ?matita_flags )
345 let root_for_development development = development.root
346 let name_for_development development = development.name
348 let publish_development_bstract build clean devel =
349 let matita_flags, matita_flags_system =
350 let orig_matita_flags =
351 try Sys.getenv "MATITA_FLAGS" with Not_found -> ""
353 "\"" ^ orig_matita_flags ^ "\"", "\"" ^ orig_matita_flags ^ " -system\""
355 HLog.message "cleaning the development before publishing";
356 if clean ~matita_flags devel then
358 HLog.message "rebuilding the development in 'system' space";
359 (* here we should use pristine metadata if we use sqlite *)
360 if build ~matita_flags:matita_flags_system devel then
362 HLog.message "publishing succeded";
367 HLog.error "building process failed, reverting";
368 if not (clean ~matita_flags devel) then
369 HLog.error "cleaning failed, end of the world (2)";
374 (HLog.error "unable to clean the development, publishing failed"; false)
376 let publish_development devel =
377 publish_development_bstract
378 (fun ~matita_flags devel -> build_development ~matita_flags devel)
379 (fun ~matita_flags devel -> clean_development ~matita_flags devel) devel
380 let publish_development_in_bg cb devel =
381 publish_development_bstract
382 (fun ~matita_flags devel -> build_development_in_bg cb ~matita_flags devel)
383 (fun ~matita_flags devel -> clean_development_in_bg cb ~matita_flags devel)