]> matita.cs.unibo.it Git - helm.git/blob - helm/matita/matitamakeLib.ml
integrated Eric's patch for HTTP/1.1 persistant connections
[helm.git] / helm / 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 let logger = fun mark -> 
27   match mark with 
28   | `Error -> MatitaLog.error
29   | `Warning -> MatitaLog.warn
30   | `Debug -> MatitaLog.debug
31   | `Message -> MatitaLog.message
32 ;;
33
34 type development = 
35   { root: string ; name: string }
36
37 let developments = ref []
38   
39 let pool () = Helm_registry.get "matita.basedir" ^ "/matitamake/" ;;
40 let rootfile = "/root" ;;
41
42 let ls_dir dir = 
43   try
44     let d = Unix.opendir dir in
45     let content = ref [] in
46     try
47       while true do
48         let name = Unix.readdir d in
49         if name <> "." && name <> ".." then
50           content := name :: !content
51       done;
52       Some []
53     with End_of_file -> Unix.closedir d; Some !content
54   with Unix.Unix_error _ -> None
55
56 let initialize () = 
57   (* create a base env if none *)
58   MatitaMisc.mkdir (pool ());
59   (* load developments *)
60   match ls_dir (pool ()) with
61   | None -> logger `Error ("Unable to list directory " ^ pool ()) 
62   | Some l -> 
63       List.iter 
64         (fun name -> 
65           let root = 
66             try 
67               Some (MatitaMisc.input_file (pool () ^ name ^ rootfile))
68             with Unix.Unix_error _ -> 
69               logger `Warning ("Malformed development " ^ name);
70               None
71           in 
72           match root with 
73           | None -> ()
74           | Some root -> 
75               developments := {root = root ; name = name} :: !developments) 
76       l
77
78 (* finds the makefile path for development devel *)
79 let makefile_for_development devel =
80   let develdir = pool () ^ devel.name in
81   develdir ^ "/makefile"
82 ;;
83
84 (* given a dir finds a development that is radicated in it or below *)
85 let development_for_dir dir =
86   let is_prefix_of d1 d2 =
87     let len1 = String.length d1 in
88     let len2 = String.length d2 in
89     if len2 < len1 then 
90       false
91     else
92       let pref = String.sub d2 0 len1 in
93       pref = d1
94   in
95   (* it must be unique *)
96   try
97     Some (List.find (fun d -> is_prefix_of d.root dir) !developments)
98   with Not_found -> None
99 ;;
100
101 let development_for_name name =
102   try 
103     Some (List.find (fun d -> d.name = name) !developments)
104   with Not_found -> None
105
106 (* dumps the deveopment to disk *)
107 let dump_development devel =
108   let devel_dir = pool () ^ devel.name in 
109   MatitaMisc.mkdir devel_dir;
110   MatitaMisc.output_file devel.root (devel_dir ^ rootfile);
111 ;;
112
113 let list_known_developments () = 
114   List.map (fun r -> r.name,r.root) !developments
115
116 let am_i_opt () = 
117   if Pcre.pmatch ~pat:"\\.opt$" Sys.argv.(0) then ".opt" else ""
118   
119 let rebuild_makefile development = 
120   let makefilepath = makefile_for_development development in
121   let template = 
122     MatitaMisc.input_file BuildTimeConf.matitamake_makefile_template 
123   in
124   let cc = BuildTimeConf.runtime_base_dir ^ "/matitac" ^ am_i_opt () in
125   let rm = BuildTimeConf.runtime_base_dir ^ "/matitaclean" ^ am_i_opt () in
126   let mm = BuildTimeConf.runtime_base_dir ^ "/matitadep" ^ am_i_opt () in
127   let df = pool () ^ development.name ^ "/depend" in
128   let template = Pcre.replace ~pat:"@ROOT@" ~templ:development.root template in
129   let template = Pcre.replace ~pat:"@CC@" ~templ:cc template in
130   let template = Pcre.replace ~pat:"@DEP@" ~templ:mm template in
131   let template = Pcre.replace ~pat:"@DEPFILE@" ~templ:df template in
132   let template = Pcre.replace ~pat:"@CLEAN@" ~templ:rm template in
133   MatitaMisc.output_file template makefilepath
134   
135 (* creates a new development if possible *)
136 let initialize_development name dir =
137   let name = Pcre.replace ~pat:" " ~templ:"_" name in 
138   let dev = {name = name ; root = dir} in
139   match development_for_dir dir with
140   | Some d ->
141       logger `Error 
142         ("Directory " ^ dir ^ " is already handled by development " ^ d.name);
143       logger `Error
144         ("Development " ^ d.name ^ " is rooted in " ^ d.root); 
145       logger `Error
146         (dir ^ " is a subdir of " ^ d.root);
147       None
148   | None -> 
149       dump_development dev;
150       rebuild_makefile dev;
151       developments := dev :: !developments;
152       Some dev
153
154 let make chdir args = 
155   let old = Unix.getcwd () in
156   try
157     Unix.chdir chdir;
158     let rc = 
159       Unix.system 
160         (String.concat " " ("make"::(List.map Filename.quote args)))
161     in
162     Unix.chdir old;
163     match rc with
164     | Unix.WEXITED 0 -> true
165     | Unix.WEXITED i -> logger `Error ("make returned " ^ string_of_int i);false
166     | _ -> logger `Error "make STOPPED or SIGNALED!";false
167   with Unix.Unix_error (_,cmd,err) -> 
168     logger `Warning ("Unix Error: " ^ cmd ^ ": " ^ err);
169     false
170       
171 let call_make development target make =
172   rebuild_makefile development;
173   let makefile = makefile_for_development development in
174   make development.root 
175     ["--no-print-directory"; "-s"; "-k"; "-f"; makefile; target]
176       
177 let build_development ?(target="all") development =
178   call_make development target make
179
180 (* not really good vt100 *)
181 let vt100 s =
182   let rex = Pcre.regexp "\e\\[[0-9;]+m" in
183   let rex_i = Pcre.regexp "^Info" in
184   let rex_w = Pcre.regexp "^Warning" in
185   let rex_e = Pcre.regexp "^Error" in
186   let rex_d = Pcre.regexp "^Debug" in
187   let rex_noendline = Pcre.regexp "\\n" in
188   let s = Pcre.replace ~rex:rex_noendline s in
189   let len = String.length s in
190   let tokens = Pcre.split ~rex s in
191   let logger = ref MatitaLog.message in
192   let rec aux = 
193     function
194     | [] -> ()
195     | s::tl ->
196         (if Pcre.pmatch ~rex:rex_i s then
197           logger := MatitaLog.message
198         else if Pcre.pmatch ~rex:rex_w s then
199           logger := MatitaLog.warn
200         else if Pcre.pmatch ~rex:rex_e s then
201           logger := MatitaLog.error
202         else if Pcre.pmatch ~rex:rex_d s then
203           logger := MatitaLog.debug
204         else 
205           !logger s);
206         aux tl
207   in
208   aux tokens
209   
210
211 let mk_maker refresh_cb =
212   (fun chdir args ->
213     let out_r,out_w = Unix.pipe () in
214     let err_r,err_w = Unix.pipe () in
215     let pid = ref ~-1 in
216     ignore(Sys.signal Sys.sigchld (Sys.Signal_ignore));
217     try 
218       let argv = Array.of_list ("make"::args) in
219       pid := Unix.create_process "make" argv Unix.stdin out_w err_w;
220       Unix.close out_w;
221       Unix.close err_w;
222       let buf = String.create 1024 in
223       let rec aux = function 
224         | f::tl ->
225             let len = Unix.read f buf 0 1024 in
226             if len = 0 then 
227               raise 
228                 (Unix.Unix_error 
229                   (Unix.EPIPE,"read","len = 0 (matita internal)"));
230             vt100 (String.sub buf 0 len);
231             aux tl
232         | _ -> ()
233       in
234       while true do
235         let r,_,_ = Unix.select [out_r; err_r] [] [] (-. 1.) in
236         aux r;
237         refresh_cb ()
238       done;
239       true
240     with 
241     | Unix.Unix_error (_,"read",_)
242     | Unix.Unix_error (_,"select",_) -> true)
243
244 let build_development_in_bg ?(target="all") refresh_cb development =
245   call_make development target (mk_maker refresh_cb)
246 ;;
247
248 let clean_development development =
249   call_make development "clean" make
250
251 let clean_development_in_bg refresh_cb development =
252   call_make development "clean" (mk_maker refresh_cb)
253
254 let destroy_development_aux development clean_development =
255   let delete_development development = 
256     let unlink file =
257       try 
258         Unix.unlink file 
259       with Unix.Unix_error _ -> logger `Debug ("Unable to delete " ^ file)
260     in
261     let rmdir dir =
262       try
263         Unix.rmdir dir 
264       with Unix.Unix_error _ -> 
265         logger `Warning ("Unable to remove dir " ^ dir);
266         match ls_dir dir with
267         | None -> logger `Error ("Unable to list directory " ^ dir) 
268         | Some [] -> ()
269         | Some l -> logger `Error ("The directory is not empty")
270     in
271     unlink (makefile_for_development development);
272     unlink (pool () ^ development.name ^ rootfile);
273     unlink (pool () ^ development.name ^ "/depend");
274     rmdir (pool () ^ development.name);
275     developments := 
276       List.filter (fun d -> d.name <> development.name) !developments
277   in
278   if not(clean_development development) then
279     begin
280       logger `Warning "Unable to clean the development problerly.";
281       logger `Warning "This may cause garbage."
282     end;
283   delete_development development 
284  
285 let destroy_development development = 
286   destroy_development_aux development clean_development
287
288 let destroy_development_in_bg refresh development = 
289   destroy_development_aux development (clean_development_in_bg refresh) 
290   
291 let root_for_development development = development.root
292 let name_for_development development = development.name
293