ocaml/yes_prepare_ocamlcocci.ml

   1 (* Note: this module passes paths to other commands, but does not take
   2  * quoting into account. Thus, if these paths contain spaces, it's likely
   3  * that things go wrong.
   4  *)
   5
   6 module Ast = Ast_cocci
   7
   8 exception CompileFailure of string
   9 exception LinkFailure of string
  10
  11 let ext = if Config.dynlink_is_native then ".cmxs" else ".cma"
  12
  13 let sysdir () =
  14   let sysdircmd = !Flag.ocamlfind ^ " printconf stdlib" in
  15   match Common.cmd_to_list sysdircmd with
  16     [sysdir] -> sysdir
  17   | _ -> raise (CompileFailure (sysdircmd ^" has failed"))
  18
  19 let check_cmd cmd =
  20   let (_,stat) = Common.cmd_to_list_and_status cmd in
  21   match stat with
  22       Unix.WEXITED 0 -> true
  23     | _ -> false
  24
  25 (* this function does not work when the executable has an extension like .exe *)
  26 let to_opt cmd =
  27   let n = String.length cmd in
  28   if n > 4 && String.compare (String.sub cmd (n-4) 4) ".opt" == 0
  29   then cmd
  30   else cmd ^ ".opt"
  31
  32 let check_runtime () =
  33   let has_opt  = check_cmd (to_opt (!Flag.ocamlc) ^ " -version 2>&1 > /dev/null") in
  34   let has_c    = check_cmd (!Flag.ocamlc ^ " -version 2>&1 > /dev/null") in
  35     if has_opt then
  36       begin
  37         Flag.ocamlc   := to_opt (!Flag.ocamlc);
  38         Flag.ocamlopt := to_opt (!Flag.ocamlopt);
  39         Flag.ocamldep := to_opt (!Flag.ocamldep);
  40         Common.pr2 "Using native version of ocamlc/ocamlopt/ocamldep"
  41       end
  42     else
  43       if has_c then
  44         Common.pr2 "Using bytecode version of ocamlc/ocamlopt/ocamldep"
  45       else
  46         if Config.dynlink_is_native then
  47           failwith
  48             "No OCaml compiler found! Install either ocamlopt or ocamlopt.opt"
  49         else
  50           failwith
  51             "No OCaml compiler found! Install either ocamlc or ocamlc.opt"
  52
  53 let init_ocamlcocci _ =
  54   "open Coccilib\n"
  55
  56 let print_match ctr nm kind =
  57   let endlet = "| _ -> failwith \"bad value\" in\n" in
  58   let index = !ctr in
  59   ctr := !ctr + 1;
  60   Printf.sprintf
  61     "let %s = match List.nth args %d with Coccilib.%s x -> x %s"
  62     nm index kind endlet
  63
  64 let string_rep_binding ctr = function
  65     (Some nm,Ast.MetaPosDecl _) -> print_match ctr nm "Pos"
  66   | (Some nm,Ast.MetaListlenDecl _) -> print_match ctr nm "Int"
  67   | (Some nm,_) (* strings for everything else *) ->
  68       print_match ctr nm "Str"
  69   | (None,_) -> ""
  70
  71 let ast_rep_binding ctr = function
  72     (Some nm,Ast.MetaPosDecl _) ->
  73       failwith
  74         (Printf.sprintf "%s: No AST representation for position variables" nm)
  75   | (Some nm,Ast.MetaMetaDecl _) ->
  76       failwith
  77         (Printf.sprintf
  78            "%s: No AST representation for metavariables declared as \"%s\""
  79            "metavariable" nm)
  80   | (Some nm,Ast.MetaIdDecl _) -> print_match ctr nm "Str"
  81   | (Some nm,Ast.MetaFreshIdDecl _) -> print_match ctr nm "Str"
  82   | (Some nm,Ast.MetaTypeDecl _) -> print_match ctr nm "Type"
  83   | (Some nm,Ast.MetaInitDecl _) -> print_match ctr nm "Init"
  84   | (Some nm,Ast.MetaInitListDecl _) -> print_match ctr nm "InitList"
  85   | (Some nm,Ast.MetaListlenDecl _) ->
  86       failwith
  87         (Printf.sprintf "%s: No AST representation for listlen variables" nm)
  88   | (Some nm,Ast.MetaParamDecl _) -> print_match ctr nm "Param"
  89   | (Some nm,Ast.MetaParamListDecl _) -> print_match ctr nm "ParamList"
  90   | (Some nm,Ast.MetaConstDecl _) -> print_match ctr nm "Expr"
  91   | (Some nm,Ast.MetaErrDecl _) -> failwith ("not supported: "^nm)
  92   | (Some nm,Ast.MetaExpDecl _) -> print_match ctr nm "Expr"
  93   | (Some nm,Ast.MetaIdExpDecl _) -> print_match ctr nm "Expr"
  94   | (Some nm,Ast.MetaLocalIdExpDecl _) -> print_match ctr nm "Expr"
  95   | (Some nm,Ast.MetaExpListDecl _) -> print_match ctr nm "ExprList"
  96   | (Some nm,Ast.MetaDeclDecl _) -> print_match ctr nm "Decl"
  97   | (Some nm,Ast.MetaFieldDecl _) -> print_match ctr nm "Field"
  98   | (Some nm,Ast.MetaFieldListDecl _) -> print_match ctr nm "FieldList"
  99   | (Some nm,Ast.MetaStmDecl _) -> print_match ctr nm "Stmt"
 100   | (Some nm,Ast.MetaStmListDecl _) -> failwith ("not supported: "^nm)
 101   | (Some nm,Ast.MetaFuncDecl _) -> print_match ctr nm "Str"
 102   | (Some nm,Ast.MetaLocalFuncDecl _) -> print_match ctr nm "Str"
 103   | (Some nm,Ast.MetaDeclarerDecl _) -> print_match ctr nm "Str"
 104   | (Some nm,Ast.MetaIteratorDecl _) -> print_match ctr nm "Str"
 105   | (None,_) -> ""
 106
 107 let manage_script_vars script_vars =
 108   let rec loop n = function
 109       [] -> ""
 110     | (_,x)::xs ->
 111         (Printf.sprintf "let %s = List.nth script_args %d in\n" x n) ^
 112         (loop (n+1) xs) in
 113   loop 0 script_vars
 114
 115 (* ---------------------------------------------------------------------- *)
 116 (* Iteration management *)
 117
 118 let print_iteration_code o =
 119   let translator l =
 120     String.concat "\n              | "
 121       (List.map
 122          (function x -> Printf.sprintf "%s -> \"%s\""
 123              (String.capitalize x) x)
 124          l) in
 125   let add_virt_rules_method =
 126     match !Iteration.parsed_virtual_rules with
 127       [] -> ""
 128     | l ->
 129         Printf.sprintf "
 130     method add_virtual_rule r =
 131       let r = match r with %s in
 132       virtual_rules <- Common.union_set [r] virtual_rules\n"
 133           (translator l) in
 134   let add_virt_ids_method =
 135     match !Iteration.parsed_virtual_identifiers with
 136       [] -> ""
 137     | l ->
 138         Printf.sprintf "
 139     method add_virtual_identifier i v =
 140       let i = match i with %s in
 141       try
 142         let v1 = List.assoc i virtual_identifiers in
 143         if not (v = v1)
 144         then failwith (\"multiple values specified for \"^i)
 145       with Not_found ->
 146         virtual_identifiers <- (i,v) :: virtual_identifiers"
 147                                          (translator l) in
 148     Printf.fprintf o "
 149 class iteration () =
 150   object
 151     val mutable files = None
 152     val mutable files_changed = false
 153     val mutable virtual_rules = ([] : string list)
 154     val mutable virtual_identifiers = ([] : (string * string) list)
 155     method set_files f = files <- Some f
 156     %s%s
 157     method register () =
 158       Iteration.add_pending_instance (files,virtual_rules,virtual_identifiers)
 159   end\n\n" add_virt_rules_method add_virt_ids_method
 160
 161 (* ---------------------------------------------------------------------- *)
 162
 163 let prepare_rule (name, metavars, script_vars, code) =
 164   let fname = String.concat "_" (Str.split (Str.regexp " ") name) in
 165   (* function header *)
 166   let function_header body =
 167     Printf.sprintf "let %s args script_args =\n %s" fname body in
 168   (* parameter list *)
 169   let build_parameter_list body =
 170     let ctr = ref 0 in
 171     let lets =
 172       String.concat ""
 173         (List.rev
 174            (List.fold_left
 175               (function prev ->
 176                 function ((str_nm,ast_nm),_,mv) ->
 177                   (* order important; ctr is incremented *)
 178                   let string_rep = string_rep_binding ctr (str_nm,mv) in
 179                   let ast_rep = ast_rep_binding ctr (ast_nm,mv) in
 180                   ast_rep :: string_rep :: prev)
 181               [] metavars)) in
 182     lets ^ (manage_script_vars script_vars) ^ body in
 183   (* add to hash table *)
 184   let hash_add body =
 185     Printf.sprintf
 186       "%s\nlet _ = Hashtbl.add Coccilib.fcts \"%s\" %s\n" body name fname in
 187   hash_add (function_header (build_parameter_list code))
 188
 189 let prepare coccifile code =
 190   let init_rules =
 191     List.fold_left
 192       (function prev ->
 193         function
 194             Ast_cocci.InitialScriptRule (name,"ocaml",deps,code) ->
 195               code :: prev
 196           | _ -> prev)
 197       [] code in
 198   let init_rules = List.rev init_rules in
 199   let other_rules =
 200     List.fold_left
 201       (function prev ->
 202         function
 203             Ast_cocci.ScriptRule (name,"ocaml",deps,mv,script_vars,code) ->
 204               (name,mv,script_vars,code) :: prev
 205           | Ast_cocci.InitialScriptRule (name,"ocaml",deps,code) -> prev
 206           | Ast_cocci.FinalScriptRule (name,"ocaml",deps,code) ->
 207               (name,[],[],code) :: prev
 208           | _ -> prev)
 209       [] code in
 210   let other_rules = List.rev other_rules in
 211   if init_rules = [] && other_rules = []
 212   then None
 213   else
 214     begin
 215       let basefile = Filename.basename (Filename.chop_extension coccifile) in
 216       let basefile =
 217         String.concat "_" (Str.split (Str.regexp "-") basefile) in
 218       let (file,o) = Filename.open_temp_file  basefile ".ml" in
 219       (* Global initialization *)
 220       Printf.fprintf o "%s\n" (init_ocamlcocci());
 221       (* virtual rules and identifiers *)
 222       (if !Iteration.parsed_virtual_rules != []
 223       then
 224         Printf.fprintf o "type __virtual_rules__ = %s\n\n"
 225           (String.concat " | "
 226              (List.map String.capitalize !Iteration.parsed_virtual_rules)));
 227       (if !Iteration.parsed_virtual_identifiers != []
 228       then
 229         Printf.fprintf o "type __virtual_identifiers__ = %s\n\n"
 230           (String.concat " | "
 231              (List.map
 232                 (function x -> Printf.sprintf "%s" x)
 233                 (List.map String.capitalize
 234                    !Iteration.parsed_virtual_identifiers))));
 235       print_iteration_code o;
 236       (* Semantic patch specific initialization *)
 237       Printf.fprintf o "%s" (String.concat "\n\n" init_rules);
 238       (* Semantic patch rules and finalizer *)
 239       let rule_code = List.map prepare_rule other_rules in
 240       Printf.fprintf o "%s" (String.concat "\n\n" rule_code);
 241       close_out o;
 242       check_runtime ();
 243       Some file
 244     end
 245
 246 (* give a path to the coccilib cmi file *)
 247 let find_cmifile name =
 248   let path1 = Printf.sprintf "%s/ocaml/%s.cmi" Config.path name in
 249   if Sys.file_exists path1 then path1 else
 250   let path2 = Printf.sprintf "%s/ocaml/coccilib/%s.cmi" Config.path name in
 251   if Sys.file_exists path2 then path2 else
 252   raise (CompileFailure ("No coccilib.cmi in " ^ path1 ^ " or " ^ path2))
 253
 254 (* extract upper case identifiers from the cmi file. This will be an
 255  * approximation of the modules referenced by the coccilib, which are
 256  * thus present in the application and do not need to be loaded by
 257  * the dynamic linker.
 258  *)
 259
 260 module ModuleSet = Set.Make(String)
 261
 262 let approx_coccilib_deps cmi =
 263   let chan = open_in_bin cmi in
 264   let tbl = Hashtbl.create 1024 in
 265   let buf = Buffer.create 140 in
 266   begin
 267   try
 268     while true do
 269       let c = input_char chan in
 270       let has_ident = Buffer.length buf > 0 in
 271       if has_ident
 272       then begin
 273         if (c >= 'a' && c <= 'z') ||
 274            (c >= 'A' && c <= 'Z') ||
 275            (c >= '0' && c <= '9') ||
 276            c == '_' || c == '\''
 277         then Buffer.add_char buf c
 278         else begin
 279           if Buffer.length buf >= 3
 280           then begin
 281             let key = Buffer.contents buf in
 282             if Hashtbl.mem tbl key
 283             then ()
 284             else Hashtbl.add tbl (Buffer.contents buf) ()
 285           end;
 286           Buffer.clear buf
 287         end
 288       end
 289       else begin
 290         if c >= 'A' && c <= 'Z'
 291         then (* perhaps the begin of a captialized identifier *)
 292           Buffer.add_char buf c
 293         else ()
 294       end
 295     done
 296   with End_of_file -> ()
 297   end;
 298   close_in chan;
 299   tbl
 300
 301 let filter_dep existing_deps (accld, accinc) dep =
 302   if Hashtbl.mem existing_deps dep
 303   then (accld, accinc)  (* skip an existing dep *)
 304   else match dep with
 305       (* Built-in and OCaml defaults are filtered out *)
 306       "Arg" | "Arith_status" | "Array" | "ArrayLabels" | "Big_int" | "Bigarray"
 307     | "Buffer" | "Callback" | "CamlinternalLazy" | "CamlinternalMod"
 308     | "CamlinternalOO"
 309     | "Char" | "Complex" | "Condition" | "Digest" | "Dynlink" | "Event"
 310     | "Filename"
 311     | "Format" | "Gc" | "Genlex" | "GraphicsX11" | "Hashtbl" | "Int32"
 312     | "Int64"
 313     | "Lazy" | "Lexing" | "List" | "ListLabels" | "Map" | "Marshal"
 314     | "MoreLabels" | "Mutex"
 315     | "Nativeint" | "Num" | "Obj" | "Oo" | "Parsing" | "Pervasives"
 316     | "Printexc" | "Printf"
 317     | "Queue" | "Random" | "Scanf" | "Set" | "Sort" | "Stack" | "StdLabels"
 318     | "Str" | "Stream"
 319     | "String" | "StringLabels" | "Sys" | "ThreadUnix" | "Unix" | "UnixLabels"
 320     | "Weak"     -> (accld, accinc)
 321     | "Dbm"      -> ("dbm"::accld, accinc)
 322     | "Graphics" -> ("graphics"::accld, accinc)
 323     | "Thread"   -> ("thread"::accld, accinc)
 324     | "Tk"       -> ("tk"::accld, accinc)
 325
 326     | _ ->
 327         let l = Char.lowercase (String.get dep 0)in
 328           String.set dep 0 l;
 329           (accld, dep::accinc)
 330
 331 let get_dir p =
 332   let inclcmd = !Flag.ocamlfind ^" query "^p in
 333   let dir = List.hd (Common.cmd_to_list inclcmd) in
 334     (dir, p)
 335
 336 let parse_dep cmifile mlfile depout =
 337   let empty_deps = ([], "") in
 338   let existing_deps = approx_coccilib_deps cmifile in
 339   let re_colon = Str.regexp_string ":" in
 340   match Str.split re_colon depout with
 341     _::[dep] ->
 342       let deplist = Str.split (Str.regexp_string " ") dep in
 343       let (libs, orderdep) = List.fold_left (filter_dep existing_deps) ([],[]) deplist in
 344       if libs <> [] || orderdep <> [] then
 345         begin
 346           if check_cmd (!Flag.ocamlfind ^ " printconf 2>&1 > /dev/null")
 347           then
 348             let packages = List.rev orderdep in
 349             let inclflags = List.map get_dir packages in
 350             let intlib = List.map get_dir libs in
 351             let alllibs = List.rev_append intlib inclflags in
 352             let plist =
 353               List.fold_left (fun acc (_,p) -> acc ^" "^p) "" alllibs in
 354             let flags =
 355               String.concat " " (List.map (fun (d,_) -> "-I "^d) inclflags) in
 356             if flags <> "" || libs <> []
 357             then begin
 358               Common.pr2
 359                 ("Extra OCaml packages used in the semantic patch:"^ plist);
 360                 (alllibs, flags)
 361             end
 362             else begin
 363               Common.pr2 ("Warning: ocamlfind did not find "^
 364                        (if (List.length libs + List.length orderdep) = 1
 365                         then "this package:"
 366                         else "one of these packages:")^ plist);
 367               empty_deps
 368             end
 369           else begin
 370             Common.pr2 ("Warning: ocamlfind not found but "^mlfile^" uses "^dep);
 371             empty_deps
 372           end
 373         end
 374       else
 375         empty_deps
 376   | _ ->
 377       raise
 378         (CompileFailure ("Wrong dependencies for "^mlfile^" (Got "^depout^")"))
 379
 380 let dep_flag cmifile mlfile =
 381   let depcmd  = !Flag.ocamldep ^" -modules "^mlfile in
 382   match Common.cmd_to_list depcmd with
 383     [dep] -> parse_dep cmifile mlfile dep
 384   | err ->
 385       List.iter (function x -> Common.pr2 (x^"\n")) err;
 386       raise (CompileFailure ("Failed ocamldep for "^mlfile))
 387
 388 let compile_bytecode_cmd flags mlfile =
 389   let obj = (Filename.chop_extension mlfile) ^ ".cmo" in
 390   (obj, Printf.sprintf "%s -c %s %s %s" !Flag.ocamlc obj flags mlfile)
 391
 392 let compile_native_cmd flags mlfile =
 393   let obj = (Filename.chop_extension mlfile) ^ ".cmxs" in
 394   (obj,
 395    Printf.sprintf "%s -shared -o %s %s %s" !Flag.ocamlopt obj flags mlfile)
 396
 397 let compile mlfile cmd =
 398   Common.pr2 cmd;
 399   match Sys.command cmd with
 400       0 -> ()
 401     | _ -> raise (CompileFailure mlfile)
 402
 403 let load_obj obj =
 404   Dynlink.allow_unsafe_modules true;
 405   try Dynlink.loadfile obj
 406   with Dynlink.Error e ->
 407     Common.pr2 (Dynlink.error_message e);
 408     raise (LinkFailure obj)
 409
 410 let load_lib (dir, name) =
 411   let obj = dir ^ "/" ^name ^ ext in
 412     Common.pr2 ("Loading "^ obj ^"...");
 413     load_obj obj
 414
 415 let load_libs libs =
 416   List.iter load_lib libs
 417
 418 let load_file mlfile =
 419   let cmifile = find_cmifile "coccilib" in
 420   let (ldlibs, inc) = dep_flag cmifile mlfile in
 421   (* add ocaml and ocaml/coccilib as search directories for the ocaml scripting *)
 422   let flags =
 423     Printf.sprintf
 424       "-g -I %s %s -I %s"
 425       (sysdir ()) inc (Filename.dirname cmifile) in
 426   let (obj, cmd) =
 427     if Config.dynlink_is_native
 428     then compile_native_cmd flags mlfile
 429     else compile_bytecode_cmd flags mlfile in
 430   compile mlfile cmd;
 431   Common.pr2 "Compilation OK!";
 432   load_libs ldlibs;
 433   Common.pr2 "Loading ML code of the SP...";
 434   load_obj obj
 435
 436 let clean_file mlfile =
 437   let basefile = Filename.chop_extension mlfile in
 438   let files =
 439     if Config.dynlink_is_native then
 440       [basefile ^ ".cmxs";
 441        basefile ^ ".cmx";
 442        basefile ^ ".o";
 443        basefile ^ ".annot"]
 444     else
 445       [basefile ^ ".cmo";
 446        basefile ^ ".annot"]
 447   in
 448     if not !Flag_parsing_cocci.keep_ml_script then Sys.remove mlfile;
 449     Sys.remove (basefile^".cmi");
 450     List.iter (fun f -> try Sys.remove f with _ -> ()) files
 451
 452 (*
 453   This function is used in testing.ml.
 454   Once the ML file is compiled and loaded,
 455   newly available functions are reported here.
 456 *)
 457 let test () =
 458   Hashtbl.iter
 459     (fun key fct ->
 460        Common.pr2 ("Fct registered: \""^key^"\"")
 461     ) Coccilib.fcts