ocamlbuild/resource.ml

   1 (***********************************************************************)
   2 (*                             ocamlbuild                              *)
   3 (*                                                                     *)
   4 (*  Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
   5 (*                                                                     *)
   6 (*  Copyright 2007 Institut National de Recherche en Informatique et   *)
   7 (*  en Automatique.  All rights reserved.  This file is distributed    *)
   8 (*  under the terms of the Q Public License version 1.0.               *)
   9 (*                                                                     *)
  10 (***********************************************************************)
  11
  12 (* $Id$ *)
  13 (* Original author: Nicolas Pouillard *)
  14 open My_std
  15 open Format
  16 open Log
  17 open Pathname.Operators
  18
  19 module Resources = Set.Make(Pathname)
  20
  21 let print = Pathname.print
  22
  23 let equal = (=)
  24 let compare = compare
  25
  26 let in_source_dir p =
  27   if Pathname.is_implicit p then Pathname.pwd/p else invalid_arg (Printf.sprintf "in_source_dir: %S" p)
  28
  29 let in_build_dir p =
  30   if Pathname.is_relative p then p
  31   else invalid_arg (Printf.sprintf "in_build_dir: %S" p)
  32
  33 let clean_up_links entry =
  34   if not !Options.make_links then entry else
  35   Slurp.filter begin fun path name _ ->
  36     let pathname = in_source_dir (path/name) in
  37     if Pathname.link_to_dir pathname !Options.build_dir then
  38       let z = Pathname.readlink pathname in
  39       (* Here is one exception where one can use Sys.file_exists directly *)
  40       (if not (Sys.file_exists z) then
  41         Shell.rm pathname; false)
  42     else true
  43   end entry
  44
  45 let clean_up_link_to_build () =
  46   Options.entry := Some(clean_up_links (the !Options.entry))
  47
  48 let source_dir_path_set_without_links_to_build =
  49   lazy begin
  50     clean_up_link_to_build ();
  51     Slurp.fold (fun path name _ -> StringSet.add (path/name))
  52                (the !Options.entry) StringSet.empty
  53   end
  54
  55 let clean_links () =
  56   if !*My_unix.is_degraded then
  57     ()
  58   else
  59     ignore (clean_up_link_to_build ())
  60
  61 let exists_in_source_dir p =
  62   if !*My_unix.is_degraded then sys_file_exists (in_source_dir p)
  63   else StringSet.mem p !*source_dir_path_set_without_links_to_build
  64
  65 let clean p = Shell.rm_f p
  66
  67 module Cache = struct
  68
  69   let clean () = Shell.chdir Pathname.pwd; Shell.rm_rf !Options.build_dir
  70
  71   type knowledge =
  72     | Yes
  73     | No
  74     | Unknown
  75
  76   type suspension = (Command.t * (unit -> unit))
  77
  78   type build_status =
  79     | Bbuilt
  80     | Bcannot_be_built
  81     | Bnot_built_yet
  82     | Bsuspension of suspension
  83
  84   type cache_entry =
  85     { mutable built        : build_status;
  86       mutable changed      : knowledge;
  87       mutable dependencies : Resources.t }
  88
  89   let empty () =
  90     { built        = Bnot_built_yet;
  91       changed      = Unknown;
  92       dependencies = Resources.empty }
  93
  94   let print_knowledge f =
  95     function
  96     | Yes -> pp_print_string f "Yes"
  97     | No  -> pp_print_string f "No"
  98     | Unknown -> pp_print_string f "Unknown"
  99
 100   let print_build_status f =
 101     function
 102     | Bbuilt -> pp_print_string f "Bbuilt"
 103     | Bnot_built_yet -> pp_print_string f "Bnot_built_yet"
 104     | Bcannot_be_built -> pp_print_string f "Bcannot_be_built"
 105     | Bsuspension(cmd, _) ->
 106         fprintf f "@[<2>Bsuspension(%a,@ (<fun> : unit -> unit))@]" Command.print cmd
 107
 108   let print_cache_entry f e =
 109     fprintf f "@[<2>{ @[<2>built =@ %a@];@ @[<2>changed =@ %a@];@ @[<2>dependencies =@ %a@]@ }@]"
 110       print_build_status e.built print_knowledge e.changed Resources.print e.dependencies
 111
 112   let cache = Hashtbl.create 103
 113
 114   let get r =
 115     try Hashtbl.find cache r
 116     with Not_found ->
 117       let cache_entry = empty () in
 118       Hashtbl.add cache r cache_entry; cache_entry
 119
 120   let fold_cache f x = Hashtbl.fold f cache x
 121
 122   let print_cache f () =
 123     fprintf f "@[<hv0>@[<hv2>{:";
 124     fold_cache begin fun k v () ->
 125       fprintf f "@ @[<2>%a =>@ %a@];" print k print_cache_entry v
 126     end ();
 127     fprintf f "@]:}@]"
 128
 129   let print_graph f () =
 130     fprintf f "@[<hv0>@[<hv2>{:";
 131     fold_cache begin fun k v () ->
 132       if not (Resources.is_empty v.dependencies) then
 133         fprintf f "@ @[<2>%a =>@ %a@];" print k Resources.print v.dependencies
 134     end ();
 135     fprintf f "@]@ :}@]"
 136
 137   let resource_changed r =
 138     dprintf 10 "resource_changed:@ %a" print r;
 139     (get r).changed <- Yes
 140
 141   let external_is_up_to_date absolute_path =
 142     let key = "Resource: " ^ absolute_path in
 143     let digest = Digest.file absolute_path in
 144     let is_up_to_date =
 145       try
 146         let digest' = Digest_cache.get key in
 147         digest = digest'
 148       with Not_found ->
 149         false
 150     in
 151     is_up_to_date || (Digest_cache.put key digest; false)
 152
 153   let source_is_up_to_date r_in_source_dir r_in_build_dir =
 154     let key = "Resource: " ^ r_in_source_dir in
 155     let digest = Digest.file r_in_source_dir in
 156     let r_is_up_to_date =
 157       Pathname.exists r_in_build_dir &&
 158       try
 159         let digest' = Digest_cache.get key in
 160         digest = digest'
 161       with Not_found ->
 162         false
 163     in
 164     r_is_up_to_date || (Digest_cache.put key digest; false)
 165
 166   let prod_is_up_to_date p =
 167     let x = in_build_dir p in
 168     not (exists_in_source_dir p) || Pathname.exists x && Pathname.same_contents x (in_source_dir p)
 169
 170   let rec resource_has_changed r =
 171     let cache_entry = get r in
 172     match cache_entry.changed with
 173     | Yes -> true
 174     | No -> false
 175     | Unknown ->
 176       let res =
 177         match cache_entry.built with
 178         | Bbuilt -> false
 179         | Bsuspension _ -> assert false
 180         | Bcannot_be_built -> false
 181         | Bnot_built_yet -> not (prod_is_up_to_date r) in
 182       let () = cache_entry.changed <- if res then Yes else No in res
 183
 184   let resource_state r = (get r).built
 185
 186   let resource_built r = (get r).built <- Bbuilt
 187
 188   let resource_failed r = (get r).built <- Bcannot_be_built
 189
 190   let import_in_build_dir r =
 191     let cache_entry = get r in
 192     let r_in_build_dir = in_build_dir r in
 193     let r_in_source_dir = in_source_dir r in
 194     if source_is_up_to_date r_in_source_dir r_in_build_dir then begin
 195       dprintf 5 "%a exists and up to date" print r;
 196     end else begin
 197       dprintf 5 "%a exists in source dir -> import it" print r;
 198       Shell.mkdir_p (Pathname.dirname r);
 199       Pathname.copy r_in_source_dir r_in_build_dir;
 200       cache_entry.changed <- Yes;
 201     end;
 202     cache_entry.built <- Bbuilt
 203
 204   let suspend_resource r cmd kont prods =
 205     let cache_entry = get r in
 206     match cache_entry.built with
 207     | Bsuspension _ -> ()
 208     | Bbuilt -> ()
 209     | Bcannot_be_built -> assert false
 210     | Bnot_built_yet ->
 211         let kont = begin fun () ->
 212           kont ();
 213           List.iter begin fun prod ->
 214             (get prod).built <- Bbuilt
 215           end prods
 216         end in cache_entry.built <- Bsuspension(cmd, kont)
 217
 218   let resume_suspension (cmd, kont) =
 219     Command.execute cmd;
 220     kont ()
 221
 222   let resume_resource r =
 223     let cache_entry = get r in
 224     match cache_entry.built with
 225     | Bsuspension(s) -> resume_suspension s
 226     | Bbuilt -> ()
 227     | Bcannot_be_built -> ()
 228     | Bnot_built_yet -> ()
 229
 230   let get_optional_resource_suspension r =
 231     match (get r).built with
 232     | Bsuspension cmd_kont -> Some cmd_kont
 233     | Bbuilt | Bcannot_be_built | Bnot_built_yet -> None
 234
 235   let clear_resource_failed r = (get r).built <- Bnot_built_yet
 236
 237   let dependencies r = (get r).dependencies
 238
 239   let fold_dependencies f =
 240     fold_cache (fun k v -> Resources.fold (f k) v.dependencies)
 241
 242   let add_dependency r s =
 243     let cache_entry = get r in
 244     cache_entry.dependencies <- Resources.add s cache_entry.dependencies
 245
 246   let print_dependencies = print_graph
 247
 248 end
 249
 250 let digest p =
 251   let f = Pathname.to_string (in_build_dir p) in
 252   let buf = Buffer.create 1024 in
 253   Buffer.add_string buf f;
 254   (if sys_file_exists f then Buffer.add_string buf (Digest.file f));
 255   Digest.string (Buffer.contents buf)
 256
 257 let exists_in_build_dir p = Pathname.exists (in_build_dir p)
 258
 259 (*
 260 type env = string
 261
 262 let split_percent s =
 263   try
 264     let pos = String.index s '%' in
 265     Some (String.before s pos, String.after s (pos + 1))
 266   with Not_found -> None
 267
 268 let extract prefix suffix s =
 269   let lprefix = String.length prefix in
 270   let lsuffix = String.length suffix in
 271   let ls = String.length s in
 272   if lprefix + lsuffix > ls then None else
 273   let s' = String.sub s lprefix (ls - lsuffix - lprefix) in
 274   if equal (prefix ^ s' ^ suffix) s then Some s' else None
 275
 276 let matchit r1 r2 =
 277   match split_percent r1 with
 278   | Some (x, y) -> extract x y r2
 279   | _ -> if equal r1 r2 then Some "" else None
 280
 281 let rec subst percent r =
 282   match split_percent r with
 283   | Some (x, y) -> x ^ percent ^ y
 284   | _ -> r
 285
 286 let print_env = pp_print_string
 287 *)
 288
 289 (* Should normalize *)
 290 let import x = Pathname.normalize x
 291
 292 module MetaPath : sig
 293
 294         type t
 295         type env
 296
 297         val mk : (bool * string) -> t
 298         val matchit : t -> string -> env option
 299         val subst : env -> t -> string
 300         val print_env : Format.formatter -> env -> unit
 301
 302 end = struct
 303         open Glob_ast
 304
 305         type atoms = A of string | V of string * Glob.globber
 306         type t = atoms list
 307         type env = (string * string) list
 308
 309         exception No_solution
 310
 311         let mk (pattern_allowed, s) = List.map begin function
 312           | `Var(var_name, globber) -> V(var_name, globber)
 313           | `Word s -> A s
 314         end (Lexers.path_scheme pattern_allowed (Lexing.from_string s))
 315
 316         let mk = memo mk
 317
 318         let match_prefix s pos prefix =
 319                 match String.contains_string s pos prefix with
 320                 | Some(pos') -> if pos = pos' then pos' + String.length prefix else raise No_solution
 321                 | None -> raise No_solution
 322
 323         let matchit p s =
 324           let sl = String.length s in
 325                 let rec loop xs pos acc delta =
 326                         match xs with
 327                         | [] -> if pos = sl then acc else raise No_solution
 328                         | A prefix :: xs -> loop xs (match_prefix s pos prefix) acc 0
 329                         | V(var, patt) :: A s2 :: xs' ->
 330                             begin match String.contains_string s (pos + delta) s2 with
 331                             | Some(pos') ->
 332                                 let matched = String.sub s pos (pos' - pos) in
 333                                 if Glob.eval patt matched
 334                                 then
 335                                   try loop xs' (pos' + String.length s2) ((var, matched) :: acc) 0
 336                                   with No_solution -> loop xs  pos acc (pos' - pos + 1)
 337                                 else loop xs  pos acc (pos' - pos + 1)
 338                             | None -> raise No_solution
 339                             end
 340                         | [V(var, patt)] ->
 341                             let matched = String.sub s pos (sl - pos) in
 342                             if Glob.eval patt matched then (var, matched) :: acc else raise No_solution
 343                         | V _ :: _ -> assert false
 344                 in
 345                 try     Some (loop p 0 [] 0)
 346                 with No_solution -> None
 347
 348   let pp_opt pp_elt f =
 349     function
 350     | None -> pp_print_string f "None"
 351     | Some x -> Format.fprintf f "Some(%a)" pp_elt x
 352
 353   let print_env f env =
 354     List.iter begin fun (k, v) ->
 355       if k = "" then Format.fprintf f "%%=%s " v
 356       else Format.fprintf f "%%(%s)=%s " k v
 357     end env
 358
 359   (* let matchit p s =
 360     let res = matchit p s in
 361       Format.eprintf "matchit %S %S = %a@." p s (pp_opt print_env) res;
 362     res
 363
 364   let _ = begin
 365     assert (matchit "%(path)lib%(libname).a" "libfoo.a" <> None);
 366     assert (matchit "%(path)lib%(libname).a" "path/libfoo.a" <> None);
 367     assert (matchit "libfoo.a" "libfoo.a" <> None);
 368     assert (matchit "lib%(libname).a" "libfoo.a" <> None);
 369     assert (matchit "%(path)libfoo.a" "path/libfoo.a" <> None);
 370     assert (matchit "foo%" "foobar" <> None);
 371     exit 42
 372   end;; *)
 373
 374         let subst env s =
 375                 String.concat "" begin
 376                         List.map begin fun x ->
 377                                 match x with
 378                                 | A atom -> atom
 379                                 | V(var, _) -> List.assoc var env
 380                         end s
 381                 end
 382 end
 383
 384 type env = MetaPath.env
 385 type resource_pattern = (Pathname.t * MetaPath.t)
 386
 387 let print_pattern f (x, _) = Pathname.print f x
 388
 389 let import_pattern x = x, MetaPath.mk (true, x)
 390 let matchit (_, p) x = MetaPath.matchit p x
 391
 392 let subst env s = MetaPath.subst env (MetaPath.mk (false, s))
 393 let subst_any env s = MetaPath.subst env (MetaPath.mk (true, s))
 394 let subst_pattern env (_, p) = MetaPath.subst env p
 395
 396 let print_env = MetaPath.print_env