Find file
Fetching contributors…
Cannot retrieve contributors at this time
398 lines (321 sloc) 12.3 KB
(***********************************************************************)
(* *)
(* ocamlbuild *)
(* *)
(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
(* *)
(* Copyright 2007 Institut National de Recherche en Informatique et *)
(* en Automatique. All rights reserved. This file is distributed *)
(* under the terms of the Q Public License version 1.0. *)
(* *)
(***********************************************************************)
(* Original author: Nicolas Pouillard *)
open My_std
open Format
open Log
open Pathname.Operators
module Resources = Set.Make(Pathname)
let print = Pathname.print
let equal = (=)
let compare = compare
let in_source_dir p =
if Pathname.is_implicit p then Pathname.pwd/p else invalid_arg (Printf.sprintf "in_source_dir: %S" p)
let in_build_dir p =
if Pathname.is_relative p then p
else invalid_arg (Printf.sprintf "in_build_dir: %S" p)
let clean_up_links entry =
if not !Options.make_links then entry else
Slurp.filter begin fun path name _ ->
let pathname = in_source_dir (path/name) in
if Pathname.link_to_dir pathname !Options.build_dir then
let z = Pathname.readlink pathname in
(* Here is one exception where one can use Sys.file_exists directly *)
(if not (Sys.file_exists z) then
Shell.rm pathname; false)
else true
end entry
let clean_up_link_to_build () =
Options.entry := Some(clean_up_links (the !Options.entry))
let source_dir_path_set_without_links_to_build =
lazy begin
clean_up_link_to_build ();
Slurp.fold (fun path name _ -> StringSet.add (path/name))
(the !Options.entry) StringSet.empty
end
let clean_links () =
if !*My_unix.is_degraded then
()
else
ignore (clean_up_link_to_build ())
let exists_in_source_dir p =
if !*My_unix.is_degraded then sys_file_exists (in_source_dir p)
else StringSet.mem p !*source_dir_path_set_without_links_to_build
let clean p = Shell.rm_f p
module Cache = struct
let clean () = Shell.chdir Pathname.pwd; Shell.rm_rf !Options.build_dir
type knowledge =
| Yes
| No
| Unknown
type suspension = (Command.t * (unit -> unit))
type build_status =
| Bbuilt
| Bcannot_be_built
| Bnot_built_yet
| Bsuspension of suspension
type cache_entry =
{ mutable built : build_status;
mutable changed : knowledge;
mutable dependencies : Resources.t }
let empty () =
{ built = Bnot_built_yet;
changed = Unknown;
dependencies = Resources.empty }
let print_knowledge f =
function
| Yes -> pp_print_string f "Yes"
| No -> pp_print_string f "No"
| Unknown -> pp_print_string f "Unknown"
let print_build_status f =
function
| Bbuilt -> pp_print_string f "Bbuilt"
| Bnot_built_yet -> pp_print_string f "Bnot_built_yet"
| Bcannot_be_built -> pp_print_string f "Bcannot_be_built"
| Bsuspension(cmd, _) ->
fprintf f "@[<2>Bsuspension(%a,@ (<fun> : unit -> unit))@]" Command.print cmd
let print_cache_entry f e =
fprintf f "@[<2>{ @[<2>built =@ %a@];@ @[<2>changed =@ %a@];@ @[<2>dependencies =@ %a@]@ }@]"
print_build_status e.built print_knowledge e.changed Resources.print e.dependencies
let cache = Hashtbl.create 103
let get r =
try Hashtbl.find cache r
with Not_found ->
let cache_entry = empty () in
Hashtbl.add cache r cache_entry; cache_entry
let fold_cache f x = Hashtbl.fold f cache x
let print_cache f () =
fprintf f "@[<hv0>@[<hv2>{:";
fold_cache begin fun k v () ->
fprintf f "@ @[<2>%a =>@ %a@];" print k print_cache_entry v
end ();
fprintf f "@]:}@]"
let print_graph f () =
fprintf f "@[<hv0>@[<hv2>{:";
fold_cache begin fun k v () ->
if not (Resources.is_empty v.dependencies) then
fprintf f "@ @[<2>%a =>@ %a@];" print k Resources.print v.dependencies
end ();
fprintf f "@]@ :}@]"
let resource_changed r =
dprintf 10 "resource_changed:@ %a" print r;
(get r).changed <- Yes
let external_is_up_to_date absolute_path =
let key = "Resource: " ^ absolute_path in
let digest = Digest.file absolute_path in
let is_up_to_date =
try
let digest' = Digest_cache.get key in
digest = digest'
with Not_found ->
false
in
is_up_to_date || (Digest_cache.put key digest; false)
let source_is_up_to_date r_in_source_dir r_in_build_dir =
let key = "Resource: " ^ r_in_source_dir in
let digest = Digest.file r_in_source_dir in
let r_is_up_to_date =
Pathname.exists r_in_build_dir &&
try
let digest' = Digest_cache.get key in
digest = digest'
with Not_found ->
false
in
r_is_up_to_date || (Digest_cache.put key digest; false)
let prod_is_up_to_date p =
let x = in_build_dir p in
not (exists_in_source_dir p) || Pathname.exists x && Pathname.same_contents x (in_source_dir p)
let rec resource_has_changed r =
let cache_entry = get r in
match cache_entry.changed with
| Yes -> true
| No -> false
| Unknown ->
let res =
match cache_entry.built with
| Bbuilt -> false
| Bsuspension _ -> assert false
| Bcannot_be_built -> false
| Bnot_built_yet -> not (prod_is_up_to_date r) in
let () = cache_entry.changed <- if res then Yes else No in res
let resource_state r = (get r).built
let resource_built r = (get r).built <- Bbuilt
let resource_failed r = (get r).built <- Bcannot_be_built
let import_in_build_dir r =
let cache_entry = get r in
let r_in_build_dir = in_build_dir r in
let r_in_source_dir = in_source_dir r in
if source_is_up_to_date r_in_source_dir r_in_build_dir then begin
dprintf 5 "%a exists and up to date" print r;
end else begin
dprintf 5 "%a exists in source dir -> import it" print r;
Shell.mkdir_p (Pathname.dirname r);
Pathname.copy r_in_source_dir r_in_build_dir;
cache_entry.changed <- Yes;
end;
cache_entry.built <- Bbuilt
let suspend_resource r cmd kont prods =
let cache_entry = get r in
match cache_entry.built with
| Bsuspension _ -> ()
| Bbuilt -> ()
| Bcannot_be_built -> assert false
| Bnot_built_yet ->
let kont = begin fun () ->
kont ();
List.iter begin fun prod ->
(get prod).built <- Bbuilt
end prods
end in cache_entry.built <- Bsuspension(cmd, kont)
let resume_suspension (cmd, kont) =
Command.execute cmd;
kont ()
let resume_resource r =
let cache_entry = get r in
match cache_entry.built with
| Bsuspension(s) -> resume_suspension s
| Bbuilt -> ()
| Bcannot_be_built -> ()
| Bnot_built_yet -> ()
let get_optional_resource_suspension r =
match (get r).built with
| Bsuspension cmd_kont -> Some cmd_kont
| Bbuilt | Bcannot_be_built | Bnot_built_yet -> None
let clear_resource_failed r = (get r).built <- Bnot_built_yet
let dependencies r = (get r).dependencies
let fold_dependencies f =
fold_cache (fun k v -> Resources.fold (f k) v.dependencies)
let add_dependency r s =
let cache_entry = get r in
cache_entry.dependencies <- Resources.add s cache_entry.dependencies
let print_dependencies = print_graph
end
let digest p =
let f = Pathname.to_string (in_build_dir p) in
let buf = Buffer.create 1024 in
Buffer.add_string buf f;
(if sys_file_exists f then Buffer.add_string buf (Digest.file f));
Digest.string (Buffer.contents buf)
let exists_in_build_dir p = Pathname.exists (in_build_dir p)
(*
type env = string
let split_percent s =
try
let pos = String.index s '%' in
Some (String.before s pos, String.after s (pos + 1))
with Not_found -> None
let extract prefix suffix s =
let lprefix = String.length prefix in
let lsuffix = String.length suffix in
let ls = String.length s in
if lprefix + lsuffix > ls then None else
let s' = String.sub s lprefix (ls - lsuffix - lprefix) in
if equal (prefix ^ s' ^ suffix) s then Some s' else None
let matchit r1 r2 =
match split_percent r1 with
| Some (x, y) -> extract x y r2
| _ -> if equal r1 r2 then Some "" else None
let rec subst percent r =
match split_percent r with
| Some (x, y) -> x ^ percent ^ y
| _ -> r
let print_env = pp_print_string
*)
(* Should normalize *)
let import x = Pathname.normalize x
module MetaPath : sig
type t
type env
val mk : (bool * string) -> t
val matchit : t -> string -> env option
val subst : env -> t -> string
val print_env : Format.formatter -> env -> unit
end = struct
open Glob_ast
type atoms = A of string | V of string * Glob.globber
type t = atoms list
type env = (string * string) list
exception No_solution
let mk (pattern_allowed, s) = List.map begin function
| `Var(var_name, globber) -> V(var_name, globber)
| `Word s -> A s
end (Lexers.path_scheme pattern_allowed (Lexing.from_string s))
let mk = memo mk
let match_prefix s pos prefix =
match String.contains_string s pos prefix with
| Some(pos') -> if pos = pos' then pos' + String.length prefix else raise No_solution
| None -> raise No_solution
let matchit p s =
let sl = String.length s in
let rec loop xs pos acc delta =
match xs with
| [] -> if pos = sl then acc else raise No_solution
| A prefix :: xs -> loop xs (match_prefix s pos prefix) acc 0
| V(var, patt) :: A s2 :: xs' ->
begin match String.contains_string s (pos + delta) s2 with
| Some(pos') ->
let matched = String.sub s pos (pos' - pos) in
if Glob.eval patt matched
then
try loop xs' (pos' + String.length s2) ((var, matched) :: acc) 0
with No_solution -> loop xs pos acc (pos' - pos + 1)
else loop xs pos acc (pos' - pos + 1)
| None -> raise No_solution
end
| [V(var, patt)] ->
let matched = String.sub s pos (sl - pos) in
if Glob.eval patt matched then (var, matched) :: acc else raise No_solution
| V _ :: _ -> assert false
in
try Some (loop p 0 [] 0)
with No_solution -> None
let pp_opt pp_elt f =
function
| None -> pp_print_string f "None"
| Some x -> Format.fprintf f "Some(%a)" pp_elt x
let print_env f env =
List.iter begin fun (k, v) ->
if k = "" then Format.fprintf f "%%=%s " v
else Format.fprintf f "%%(%s)=%s " k v
end env
(* let matchit p s =
let res = matchit p s in
Format.eprintf "matchit %S %S = %a@." p s (pp_opt print_env) res;
res
let _ = begin
assert (matchit "%(path)lib%(libname).a" "libfoo.a" <> None);
assert (matchit "%(path)lib%(libname).a" "path/libfoo.a" <> None);
assert (matchit "libfoo.a" "libfoo.a" <> None);
assert (matchit "lib%(libname).a" "libfoo.a" <> None);
assert (matchit "%(path)libfoo.a" "path/libfoo.a" <> None);
assert (matchit "foo%" "foobar" <> None);
exit 42
end;; *)
let subst env s =
String.concat "" begin
List.map begin fun x ->
match x with
| A atom -> atom
| V(var, _) -> List.assoc var env
end s
end
end
type env = MetaPath.env
type resource_pattern = (Pathname.t * MetaPath.t)
let print_pattern f (x, _) = Pathname.print f x
let import_pattern x = x, MetaPath.mk (true, x)
let matchit (_, p) x = MetaPath.matchit p x
let subst env s = MetaPath.subst env (MetaPath.mk (false, s))
let subst_any env s = MetaPath.subst env (MetaPath.mk (true, s))
let subst_pattern env (_, p) = MetaPath.subst env p
let print_env = MetaPath.print_env