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