]> matita.cs.unibo.it Git - helm.git/blob - helm/software/matita/matitamakeLib.ml
carabinieri almost done
[helm.git] / 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