From b1b707a9c5e0a39d64c9d38b829b3c086a33411d Mon Sep 17 00:00:00 2001 From: Krishna Vaidyanathan Date: Mon, 27 Apr 2015 23:59:09 +0530 Subject: [PATCH 1/6] Method to method call fucntionality added in callgraph. NOTE: graph_code_java.ml has ast passed in functions, though not used (may be used in further iterations). Unused functions are commented out (for reference), can be deleted in next commit. --- lang_java/analyze/graph_code_java.ml | 482 ++++++++++++++++++++------- 1 file changed, 364 insertions(+), 118 deletions(-) diff --git a/lang_java/analyze/graph_code_java.ml b/lang_java/analyze/graph_code_java.ml index f5e493ec3..9fc0716ac 100644 --- a/lang_java/analyze/graph_code_java.ml +++ b/lang_java/analyze/graph_code_java.ml @@ -20,6 +20,7 @@ module G = Graph_code open Ast_java module Ast = Ast_java module PI = Parse_info +module V = Visitor_java (*****************************************************************************) (* Prelude *) @@ -74,7 +75,8 @@ type env = { phase: phase; current: Graph_code.node; current_qualifier: Ast_java.qualified_ident; - + (*Track class classifiers, for mapping nodes *) + top_level_qualifer: Ast_java.qualified_ident; (* import x.y.* => [["x";"y"]; ...] *) imported_namespace: (string list) list; (* import x.y.z => [("z", (false, ["x";"y";"z"])); ...] *) @@ -99,7 +101,7 @@ type env = { * a field needs the full inheritance tree to already be computed * as we may need to lookup entities up in the parents. *) - and phase = Defs | Inheritance | Uses + and phase = Defs | Inheritance | Uses | MethodToMethod (*****************************************************************************) (* Helpers *) @@ -124,6 +126,23 @@ let str_of_name xs = xs +> List.map (fun (_tyarg_todo, ident) -> Ast.unwrap ident) +> Common.join "." +(*let str_of_class_type xs =*) + (*xs +> List.map (fun (ident, _tyarg_todo) -> Ast.unwrap ident) +>*) + (*Common.join "."*) + +(* Same as str_of_qualified_ident except neglects super and this *) +(* + *let str_of_name_this_super xs= + * (match xs with + * | (_,hd)::tl -> (match Ast.unwrap hd with + * | "super" + * | "this" -> str_of_name tl + * | _ -> str_of_name xs + * ) + * | [] -> "") + * + *) + (* helper to build entries in env.params_or_locals *) let p_or_l v = Ast.unwrap v.v_name, Ast.is_final v.v_mods @@ -183,12 +202,12 @@ let add_use_edge env (name, kind) = let dst = (name, kind) in (match () with | _ when not (G.has_node src env.g) -> - pr2 (spf "LOOKUP SRC FAIL %s --> %s, src does not exist???" - (G.string_of_node src) (G.string_of_node dst)); - + if env.phase = MethodToMethod then + pr2 (spf "MTM: (add_use_edge) lookup fail on %s" name) + else + pr2 (spf "LOOKUP SRC FAIL %s --> %s, src does not exist???" (G.string_of_node src) (G.string_of_node dst)); | _ when G.has_node dst env.g -> - G.add_edge (src, dst) G.Use env.g - + G.add_edge (src, dst) G.Use env.g | _ -> (match kind with | _ -> @@ -211,15 +230,61 @@ let add_use_edge env (name, kind) = env.g +> G.add_edge (src, dst) G.Use; () | _ -> - pr2 (spf "PB: lookup fail on %s (in %s)" - (G.string_of_node dst) (G.string_of_node src)); - G.add_node dst env.g; - env.g +> G.add_edge (parent_target, dst) G.Has; - env.g +> G.add_edge (src, dst) G.Use; + match env.phase with + | MethodToMethod -> + pr2 (spf "MTM: (add_use_edge) lookup fail on %s (in %s)" + (G.string_of_node dst) (G.string_of_node src)) + | _ -> + pr2 (spf "PB: lookup fail on %s (in %s)" (G.string_of_node dst) (G.string_of_node src)); + G.add_node dst env.g; + env.g +> G.add_edge (parent_target, dst) G.Has; + env.g +> G.add_edge (src, dst) G.Use; ) ) ) + +(* + *Depth first search, checks which class path has the method called in the current + *node's successors + *) +let dfs ~env ~node ~node_str ~get_edges ~f = + let full_str = (str_of_qualified_ident env.top_level_qualifer) ^"." ^ + node_str in + (match (f full_str, f node_str) with + | (true,_) -> pr "Fully qualified "; Some full_str + | (_,true) -> pr "Method name as is"; Some node_str + | (false, false) -> + let rec aux ~node_str ~d ~list_ ~get_edges ~f = +(* Maximum depth that the funtion searched uptil *) + if (d < 10) then + begin + (match list_ with + | [] -> None + | hd::tl -> + let node_str_hd = (fst hd) ^ "." ^ node_str in + (match f node_str_hd with + | true -> + Some node_str_hd + | false -> + let node_list = get_edges ~n:hd in + (match aux ~node_str:node_str_hd ~d:(d+1) ~list_:node_list ~get_edges:get_edges ~f:f with + | None -> aux ~d:d ~node_str:node_str ~list_:tl ~get_edges:get_edges ~f:f + | Some x -> Some x + ) + ) + ) + end + else + None + in + (match aux ~d:0 ~node_str:node_str ~list_:(get_edges + ~n:node) ~get_edges:get_edges ~f with + | Some x -> pr "dfs, node existing"; Some x + | None -> None + ) + ) + (*****************************************************************************) (* Class/Package Lookup *) (*****************************************************************************) @@ -311,6 +376,11 @@ let rec extract_defs_uses ~phase ~g ~ast ~readable ~lookup_fails = | None -> [] | Some long_ident -> long_ident ); + top_level_qualifer = + (match ast.package with + | None -> [] + | Some long_ident -> long_ident + ); params_or_locals = []; type_parameters = []; imported_namespace = @@ -341,24 +411,31 @@ let rec extract_defs_uses ~phase ~g ~ast ~readable ~lookup_fails = match ast.package with (* have None usually for scripts, tests, or entry points *) | None -> +(* pr "None --\n"; *) let dir = Common2.dirname readable in G.create_intermediate_directories_if_not_present g dir; + pr "Create defs"; + pr readable; g +> G.add_node (readable, E.File); g +> G.add_edge ((dir, E.Dir), (readable, E.File)) G.Has; | Some long_ident -> - create_intermediate_packages_if_not_present g G.root long_ident; +(* pr "Some long_indent\n"; *) + create_intermediate_packages_if_not_present g G.root long_ident; +(* pr "End Some long indent\n"; *) end; (* double check if we can find some of the imports * (especially useful when have a better java_stdlib/ to report * third-party packages not-yet handled). *) if phase = Inheritance then begin - ast.imports +> List.iter (fun (is_static, qualified_ident) -> +(* pr "Phase inheritance \n"; *) + ast.imports +> List.iter (fun (_is_static, qualified_ident) (* Replaced + is_static with _is_static *)-> let qualified_ident_bis = match List.rev qualified_ident with | ("*",_)::rest -> List.rev rest (* less: just lookup the class for now *) - | _x::xs when is_static -> List.rev xs + | _x::xs when true-> List.rev xs (* Replaced is_static with true *) | _ -> qualified_ident in let entity = List.map Ast.unwrap qualified_ident_bis in @@ -381,17 +458,26 @@ let rec extract_defs_uses ~phase ~g ~ast ~readable ~lookup_fails = * to visit the AST and lookup classnames (possibly using information * from the import to know where to look for first). *) - decls env ast.decls + decls ast env ast.decls (* ---------------------------------------------------------------------- *) (* Declarations (classes, fields, etc) *) (* ---------------------------------------------------------------------- *) -and decl env = function - | Class def, _ -> class_decl env def - | Method def, _ -> method_decl env def - | Field def, _ -> field_decl env def - | Enum def, _ -> enum_decl env def +and decl ast env = function + | Class def, _ -> +(* pr "Class def \n"; *) + class_decl ast env def + | Method def, _ -> +(* pr "method def\n"; *) + method_decl ast env def + | Field def, _ -> +(* pr "Def\n"; *) + field_decl ast env def + | Enum def, _ -> +(* pr "Enum\n"; *) + enum_decl ast env def | Init (_is_static, st), n -> +(* pr "Init\n"; *) let name = spf "__init__%d" n in let full_ident = env.current_qualifier @ [name, fakeInfo name] in let full_str = str_of_qualified_ident full_ident in @@ -405,23 +491,39 @@ and decl env = function current_qualifier = full_ident; } in - stmt env st + stmt ast env st -and decls env xs = List.iter (decl env) (Common.index_list_1 xs) +and decls ast env xs = +(* pr "Decls env xs \n"; *) + List.iter (decl ast env) (Common.index_list_1 xs); +(* pr "Done with decls env xs" *) -and class_decl env def = +and class_decl ast env def = +(* pr "Class decl env def\n"; *) let full_ident = env.current_qualifier @ [def.cl_name] in let full_str = str_of_qualified_ident full_ident in let node = (full_str, E.Class) in +(* pr "env.phase = Defs\n "; *) if env.phase = Defs then begin (* less: def.c_type? *) - env.g +> G.add_node node; - env.g +> G.add_nodeinfo node (nodeinfo def.cl_name); - env.g +> G.add_edge (env.current, node) G.Has; + begin +(* pr "Inside begin block\n"; *) + if not (G.has_node node env.g) then + begin +(* pr "Not existing"; *) +(* pr "This is not in the if block"; *) + env.g +> G.add_node node; + env.g +> G.add_nodeinfo node (nodeinfo def.cl_name); + env.g +> G.add_edge (env.current, node) G.Has; +(* pr "This is not the error" *) + end; + end; end; +(* pr "End adding nodes\n"; *) let env = { env with current = node; current_qualifier = full_ident; + top_level_qualifer = full_ident; (* with anon classes we need to lookup enclosing final parameters/locals *) params_or_locals = env.params_or_locals +> List.filter (fun (_x,b) -> b); type_parameters = def.cl_tparams +> List.map (function @@ -429,12 +531,14 @@ and class_decl env def = ); } in +(* pr "parents operation \n"; *) let parents = Common2.option_to_list def.cl_extends @ (def.cl_impls) in - List.iter (typ env) parents; - +(* pr "List iter \n"; *) + List.iter (typ ast env) parents; +(* pr "imports \n"; *) let imports = if env.phase = Defs then [] else @@ -447,13 +551,13 @@ and class_decl env def = (List.map Ast.unwrap full_ident @ ["*"]) :: import_of_inherited_classes env (full_str, E.Class) in - decls {env with imported_namespace = imports @ env.imported_namespace } + decls ast {env with imported_namespace = imports @ env.imported_namespace } def.cl_body (* Java allow some forms of overloading, so the same method name can be * used multiple times. *) -and method_decl env def = +and method_decl ast env def = let full_ident = env.current_qualifier @ [def.m_var.v_name] in let full_str = str_of_qualified_ident full_ident in @@ -464,6 +568,9 @@ and method_decl env def = if G.has_node (full_str, E.Method) env.g then () else begin + (*pr "Print Method";*) + (*pr full_str;*) + (*pr "----";*) env.g +> G.add_node node; env.g +> G.add_nodeinfo node (nodeinfo def.m_var.v_name); env.g +> G.add_edge (env.current, node) G.Has; @@ -487,12 +594,12 @@ and method_decl env def = type_parameters = []; } in - var env def.m_var; - List.iter (var env) def.m_formals; + var ast env def.m_var; + List.iter (var ast env) def.m_formals; (* todo: m_throws *) - stmt env def.m_body + stmt ast env def.m_body -and field_decl env def = +and field_decl ast env def = let full_ident = env.current_qualifier @ [def.f_var.v_name] in let full_str = str_of_qualified_ident full_ident in let kind = @@ -503,27 +610,40 @@ and field_decl env def = let node = (full_str, kind) in if env.phase = Defs then begin (* less: static? *) + if not (G.has_node node env.g) + then + begin env.g +> G.add_node node; env.g +> G.add_nodeinfo node (nodeinfo def.f_var.v_name); env.g +> G.add_edge (env.current, node) G.Has; + end + else pr2 (spf "Package: %s already existing" (G.string_of_node node)) end; let env = { env with current = node; current_qualifier = env.current_qualifier } in - field env def + field ast env def -and enum_decl env def = +and enum_decl ast env def = let full_ident = env.current_qualifier @ [def.en_name] in let full_str = str_of_qualified_ident full_ident in (* less: make it a class? or a Type? *) let node = (full_str, E.Class) in - if env.phase = Defs then begin + if env.phase = Defs then + begin +(* pr "Enum decl env.phases = Def"; *) + if not (G.has_node node env.g) + then + begin env.g +> G.add_node node; env.g +> G.add_nodeinfo node (nodeinfo def.en_name); env.g +> G.add_edge (env.current, node) G.Has; - end; + end + else begin pr2 (spf "Package: %s already existing" (G.string_of_node + node)) end + end; let env = { env with current = node; current_qualifier = full_ident; @@ -533,9 +653,9 @@ and enum_decl env def = } in let parents = (def.en_impls) in - List.iter (typ env) parents; + List.iter (typ ast env) parents; let (csts, xs) = def.en_body in - decls env xs; + decls ast env xs; csts +> List.iter (fun enum_constant -> @@ -547,9 +667,14 @@ and enum_decl env def = let full_str = str_of_qualified_ident full_ident in let node = (full_str, E.Constant) in if env.phase = Defs then begin + if not (G.has_node node env.g) then + begin env.g +> G.add_node node; env.g +> G.add_nodeinfo node (nodeinfo ident); env.g +> G.add_edge (env.current, node) G.Has; + end + else begin pr2 (spf ": %s already existing" + (G.string_of_node node)) end end; let env = { env with current = node; @@ -559,9 +684,9 @@ and enum_decl env def = (match enum_constant with | EnumSimple _ident -> () | EnumConstructor (_ident, args) -> - exprs env args + exprs ast env args | EnumWithMethods (_ident, xs) -> - decls env (xs +> List.map (fun x -> Method x)) + decls ast env (xs +> List.map (fun x -> Method x)) ) ) @@ -569,32 +694,32 @@ and enum_decl env def = (* Stmt *) (* ---------------------------------------------------------------------- *) (* mostly boilerplate, control constructs don't introduce entities *) -and stmt env = function +and stmt ast env = function | Empty -> () - | Block xs -> stmts env xs - | Expr e -> expr env e + | Block xs -> stmts ast env xs + | Expr e -> expr ast env e | If (e, st1, st2) -> - expr env e; - stmt env st1; - stmt env st2; + expr ast env e; + stmt ast env st1; + stmt ast env st2; | Switch (e, xs) -> - expr env e; + expr ast env e; xs +> List.iter (fun (cs, sts) -> - cases env cs; - stmts env sts + cases ast env cs; + stmts ast env sts ) | While (e, st) -> - expr env e; - stmt env st; + expr ast env e; + stmt ast env st; | Do (st, e) -> - expr env e; - stmt env st; + expr ast env e; + stmt ast env st; | For (x, st) -> let env = match x with | Foreach (v, e) -> - var env v; - expr env e; + var ast env v; + expr ast env e; { env with params_or_locals = p_or_l v :: env.params_or_locals; } @@ -602,47 +727,47 @@ and stmt env = function | ForClassic (init, es1, es2) -> (match init with | ForInitExprs es0 -> - exprs env (es0 @ es1 @ es2); + exprs ast env (es0 @ es1 @ es2); env | ForInitVars xs -> - List.iter (field env) xs; + List.iter (field ast env) xs; let env = { env with params_or_locals = (xs +> List.map (fun fld -> p_or_l fld.f_var) ) @ env.params_or_locals; } in - exprs env (es1 @ es2); + exprs ast env (es1 @ es2); env ) in - stmt env st; + stmt ast env st; (* could have an entity and dependency ... but it's intra procedural * so not that useful *) - | Label (_id, st) -> stmt env st + | Label (_id, st) -> stmt ast env st | Break _idopt | Continue _idopt -> () - | Return eopt -> exprs env (Common2.option_to_list eopt) + | Return eopt -> exprs ast env (Common2.option_to_list eopt) | Sync (e, st) -> - expr env e; - stmt env st; + expr ast env e; + stmt ast env st; | Try (st, xs, stopt) -> - stmt env st; - catches env xs; - stmts env (Common2.option_to_list stopt); - | Throw e -> expr env e + stmt ast env st; + catches ast env xs; + stmts ast env (Common2.option_to_list stopt); + | Throw e -> expr ast env e | Assert (e, eopt) -> - exprs env (e::Common2.option_to_list eopt) + exprs ast env (e::Common2.option_to_list eopt) (* The modification of env.params_locals is done in decls() *) - | LocalVar f -> field env f - | LocalClass def -> class_decl env def + | LocalVar f -> field ast env f + | LocalClass def -> class_decl ast env def -and stmts env xs = +and stmts ast env xs = let rec aux env = function | [] -> () | x::xs -> - stmt env x; + stmt ast env x; let env = match x with | LocalVar fld -> @@ -655,21 +780,21 @@ and stmts env xs = in aux env xs -and cases env xs = List.iter (case env) xs -and case env = function - | Case e -> expr env e +and cases ast env xs = List.iter (case ast env) xs +and case ast env = function + | Case e -> expr ast env e | Default -> () -and catches env xs = List.iter (catch env) xs -and catch env (v, st) = - var env v; +and catches ast env xs = List.iter (catch ast env) xs +and catch ast env (v, st) = + var ast env v; let env = { env with params_or_locals = p_or_l v :: env.params_or_locals } in - stmt env st + stmt ast env st (* ---------------------------------------------------------------------- *) (* Expr *) (* ---------------------------------------------------------------------- *) -and expr env = function +and expr ast env = function (* main dependency source! *) | Name n -> if env.phase = Uses then begin @@ -713,10 +838,10 @@ and expr env = function | NameOrClassType _ -> () | Literal _ -> () - | ClassLiteral t -> typ env t + | ClassLiteral t -> typ ast env t | NewClass (t, args, decls_opt) -> - typ env t; - exprs env args; + typ ast env t; + exprs ast env args; (match decls_opt with | None -> () | Some xs -> @@ -735,7 +860,7 @@ and expr env = function cl_mods = []; } in - class_decl env cdecl + class_decl ast env cdecl ) | NewQualifiedClass (_e, id, args, decls_opt) -> (* @@ -743,53 +868,163 @@ and expr env = function pr2_gen (NewQualifiedClass (e, id, args, decls_opt)); *) (* todo: need to resolve the type of 'e' *) - expr env (NewClass (TClass ([id, []]), args, decls_opt)) + expr ast env (NewClass (TClass ([id, []]), args, decls_opt)) | NewArray (t, args, _i, ini_opt) -> - typ env t; - exprs env args; - init_opt env ini_opt + typ ast env t; + exprs ast env args; + init_opt ast env ini_opt | Call (e, es) -> - expr env e; - exprs env es + (if env.phase = MethodToMethod then + resolve_call ast env (e,es)); + expr ast env e; + exprs ast env es; +(* TODO: resolve call *) | Dot (e, _idTODO) -> (* todo: match e, and try lookup method/field * if e is a Name, lookup it, and if a class then * lookup children. If local ... then need get its type * lookup its node, and then lookup children. *) - expr env e; + expr ast env e; - | ArrayAccess (e1, e2) -> exprs env [e1;e2] - | Postfix (e, _op) | Prefix (_op, e) -> expr env e - | Infix (e1, _op, e2) -> exprs env [e1;e2] - | Conditional (e1, e2, e3) -> exprs env [e1;e2;e3] - | Assignment (e1, _op, e2) -> exprs env [e1;e2] + | ArrayAccess (e1, e2) -> exprs ast env [e1;e2] + | Postfix (e, _op) | Prefix (_op, e) -> expr ast env e + | Infix (e1, _op, e2) -> exprs ast env [e1;e2] + | Conditional (e1, e2, e3) -> exprs ast env [e1;e2;e3] + | Assignment (e1, _op, e2) -> exprs ast env [e1;e2] | Cast (t, e) -> - typ env t; - expr env e + typ ast env t; + expr ast env e | InstanceOf (e, tref) -> - expr env e; - typ env (tref); - - -and exprs env xs = List.iter (expr env) xs -and init env = function - | ExprInit e -> expr env e - | ArrayInit xs -> List.iter (init env) xs -and init_opt env opt = + expr ast env e; + typ ast env (tref); + +(* TODO: Remove ast, if it is not used *) +and resolve_call ast env (expr_,_) = + let rec aux _ast expr_ = + (match expr_ with + | Name name_ -> resolve_name ast name_ + | NameOrClassType _ + | Literal _ + | ClassLiteral _ + | NewClass _ + | NewArray _ + | NewQualifiedClass _ -> "NewQualifiedClassNone" + | Call(expr_,_) -> aux _ast expr_ + | Dot (expr_, ident) -> let qualifier = (aux _ast expr_) in + (match qualifier with + | "" -> Ast.unwrap ident + | q -> q ^ "." ^ Ast.unwrap ident) + | ArrayAccess _ + | Postfix _ + | Prefix _ + | Infix _ + | Cast _ + | InstanceOf _ + | Conditional _ + | Assignment _ -> "AssignmentNone" + ) + in + let node_str = aux ast expr_ in + let node_str_o = dfs ~env ~node:env.current ~node_str:node_str ~get_edges:(fun + ~n -> G.succ n G.Use env.g) ~f:(fun node -> G.has_node (node, + E.Method) env.g) + in + (match node_str_o with + | None -> pr2 (spf "MTM: (resolve_call) lookup fail on %s" node_str) + | Some str -> + add_use_edge env (str, E.Method); + pr (spf "MTM: (resolve_call) Edge drawn to method %s, %s" str + node_str) + ); + () + +(* Removes the object's name in method calls, NOTE: this is a heuristic which + * relies on the fact that most method calls are of the form A.x(), where A is + * an object. Also, it assumes that in type name, first element of the list can + * be removed*) +and resolve_name _ast name_ = + match name_ with +(* | hd::[] -> str_of_name [hd] *) + | _::tl -> str_of_name tl + | [] -> "" + +(* Finds the type of object, and prepends it to qualifying path +and resolve_name ast name_ = + let flag = ref true in + let field_name_ = match name_ with + | hd::_ -> Ast.unwrap (snd hd) + | [] -> flag.contents <- false; + pr " field_name_ []"; + "None" + in + let str = ref (str_of_name_this_super name_) in + let traverse_ast = V.mk_visitor { V.default_visitor with + (* Only handling fields, as visitor functions are written only for it*) + V.kfield= ( fun(k,_) d-> + (match d with + | field -> + let field_name = fst (field.f_var.v_name) in + if field_name = field_name_ then + begin + pr "field_name equal \n"; + pr "field_name_ "; + pr field_name_; +(* flag.contents <- true; *) + let object_name = resolve_typ field.f_var.v_type in + let str_name_td = match name_ with + | [] -> flag.contents <- false; + (* pr "str_name_td []"; *) + "None" + | _::name_td -> str_of_name_this_super name_td + in + (* + *pr "str_name_td"; + *pr str_name_td; + *pr "--------"; + *) + str.contents <- + (match str_name_td with + | "" -> object_name + | q -> object_name ^ "."^q + ) + end; + + ); + k d + ) + + } + in traverse_ast(Ast.AProgram ast); + if flag.contents = true then + str.contents + else + str_of_name_this_super name_ + +and resolve_typ = function + | TBasic ident_ -> Ast.unwrap ident_ + | TClass class_type_ -> str_of_class_type class_type_ + | TArray typ_ -> resolve_typ typ_ + +*) +and exprs ast env xs = List.iter (expr ast env) xs +and init ast env = function + | ExprInit e -> expr ast env e + | ArrayInit xs -> List.iter (init ast env) xs +and init_opt ast env opt = match opt with | None -> () - | Some ini -> init env ini + | Some ini -> init ast env ini (* ---------------------------------------------------------------------- *) (* Types *) (* ---------------------------------------------------------------------- *) -and typ env = function +and typ _ast env = function | TBasic _ -> () - | TArray t -> typ env t + | TArray t -> typ _ast env t (* other big dependency source! *) | TClass reft -> (* todo: let's forget generic arguments for now *) @@ -830,13 +1065,13 @@ and typ env = function (* ---------------------------------------------------------------------- *) (* Misc *) (* ---------------------------------------------------------------------- *) -and var env v = - typ env v.v_type; +and var ast env v = + typ ast env v.v_type; () -and field env f = - var env f.f_var; - init_opt env f.f_init; +and field ast env f = + var ast env f.f_var; + init_opt ast env f.f_init; () (*****************************************************************************) @@ -851,6 +1086,7 @@ let build ?(verbose=true) ?(only_defs=false) root files = (* step1: creating the nodes and 'Has' edges, the defs *) if verbose then pr2 "\nstep1: extract defs"; +(* pr "Step 1\n"; *) files +> Console.progress ~show:verbose (fun k -> List.iter (fun file -> k(); @@ -862,6 +1098,7 @@ let build ?(verbose=true) ?(only_defs=false) root files = (* step2: creating the 'Use' edges just for inheritance *) if verbose then pr2 "\nstep2: extract inheritance information"; +(* pr "Step 2 \n"; *) files +> Console.progress ~show:verbose (fun k -> List.iter (fun file -> k(); @@ -880,4 +1117,13 @@ let build ?(verbose=true) ?(only_defs=false) root files = extract_defs_uses ~phase:Uses ~g ~ast ~readable ~lookup_fails; )); end; + if verbose then pr2 "\nstep4: methodtomethod"; +(* pr "Step 4\n"; *) + files +> Console.progress ~show:verbose (fun k -> + List.iter (fun file -> + k(); + let readable = Common.readable ~root file in + let ast = parse ~show_parse_error:true file in + extract_defs_uses ~phase:MethodToMethod ~g ~ast ~readable ~lookup_fails; + )); g From 513975ff3f859c8b5ca17b9dc777d1cb7ff974c4 Mon Sep 17 00:00:00 2001 From: Krishna Vaidyanathan Date: Mon, 27 Apr 2015 23:59:32 +0530 Subject: [PATCH 2/6] Method to method fuction calls in call-graphs: searches for methods in imports also now. Added option in main_codegraph.ml to run method to method functionality as optional - currently slows down things when run --- find_source.ml | 2 + lang_java/analyze/graph_code_java.ml | 400 +++++++++++++++++--------- lang_java/analyze/graph_code_java.mli | 1 + main_codegraph.ml | 6 + 4 files changed, 277 insertions(+), 132 deletions(-) diff --git a/find_source.ml b/find_source.ml index 461f9be9f..f57905e26 100644 --- a/find_source.ml +++ b/find_source.ml @@ -16,6 +16,8 @@ let finder lang = | "cmt" -> Lib_parsing_ml.find_cmt_files_of_dir_or_files | "java" -> + Lib_parsing_java.find_source_files_of_dir_or_files + | "javam" -> Lib_parsing_java.find_source_files_of_dir_or_files | "js" -> Lib_parsing_js.find_source_files_of_dir_or_files ~include_scripts:false diff --git a/lang_java/analyze/graph_code_java.ml b/lang_java/analyze/graph_code_java.ml index 9fc0716ac..477b840c9 100644 --- a/lang_java/analyze/graph_code_java.ml +++ b/lang_java/analyze/graph_code_java.ml @@ -106,6 +106,39 @@ type env = { (*****************************************************************************) (* Helpers *) (*****************************************************************************) +let rec iter_until_true ~f list_ = + match list_ with + | [] -> None + | hd::tl -> + match f hd with + | false -> iter_until_true ~f tl + | true -> Some hd + +let rec fold_inner ~acc ~f ~x = + (match x with + | [] -> acc + | hd::tl -> fold_inner ~acc:(f acc hd) ~f:f ~x:tl + ) + +let fold x_list ~init ~f = + fold_inner ~acc:init ~x:x_list ~f:f + +let last = function + | hd::tl -> List.fold_left (fun _ y -> y) hd tl + | [] -> failwith "no element" + + let join_list ~sep a= + let a = + (match a with + | "this"::tl -> tl + | _ -> a) + in + let aux = fold ~init:"" ~f:(fun a b -> (Common.join sep [a;b])) in + (match a with + | [] -> "" + | [a] -> a + | hd::tl -> hd ^ (aux tl) + ) let parse ~show_parse_error file = try @@ -248,14 +281,57 @@ let add_use_edge env (name, kind) = *Depth first search, checks which class path has the method called in the current *node's successors *) -let dfs ~env ~node ~node_str ~get_edges ~f = +let dfs ?(verbose=false) ~env ~node ~node_str ~get_edges ~f = + let printer = ref [""] in let full_str = (str_of_qualified_ident env.top_level_qualifer) ^"." ^ node_str in - (match (f full_str, f node_str) with - | (true,_) -> pr "Fully qualified "; Some full_str - | (_,true) -> pr "Method name as is"; Some node_str - | (false, false) -> - let rec aux ~node_str ~d ~list_ ~get_edges ~f = + if verbose = true then + begin + pr (spf "dfs on str: %s, %s" full_str node_str); + pr (spf "Current method/class/fied: %s" (str_of_qualified_ident env.current_qualifier ^"."^node_str)); + end; + let f_imported_namespace_check = + iter_until_true ~f:(fun a-> f ((join_list ~sep:"." a) ^ "." ^ node_str)) + env.imported_namespace + in + let f_imported_qualifier_check = + iter_until_true ~f:(fun (a,(_,b))-> f (a ^ "."^(str_of_qualified_ident b) + ^"." ^ node_str)) + env.imported_qualified + in +(* + pr "Imported qualified"; + pr (match f_imported_qualifier_check with + | Some (str,_) -> str + | None -> "None" + ); +*) + (* + *let _str = + * match env.imported_qualified with + * | [] -> "" + * | (hd,(_,b))::_ -> hd ^"."^ (str_of_qualified_ident b)^"."^node_str + *in + *pr _str; + *) +let op = + (match (f full_str, f node_str, f_imported_namespace_check , f_imported_qualifier_check) with + | (false,false,Some str, _) -> + if verbose = true then + printer.contents <- printer.contents @ ["Imported namespace edge drawn"]; + Some (join_list ~sep:"." str ^"."^node_str) + | (false, false, _ , Some (str,_)) -> + if verbose = true then + printer.contents <- printer.contents @[ "Imported qualifier edge drawn"]; + Some ( str ^"." ^ node_str) + | (true,_,_,_) -> + if verbose = true then + printer.contents <- printer.contents @ ["Fully qualified "]; Some full_str + | (_,true,_,_) -> + if verbose = true then + printer.contents <- printer.contents @ ["Method name as is"]; Some node_str + | (false, false,None, None) -> + let rec aux ~verbose ~node_str ~d ~list_ ~get_edges ~f = (* Maximum depth that the funtion searched uptil *) if (d < 10) then begin @@ -263,13 +339,15 @@ let dfs ~env ~node ~node_str ~get_edges ~f = | [] -> None | hd::tl -> let node_str_hd = (fst hd) ^ "." ^ node_str in + if verbose = true then + printer.contents <- printer.contents @ [node_str_hd]; (match f node_str_hd with | true -> Some node_str_hd | false -> let node_list = get_edges ~n:hd in - (match aux ~node_str:node_str_hd ~d:(d+1) ~list_:node_list ~get_edges:get_edges ~f:f with - | None -> aux ~d:d ~node_str:node_str ~list_:tl ~get_edges:get_edges ~f:f + (match aux ~verbose ~node_str:node_str_hd ~d:(d+1) ~list_:node_list ~get_edges:get_edges ~f:f with + | None -> aux ~verbose ~d:d ~node_str:node_str ~list_:tl ~get_edges:get_edges ~f:f | Some x -> Some x ) ) @@ -278,12 +356,14 @@ let dfs ~env ~node ~node_str ~get_edges ~f = else None in - (match aux ~d:0 ~node_str:node_str ~list_:(get_edges + (match aux ~verbose ~d:0 ~node_str:node_str ~list_:(get_edges ~n:node) ~get_edges:get_edges ~f with - | Some x -> pr "dfs, node existing"; Some x + | Some x -> printer.contents <- printer.contents @ ["dfs, node existing"]; Some x | None -> None ) ) +in + (op, printer) (*****************************************************************************) (* Class/Package Lookup *) @@ -364,7 +444,7 @@ let rec extract_defs_uses ~phase ~g ~ast ~readable ~lookup_fails = ignore(lookup_fails); let env = { - g; phase; + g; phase; current = (match ast.package with @@ -458,24 +538,24 @@ let rec extract_defs_uses ~phase ~g ~ast ~readable ~lookup_fails = * to visit the AST and lookup classnames (possibly using information * from the import to know where to look for first). *) - decls ast env ast.decls + decls env ast.decls (* ---------------------------------------------------------------------- *) (* Declarations (classes, fields, etc) *) (* ---------------------------------------------------------------------- *) -and decl ast env = function +and decl env = function | Class def, _ -> (* pr "Class def \n"; *) - class_decl ast env def + class_decl env def | Method def, _ -> (* pr "method def\n"; *) - method_decl ast env def + method_decl env def | Field def, _ -> (* pr "Def\n"; *) - field_decl ast env def + field_decl env def | Enum def, _ -> (* pr "Enum\n"; *) - enum_decl ast env def + enum_decl env def | Init (_is_static, st), n -> (* pr "Init\n"; *) let name = spf "__init__%d" n in @@ -491,14 +571,14 @@ and decl ast env = function current_qualifier = full_ident; } in - stmt ast env st + stmt env st -and decls ast env xs = +and decls env xs = (* pr "Decls env xs \n"; *) - List.iter (decl ast env) (Common.index_list_1 xs); + List.iter (decl env) (Common.index_list_1 xs); (* pr "Done with decls env xs" *) -and class_decl ast env def = +and class_decl env def = (* pr "Class decl env def\n"; *) let full_ident = env.current_qualifier @ [def.cl_name] in let full_str = str_of_qualified_ident full_ident in @@ -537,7 +617,7 @@ and class_decl ast env def = (def.cl_impls) in (* pr "List iter \n"; *) - List.iter (typ ast env) parents; + List.iter (typ env) parents; (* pr "imports \n"; *) let imports = if env.phase = Defs then [] @@ -551,13 +631,13 @@ and class_decl ast env def = (List.map Ast.unwrap full_ident @ ["*"]) :: import_of_inherited_classes env (full_str, E.Class) in - decls ast {env with imported_namespace = imports @ env.imported_namespace } + decls {env with imported_namespace = imports @ env.imported_namespace } def.cl_body (* Java allow some forms of overloading, so the same method name can be * used multiple times. *) -and method_decl ast env def = +and method_decl env def = let full_ident = env.current_qualifier @ [def.m_var.v_name] in let full_str = str_of_qualified_ident full_ident in @@ -594,12 +674,12 @@ and method_decl ast env def = type_parameters = []; } in - var ast env def.m_var; - List.iter (var ast env) def.m_formals; + var env def.m_var; + List.iter (var env) def.m_formals; (* todo: m_throws *) - stmt ast env def.m_body + stmt env def.m_body -and field_decl ast env def = +and field_decl env def = let full_ident = env.current_qualifier @ [def.f_var.v_name] in let full_str = str_of_qualified_ident full_ident in let kind = @@ -624,9 +704,9 @@ and field_decl ast env def = current_qualifier = env.current_qualifier } in - field ast env def + field env def -and enum_decl ast env def = +and enum_decl env def = let full_ident = env.current_qualifier @ [def.en_name] in let full_str = str_of_qualified_ident full_ident in (* less: make it a class? or a Type? *) @@ -653,9 +733,9 @@ and enum_decl ast env def = } in let parents = (def.en_impls) in - List.iter (typ ast env) parents; + List.iter (typ env) parents; let (csts, xs) = def.en_body in - decls ast env xs; + decls env xs; csts +> List.iter (fun enum_constant -> @@ -684,9 +764,9 @@ and enum_decl ast env def = (match enum_constant with | EnumSimple _ident -> () | EnumConstructor (_ident, args) -> - exprs ast env args + exprs env args | EnumWithMethods (_ident, xs) -> - decls ast env (xs +> List.map (fun x -> Method x)) + decls env (xs +> List.map (fun x -> Method x)) ) ) @@ -694,32 +774,32 @@ and enum_decl ast env def = (* Stmt *) (* ---------------------------------------------------------------------- *) (* mostly boilerplate, control constructs don't introduce entities *) -and stmt ast env = function +and stmt env = function | Empty -> () - | Block xs -> stmts ast env xs - | Expr e -> expr ast env e + | Block xs -> stmts env xs + | Expr e -> expr env e | If (e, st1, st2) -> - expr ast env e; - stmt ast env st1; - stmt ast env st2; + expr env e; + stmt env st1; + stmt env st2; | Switch (e, xs) -> - expr ast env e; + expr env e; xs +> List.iter (fun (cs, sts) -> - cases ast env cs; - stmts ast env sts + cases env cs; + stmts env sts ) | While (e, st) -> - expr ast env e; - stmt ast env st; + expr env e; + stmt env st; | Do (st, e) -> - expr ast env e; - stmt ast env st; + expr env e; + stmt env st; | For (x, st) -> let env = match x with | Foreach (v, e) -> - var ast env v; - expr ast env e; + var env v; + expr env e; { env with params_or_locals = p_or_l v :: env.params_or_locals; } @@ -727,47 +807,47 @@ and stmt ast env = function | ForClassic (init, es1, es2) -> (match init with | ForInitExprs es0 -> - exprs ast env (es0 @ es1 @ es2); + exprs env (es0 @ es1 @ es2); env | ForInitVars xs -> - List.iter (field ast env) xs; + List.iter (field env) xs; let env = { env with params_or_locals = (xs +> List.map (fun fld -> p_or_l fld.f_var) ) @ env.params_or_locals; } in - exprs ast env (es1 @ es2); + exprs env (es1 @ es2); env ) in - stmt ast env st; + stmt env st; (* could have an entity and dependency ... but it's intra procedural * so not that useful *) - | Label (_id, st) -> stmt ast env st + | Label (_id, st) -> stmt env st | Break _idopt | Continue _idopt -> () - | Return eopt -> exprs ast env (Common2.option_to_list eopt) + | Return eopt -> exprs env (Common2.option_to_list eopt) | Sync (e, st) -> - expr ast env e; - stmt ast env st; + expr env e; + stmt env st; | Try (st, xs, stopt) -> - stmt ast env st; - catches ast env xs; - stmts ast env (Common2.option_to_list stopt); - | Throw e -> expr ast env e + stmt env st; + catches env xs; + stmts env (Common2.option_to_list stopt); + | Throw e -> expr env e | Assert (e, eopt) -> - exprs ast env (e::Common2.option_to_list eopt) + exprs env (e::Common2.option_to_list eopt) (* The modification of env.params_locals is done in decls() *) - | LocalVar f -> field ast env f - | LocalClass def -> class_decl ast env def + | LocalVar f -> field env f + | LocalClass def -> class_decl env def -and stmts ast env xs = +and stmts env xs = let rec aux env = function | [] -> () | x::xs -> - stmt ast env x; + stmt env x; let env = match x with | LocalVar fld -> @@ -780,21 +860,21 @@ and stmts ast env xs = in aux env xs -and cases ast env xs = List.iter (case ast env) xs -and case ast env = function - | Case e -> expr ast env e +and cases env xs = List.iter (case env) xs +and case env = function + | Case e -> expr env e | Default -> () -and catches ast env xs = List.iter (catch ast env) xs -and catch ast env (v, st) = - var ast env v; +and catches env xs = List.iter (catch env) xs +and catch env (v, st) = + var env v; let env = { env with params_or_locals = p_or_l v :: env.params_or_locals } in - stmt ast env st + stmt env st (* ---------------------------------------------------------------------- *) (* Expr *) (* ---------------------------------------------------------------------- *) -and expr ast env = function +and expr env = function (* main dependency source! *) | Name n -> if env.phase = Uses then begin @@ -838,10 +918,10 @@ and expr ast env = function | NameOrClassType _ -> () | Literal _ -> () - | ClassLiteral t -> typ ast env t + | ClassLiteral t -> typ env t | NewClass (t, args, decls_opt) -> - typ ast env t; - exprs ast env args; + typ env t; + exprs env args; (match decls_opt with | None -> () | Some xs -> @@ -860,7 +940,7 @@ and expr ast env = function cl_mods = []; } in - class_decl ast env cdecl + class_decl env cdecl ) | NewQualifiedClass (_e, id, args, decls_opt) -> (* @@ -868,18 +948,18 @@ and expr ast env = function pr2_gen (NewQualifiedClass (e, id, args, decls_opt)); *) (* todo: need to resolve the type of 'e' *) - expr ast env (NewClass (TClass ([id, []]), args, decls_opt)) + expr env (NewClass (TClass ([id, []]), args, decls_opt)) | NewArray (t, args, _i, ini_opt) -> - typ ast env t; - exprs ast env args; - init_opt ast env ini_opt + typ env t; + exprs env args; + init_opt env ini_opt | Call (e, es) -> (if env.phase = MethodToMethod then - resolve_call ast env (e,es)); - expr ast env e; - exprs ast env es; + resolve_call env (e,es)); + expr env e; + exprs env es; (* TODO: resolve call *) | Dot (e, _idTODO) -> (* todo: match e, and try lookup method/field @@ -887,37 +967,39 @@ and expr ast env = function * lookup children. If local ... then need get its type * lookup its node, and then lookup children. *) - expr ast env e; + expr env e; - | ArrayAccess (e1, e2) -> exprs ast env [e1;e2] - | Postfix (e, _op) | Prefix (_op, e) -> expr ast env e - | Infix (e1, _op, e2) -> exprs ast env [e1;e2] - | Conditional (e1, e2, e3) -> exprs ast env [e1;e2;e3] - | Assignment (e1, _op, e2) -> exprs ast env [e1;e2] + | ArrayAccess (e1, e2) -> exprs env [e1;e2] + | Postfix (e, _op) | Prefix (_op, e) -> expr env e + | Infix (e1, _op, e2) -> exprs env [e1;e2] + | Conditional (e1, e2, e3) -> exprs env [e1;e2;e3] + | Assignment (e1, _op, e2) -> exprs env [e1;e2] | Cast (t, e) -> - typ ast env t; - expr ast env e + typ env t; + expr env e | InstanceOf (e, tref) -> - expr ast env e; - typ ast env (tref); + expr env e; + typ env (tref); (* TODO: Remove ast, if it is not used *) -and resolve_call ast env (expr_,_) = - let rec aux _ast expr_ = +and resolve_call env (expr_,_) = + let rec aux expr_ = (match expr_ with - | Name name_ -> resolve_name ast name_ + | Name name_ -> resolve_name name_ | NameOrClassType _ | Literal _ | ClassLiteral _ | NewClass _ | NewArray _ - | NewQualifiedClass _ -> "NewQualifiedClassNone" - | Call(expr_,_) -> aux _ast expr_ - | Dot (expr_, ident) -> let qualifier = (aux _ast expr_) in - (match qualifier with - | "" -> Ast.unwrap ident - | q -> q ^ "." ^ Ast.unwrap ident) + | NewQualifiedClass _ -> ["Not supported"] + | Call(expr_,_) -> aux expr_ + | Dot (expr_, ident) -> + let qualifier = (aux expr_) in + (match qualifier with + | [] -> [Ast.unwrap ident] + | q -> q @ [Ast.unwrap ident] + ) | ArrayAccess _ | Postfix _ | Prefix _ @@ -925,20 +1007,66 @@ and resolve_call ast env (expr_,_) = | Cast _ | InstanceOf _ | Conditional _ - | Assignment _ -> "AssignmentNone" + | Assignment _ -> ["Not supported"] ) - in - let node_str = aux ast expr_ in - let node_str_o = dfs ~env ~node:env.current ~node_str:node_str ~get_edges:(fun - ~n -> G.succ n G.Use env.g) ~f:(fun node -> G.has_node (node, - E.Method) env.g) + in + let node_str_array = aux expr_ in + let node_str = (last node_str_array) in + let f a = join_list ~sep:"." a + in + let dfs_f = ref (dfs ~verbose:true ~env ~node:env.current ~get_edges:(fun + ~n -> G.succ n G.Use env.g) ~f:(fun node -> G.has_node + (node,E.Method) env.g) ) + in + (* + *if node_str = "addAccessibilityInteractionConnection" then + * dfs_f.contents <- (dfs ~verbose:true ~env ~node:env.current ~get_edges:(fun + * ~n -> G.succ n G.Use env.g) ~f:(fun node -> G.has_node + * (node,E.Method) env.g) ); + *) + let node_str_o = + (match node_str_array with + | [] -> None + | _::node_str_array_tl -> + (match dfs_f.contents ~node_str:(f node_str_array_tl) with + | (None, printer) -> + printer.contents <- printer.contents @ + ["MTM: lookup without first qualifier failed"]; + (match dfs_f.contents ~node_str:(f node_str_array) with + | (None, printer2) -> + let string_ = join_list ~sep:"\n" (printer.contents @ + printer2.contents) in + pr "Print dfs"; + pr string_; + None + | (Some a,_) -> Some a + ) + | (Some a, _) -> Some a + ) + ) + (* + *let node_str_o = + * (match dfs_f.contents ~node_str:(node_str) with + * | None -> + * (match node_str_array with + * | [] -> None + * | _::node_str_array_tl -> + * pr "MTM: lookup with first qualifier failed"; + * pr (f node_str_array_tl); + * pr (f node_str_array); + * dfs_f.contents ~node_str:(f node_str_array_tl) + * ) + * | str_o -> str_o + * ) + *) in (match node_str_o with - | None -> pr2 (spf "MTM: (resolve_call) lookup fail on %s" node_str) + | None -> + pr (spf "MTM: (resolve_call) lookup fail on %s" node_str) | Some str -> add_use_edge env (str, E.Method); pr (spf "MTM: (resolve_call) Edge drawn to method %s, %s" str - node_str) + node_str) ); () @@ -946,11 +1074,16 @@ and resolve_call ast env (expr_,_) = * relies on the fact that most method calls are of the form A.x(), where A is * an object. Also, it assumes that in type name, first element of the list can * be removed*) -and resolve_name _ast name_ = - match name_ with -(* | hd::[] -> str_of_name [hd] *) - | _::tl -> str_of_name tl - | [] -> "" +and resolve_name name_ = + List.map (fun (_tyarg_todo, ident) -> Ast.unwrap ident) name_ + + (* + * and resolve_namr _ast name_ = + *match name_ with + *| hd::[] -> str_of_name [hd] + *| _::tl -> str_of_name tl + *| [] -> "" + *) (* Finds the type of object, and prepends it to qualifying path and resolve_name ast name_ = @@ -1010,21 +1143,21 @@ and resolve_typ = function | TArray typ_ -> resolve_typ typ_ *) -and exprs ast env xs = List.iter (expr ast env) xs -and init ast env = function - | ExprInit e -> expr ast env e - | ArrayInit xs -> List.iter (init ast env) xs -and init_opt ast env opt = +and exprs env xs = List.iter (expr env) xs +and init env = function + | ExprInit e -> expr env e + | ArrayInit xs -> List.iter (init env) xs +and init_opt env opt = match opt with | None -> () - | Some ini -> init ast env ini + | Some ini -> init env ini (* ---------------------------------------------------------------------- *) (* Types *) (* ---------------------------------------------------------------------- *) -and typ _ast env = function +and typ env = function | TBasic _ -> () - | TArray t -> typ _ast env t + | TArray t -> typ env t (* other big dependency source! *) | TClass reft -> (* todo: let's forget generic arguments for now *) @@ -1065,20 +1198,20 @@ and typ _ast env = function (* ---------------------------------------------------------------------- *) (* Misc *) (* ---------------------------------------------------------------------- *) -and var ast env v = - typ ast env v.v_type; +and var env v = + typ env v.v_type; () -and field ast env f = - var ast env f.f_var; - init_opt ast env f.f_init; +and field env f = + var env f.f_var; + init_opt env f.f_init; () (*****************************************************************************) (* Main entry point *) (*****************************************************************************) -let build ?(verbose=true) ?(only_defs=false) root files = +let build ?(verbose=true) ?(only_defs=false) ?(method_to_method=false) root files = let g = G.create () in G.create_initial_hierarchy g; @@ -1117,6 +1250,8 @@ let build ?(verbose=true) ?(only_defs=false) root files = extract_defs_uses ~phase:Uses ~g ~ast ~readable ~lookup_fails; )); end; + if method_to_method then + begin if verbose then pr2 "\nstep4: methodtomethod"; (* pr "Step 4\n"; *) files +> Console.progress ~show:verbose (fun k -> @@ -1125,5 +1260,6 @@ let build ?(verbose=true) ?(only_defs=false) root files = let readable = Common.readable ~root file in let ast = parse ~show_parse_error:true file in extract_defs_uses ~phase:MethodToMethod ~g ~ast ~readable ~lookup_fails; - )); + )); + end; g diff --git a/lang_java/analyze/graph_code_java.mli b/lang_java/analyze/graph_code_java.mli index 96247da35..e889a5f2d 100644 --- a/lang_java/analyze/graph_code_java.mli +++ b/lang_java/analyze/graph_code_java.mli @@ -3,5 +3,6 @@ val build: ?verbose:bool -> (* for builtins_java.ml, tags_java.ml *) ?only_defs:bool -> + ?method_to_method:bool -> Common.path -> Common.filename list -> Graph_code.graph diff --git a/main_codegraph.ml b/main_codegraph.ml index 078562b73..36bed0021 100644 --- a/main_codegraph.ml +++ b/main_codegraph.ml @@ -328,6 +328,11 @@ let build_graph_code lang xs = | "clang2" -> Graph_code_clang.build ~verbose:!verbose root files, empty | "java" -> Graph_code_java.build ~verbose:!verbose root files, empty + + | "javam" -> Graph_code_java.build ~verbose:!verbose ~method_to_method:true + root files, empty (*TODO: move method_to_method option to build, and not + language - this takes more time to complete than the previous case so + setting a flag to activate it*) #if FEATURE_BYTECODE | "bytecode" -> let graph_code_java = None @@ -380,6 +385,7 @@ let build_graph_code lang xs = let build_stdlib lang root dst = let files = Find_source.files_of_root ~lang root in match lang with + | "javam" | "java" -> Builtins_java.extract_from_sources ~src:root ~dst files | "clang" -> From 346e173874087a601eba37094b5463f79d7cc6ef Mon Sep 17 00:00:00 2001 From: Krishna Vaidyanathan Date: Tue, 28 Apr 2015 00:00:13 +0530 Subject: [PATCH 3/6] Dfs on Use edges without repititions --- lang_java/analyze/graph_code_java.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/lang_java/analyze/graph_code_java.ml b/lang_java/analyze/graph_code_java.ml index 477b840c9..dc9ecf007 100644 --- a/lang_java/analyze/graph_code_java.ml +++ b/lang_java/analyze/graph_code_java.ml @@ -346,7 +346,7 @@ let op = Some node_str_hd | false -> let node_list = get_edges ~n:hd in - (match aux ~verbose ~node_str:node_str_hd ~d:(d+1) ~list_:node_list ~get_edges:get_edges ~f:f with + (match aux ~verbose ~node_str:node_str ~d:(d+1) ~list_:node_list ~get_edges:get_edges ~f:f with | None -> aux ~verbose ~d:d ~node_str:node_str ~list_:tl ~get_edges:get_edges ~f:f | Some x -> Some x ) @@ -1014,7 +1014,7 @@ and resolve_call env (expr_,_) = let node_str = (last node_str_array) in let f a = join_list ~sep:"." a in - let dfs_f = ref (dfs ~verbose:true ~env ~node:env.current ~get_edges:(fun + let dfs_f = ref (dfs ~verbose:false ~env ~node:env.current ~get_edges:(fun ~n -> G.succ n G.Use env.g) ~f:(fun node -> G.has_node (node,E.Method) env.g) ) in From d4b7ccc08dddd99bf531be489ee2d8fa8cebb45a Mon Sep 17 00:00:00 2001 From: Krishna Vaidyanathan Date: Tue, 28 Apr 2015 00:00:47 +0530 Subject: [PATCH 4/6] Method to method Use edge resolving: support for searching for method in nested classes. --- lang_java/analyze/graph_code_java.ml | 35 +++++++++++++++++++++++----- 1 file changed, 29 insertions(+), 6 deletions(-) diff --git a/lang_java/analyze/graph_code_java.ml b/lang_java/analyze/graph_code_java.ml index dc9ecf007..4ff4eb624 100644 --- a/lang_java/analyze/graph_code_java.ml +++ b/lang_java/analyze/graph_code_java.ml @@ -299,6 +299,29 @@ let dfs ?(verbose=false) ~env ~node ~node_str ~get_edges ~f = ^"." ^ node_str)) env.imported_qualified in + let check_current_class = + if not (f full_str) then + let base_class_o = + (match List.rev env.top_level_qualifer with + | [] -> None + | _::[] -> None + | _::a -> Some (List.rev a) + ) + in + (match base_class_o with + | Some base_class_list -> + (match f( (str_of_qualified_ident base_class_list) ^ "."^ + node_str) + with + | true -> Some (str_of_qualified_ident base_class_list + ^"."^node_str ) + | false -> None + ) + | None -> None + ) + else + Some full_str + in (* pr "Imported qualified"; pr (match f_imported_qualifier_check with @@ -315,22 +338,22 @@ let dfs ?(verbose=false) ~env ~node ~node_str ~get_edges ~f = *pr _str; *) let op = - (match (f full_str, f node_str, f_imported_namespace_check , f_imported_qualifier_check) with - | (false,false,Some str, _) -> + (match (check_current_class, f node_str, f_imported_namespace_check , f_imported_qualifier_check) with + | (None,false,Some str, _) -> if verbose = true then printer.contents <- printer.contents @ ["Imported namespace edge drawn"]; Some (join_list ~sep:"." str ^"."^node_str) - | (false, false, _ , Some (str,_)) -> + | (None, false, _ , Some (str,_)) -> if verbose = true then printer.contents <- printer.contents @[ "Imported qualifier edge drawn"]; Some ( str ^"." ^ node_str) - | (true,_,_,_) -> + | (Some str,_,_,_) -> if verbose = true then - printer.contents <- printer.contents @ ["Fully qualified "]; Some full_str + printer.contents <- printer.contents @ ["Fully qualified "]; Some str | (_,true,_,_) -> if verbose = true then printer.contents <- printer.contents @ ["Method name as is"]; Some node_str - | (false, false,None, None) -> + | (None, false,None, None) -> let rec aux ~verbose ~node_str ~d ~list_ ~get_edges ~f = (* Maximum depth that the funtion searched uptil *) if (d < 10) then From 5c8bb9b3e6567af20f20fc237210727c172791bf Mon Sep 17 00:00:00 2001 From: Krishna Vaidyanathan Date: Tue, 28 Apr 2015 00:01:21 +0530 Subject: [PATCH 5/6] Added docstrings, modified flow of fuctions and function names. Also fixed bug in fn read_from_last --- lang_java/analyze/graph_code_java.ml | 449 ++++++++++++--------------- 1 file changed, 193 insertions(+), 256 deletions(-) diff --git a/lang_java/analyze/graph_code_java.ml b/lang_java/analyze/graph_code_java.ml index 4ff4eb624..40805be03 100644 --- a/lang_java/analyze/graph_code_java.ml +++ b/lang_java/analyze/graph_code_java.ml @@ -13,11 +13,10 @@ * license.txt for more details. *) open Common +open Ast_java module E = Entity_code module G = Graph_code - -open Ast_java module Ast = Ast_java module PI = Parse_info module V = Visitor_java @@ -106,6 +105,11 @@ type env = { (*****************************************************************************) (* Helpers *) (*****************************************************************************) + +(* + *Iterates over list [a1; a2; ... ] with f until f ai returns true. Return Some f ai, + *or None if f returns false for all ai's + *) let rec iter_until_true ~f list_ = match list_ with | [] -> None @@ -114,31 +118,53 @@ let rec iter_until_true ~f list_ = | false -> iter_until_true ~f tl | true -> Some hd -let rec fold_inner ~acc ~f ~x = - (match x with - | [] -> acc - | hd::tl -> fold_inner ~acc:(f acc hd) ~f:f ~x:tl - ) - -let fold x_list ~init ~f = - fold_inner ~acc:init ~x:x_list ~f:f - -let last = function - | hd::tl -> List.fold_left (fun _ y -> y) hd tl - | [] -> failwith "no element" +(* + *Fold function, already defined in commons/common.ml in git_diff parser version + *of pfff. Should use that when integrating + *) +let fold x_list ~init ~f = + let rec aux ~acc ~x ~f= + (match x with + | [] -> acc + | hd::tl -> aux ~acc:(f acc hd) ~f:f ~x:tl + ) + in + aux ~acc:init ~x:x_list ~f:f + +(* + *Returns last element of list and the beginning of the list too, think of it as + *of let a::b = list_, in reverse + *) +let last_and_beginning_of_list list_ = + match List.rev list_ with + | [] -> None + | last::[] -> Some (last,[]) + | last::rest -> Some (last, List.rev rest) + +(*Returns string list, without string x as an element *) +let remove_char_from_string_list x x_list = + List.flatten (List.map + (fun y -> + if y = x then [] + else + [y] + ) + x_list) - let join_list ~sep a= +(*Joins string list, into a string with a separator *) +let join_list ~sep a= let a = - (match a with - | "this"::tl -> tl - | _ -> a) - in - let aux = fold ~init:"" ~f:(fun a b -> (Common.join sep [a;b])) in (match a with - | [] -> "" - | [a] -> a - | hd::tl -> hd ^ (aux tl) + | "this"::tl -> tl + | _ -> a ) + in + let aux = fold ~init:"" ~f:(fun a b -> (Common.join sep [a;b])) in + (match a with + | [] -> "" + | [a] -> a + | hd::tl -> hd ^ (aux tl) + ) let parse ~show_parse_error file = try @@ -159,23 +185,6 @@ let str_of_name xs = xs +> List.map (fun (_tyarg_todo, ident) -> Ast.unwrap ident) +> Common.join "." -(*let str_of_class_type xs =*) - (*xs +> List.map (fun (ident, _tyarg_todo) -> Ast.unwrap ident) +>*) - (*Common.join "."*) - -(* Same as str_of_qualified_ident except neglects super and this *) -(* - *let str_of_name_this_super xs= - * (match xs with - * | (_,hd)::tl -> (match Ast.unwrap hd with - * | "super" - * | "this" -> str_of_name tl - * | _ -> str_of_name xs - * ) - * | [] -> "") - * - *) - (* helper to build entries in env.params_or_locals *) let p_or_l v = Ast.unwrap v.v_name, Ast.is_final v.v_mods @@ -289,16 +298,36 @@ let dfs ?(verbose=false) ~env ~node ~node_str ~get_edges ~f = begin pr (spf "dfs on str: %s, %s" full_str node_str); pr (spf "Current method/class/fied: %s" (str_of_qualified_ident env.current_qualifier ^"."^node_str)); - end; + end; + (*Checks if method exists in imported namespaces *) + (*if verbose = true then*) + (*pr "imported_namespace_check";*) let f_imported_namespace_check = - iter_until_true ~f:(fun a-> f ((join_list ~sep:"." a) ^ "." ^ node_str)) + iter_until_true ~f:(fun a-> let str = (( a +> remove_char_from_string_list + "*" +> (join_list ~sep:".") ) ^ "." ^ node_str) in + let is_node_present = f str in + (*if verbose = true then*) + (*begin*) + (*pr str; *) + (*end;*) + is_node_present ) env.imported_namespace in + (*Checks if method exists in imported qualifiers *) + (*if verbose = true then*) + (*pr "imported_qualifier_check"; *) let f_imported_qualifier_check = - iter_until_true ~f:(fun (a,(_,b))-> f (a ^ "."^(str_of_qualified_ident b) - ^"." ^ node_str)) + iter_until_true ~f:(fun (a,(_,b))-> let str = (a ^ "."^(str_of_qualified_ident b) + ^"." ^ node_str) in + let is_node_present = f str in + (*if verbose = true then*) + (*begin*) + (*pr str;*) + (*end;*) + is_node_present) env.imported_qualified in + (*Checks if method exists in current class, or main class - for nested classes*) let check_current_class = if not (f full_str) then let base_class_o = @@ -322,71 +351,59 @@ let dfs ?(verbose=false) ~env ~node ~node_str ~get_edges ~f = else Some full_str in -(* - pr "Imported qualified"; - pr (match f_imported_qualifier_check with - | Some (str,_) -> str - | None -> "None" - ); -*) - (* - *let _str = - * match env.imported_qualified with - * | [] -> "" - * | (hd,(_,b))::_ -> hd ^"."^ (str_of_qualified_ident b)^"."^node_str - *in - *pr _str; - *) -let op = - (match (check_current_class, f node_str, f_imported_namespace_check , f_imported_qualifier_check) with - | (None,false,Some str, _) -> - if verbose = true then - printer.contents <- printer.contents @ ["Imported namespace edge drawn"]; - Some (join_list ~sep:"." str ^"."^node_str) - | (None, false, _ , Some (str,_)) -> - if verbose = true then - printer.contents <- printer.contents @[ "Imported qualifier edge drawn"]; - Some ( str ^"." ^ node_str) - | (Some str,_,_,_) -> - if verbose = true then - printer.contents <- printer.contents @ ["Fully qualified "]; Some str - | (_,true,_,_) -> - if verbose = true then - printer.contents <- printer.contents @ ["Method name as is"]; Some node_str - | (None, false,None, None) -> - let rec aux ~verbose ~node_str ~d ~list_ ~get_edges ~f = -(* Maximum depth that the funtion searched uptil *) - if (d < 10) then - begin - (match list_ with - | [] -> None - | hd::tl -> - let node_str_hd = (fst hd) ^ "." ^ node_str in - if verbose = true then - printer.contents <- printer.contents @ [node_str_hd]; - (match f node_str_hd with - | true -> - Some node_str_hd - | false -> - let node_list = get_edges ~n:hd in - (match aux ~verbose ~node_str:node_str ~d:(d+1) ~list_:node_list ~get_edges:get_edges ~f:f with - | None -> aux ~verbose ~d:d ~node_str:node_str ~list_:tl ~get_edges:get_edges ~f:f - | Some x -> Some x - ) - ) - ) - end - else - None - in - (match aux ~verbose ~d:0 ~node_str:node_str ~list_:(get_edges - ~n:node) ~get_edges:get_edges ~f with - | Some x -> printer.contents <- printer.contents @ ["dfs, node existing"]; Some x - | None -> None - ) - ) -in - (op, printer) + + let op = + (match (check_current_class, f node_str, f_imported_namespace_check , f_imported_qualifier_check) with + | (None,false,Some str, _) -> + if verbose = true then + printer.contents <- printer.contents @ ["Imported namespace edge drawn"]; + + Some ( (str +> remove_char_from_string_list "*" +> join_list ~sep:".") ^ "." ^ node_str) + (*Some (join_list ~sep:"." str ^"."^node_str)*) + | (None, false, _ , Some (str,_)) -> + if verbose = true then + printer.contents <- printer.contents @[ "Imported qualifier edge drawn"]; + Some ( str ^ "." ^ node_str ) + | (Some str,_,_,_) -> + if verbose = true then + printer.contents <- printer.contents @ ["Fully qualified "]; Some str + | (_,true,_,_) -> + if verbose = true then + printer.contents <- printer.contents @ ["Method name as is"]; Some node_str + | (None, false,None, None) -> + let rec aux ~verbose ~node_str ~d ~list_ ~get_edges ~f = + (* Maximum depth that the funtion searched uptil *) + if (d < 10) then + begin + (match list_ with + | [] -> None + | hd::tl -> + let node_str_hd = (fst hd) ^ "." ^ node_str in + if verbose = true then + printer.contents <- printer.contents @ [node_str_hd]; + (match f node_str_hd with + | true -> + Some node_str_hd + | false -> + let node_list = get_edges ~n:hd in + (match aux ~verbose ~node_str:node_str ~d:(d+1) ~list_:node_list ~get_edges:get_edges ~f:f with + | None -> aux ~verbose ~d:d ~node_str:node_str ~list_:tl ~get_edges:get_edges ~f:f + | Some x -> Some x + ) + ) + ) + end + else + None + in + (match aux ~verbose ~d:0 ~node_str:node_str ~list_:(get_edges + ~n:node) ~get_edges:get_edges ~f with + | Some x -> printer.contents <- printer.contents @ ["dfs, node existing"]; Some x + | None -> None + ) + ) + in + (op, printer) (*****************************************************************************) (* Class/Package Lookup *) @@ -1007,91 +1024,77 @@ and expr env = function (* TODO: Remove ast, if it is not used *) and resolve_call env (expr_,_) = - let rec aux expr_ = - (match expr_ with - | Name name_ -> resolve_name name_ - | NameOrClassType _ - | Literal _ - | ClassLiteral _ - | NewClass _ - | NewArray _ - | NewQualifiedClass _ -> ["Not supported"] - | Call(expr_,_) -> aux expr_ - | Dot (expr_, ident) -> - let qualifier = (aux expr_) in - (match qualifier with - | [] -> [Ast.unwrap ident] - | q -> q @ [Ast.unwrap ident] - ) - | ArrayAccess _ - | Postfix _ - | Prefix _ - | Infix _ - | Cast _ - | InstanceOf _ - | Conditional _ - | Assignment _ -> ["Not supported"] + let rec aux expr_ = + (match expr_ with + | Name name_ -> resolve_name name_ + | NameOrClassType _ + | Literal _ + | ClassLiteral _ + | NewClass _ + | NewArray _ + | NewQualifiedClass _ -> ["Not supported"] + | Call(expr_,_) -> aux expr_ + | Dot (expr_, ident) -> + let qualifier = (aux expr_) in + (match qualifier with + | [] -> [Ast.unwrap ident] + | q -> q @ [Ast.unwrap ident] ) - in - let node_str_array = aux expr_ in - let node_str = (last node_str_array) in - let f a = join_list ~sep:"." a - in - let dfs_f = ref (dfs ~verbose:false ~env ~node:env.current ~get_edges:(fun - ~n -> G.succ n G.Use env.g) ~f:(fun node -> G.has_node + | ArrayAccess _ + | Postfix _ + | Prefix _ + | Infix _ + | Cast _ + | InstanceOf _ + | Conditional _ + | Assignment _ -> ["Not supported"] + ) + in + let node_str_array = aux expr_ in + (*let node_str = (Common2.list_last node_str_array) in*) + (* + *Verbose flag can be set to false/true here. Stack overflow error + *results when imported namespaces & qualifiers is printed, so commented out. + *) + let dfs_f = ref (dfs ~verbose:false ~env ~node:env.current ~get_edges:(fun + ~n -> G.succ n G.Use env.g) ~f:(fun node -> G.has_node (node,E.Method) env.g) ) - in - (* - *if node_str = "addAccessibilityInteractionConnection" then - * dfs_f.contents <- (dfs ~verbose:true ~env ~node:env.current ~get_edges:(fun - * ~n -> G.succ n G.Use env.g) ~f:(fun node -> G.has_node - * (node,E.Method) env.g) ); - *) - let node_str_o = - (match node_str_array with - | [] -> None - | _::node_str_array_tl -> - (match dfs_f.contents ~node_str:(f node_str_array_tl) with - | (None, printer) -> - printer.contents <- printer.contents @ - ["MTM: lookup without first qualifier failed"]; - (match dfs_f.contents ~node_str:(f node_str_array) with - | (None, printer2) -> - let string_ = join_list ~sep:"\n" (printer.contents @ - printer2.contents) in - pr "Print dfs"; - pr string_; - None - | (Some a,_) -> Some a - ) - | (Some a, _) -> Some a + in + let read_from_last ~node_str_list ~f = + let printer = ref [""] in + let rec aux ~acc ~node_str_list ~f = + (match last_and_beginning_of_list node_str_list with + | Some (last_node, rest) -> + (match f (last_node ^ acc ) with + | (Some a,_) -> Some a + | (None, printer2) -> + printer.contents <- printer.contents @ printer2.contents; + let acc2 = "."^last_node ^ acc + in + aux ~acc:acc2 ~node_str_list:rest ~f ) - ) - (* - *let node_str_o = - * (match dfs_f.contents ~node_str:(node_str) with - * | None -> - * (match node_str_array with - * | [] -> None - * | _::node_str_array_tl -> - * pr "MTM: lookup with first qualifier failed"; - * pr (f node_str_array_tl); - * pr (f node_str_array); - * dfs_f.contents ~node_str:(f node_str_array_tl) - * ) - * | str_o -> str_o - * ) - *) - in - (match node_str_o with | None -> - pr (spf "MTM: (resolve_call) lookup fail on %s" node_str) - | Some str -> - add_use_edge env (str, E.Method); - pr (spf "MTM: (resolve_call) Edge drawn to method %s, %s" str - node_str) - ); - () + pr "Print dfs"; + pr (join_list ~sep:"\n" printer.contents); + None + ) + in + aux ~acc:"" ~node_str_list ~f + in + let node_str_o = + read_from_last ~node_str_list:node_str_array ~f:(fun x -> dfs_f.contents + ~node_str: x ) + in + (match node_str_o with + | None -> + pr (spf "MTM: (resolve_call) lookup fail on method %s, source: %s " (node_str_array +> + join_list ~sep:".") (env.current_qualifier +> str_of_qualified_ident) ) + | Some str -> + add_use_edge env (str, E.Method); + pr (spf "MTM: (resolve_call) Edge drawn to method %s, resolved qualifier: %s, source: %s" (node_str_array +> join_list ~sep:".") str + (env.current_qualifier +> str_of_qualified_ident)) + ); + () (* Removes the object's name in method calls, NOTE: this is a heuristic which * relies on the fact that most method calls are of the form A.x(), where A is @@ -1099,73 +1102,7 @@ and resolve_call env (expr_,_) = * be removed*) and resolve_name name_ = List.map (fun (_tyarg_todo, ident) -> Ast.unwrap ident) name_ - - (* - * and resolve_namr _ast name_ = - *match name_ with - *| hd::[] -> str_of_name [hd] - *| _::tl -> str_of_name tl - *| [] -> "" - *) -(* Finds the type of object, and prepends it to qualifying path -and resolve_name ast name_ = - let flag = ref true in - let field_name_ = match name_ with - | hd::_ -> Ast.unwrap (snd hd) - | [] -> flag.contents <- false; - pr " field_name_ []"; - "None" - in - let str = ref (str_of_name_this_super name_) in - let traverse_ast = V.mk_visitor { V.default_visitor with - (* Only handling fields, as visitor functions are written only for it*) - V.kfield= ( fun(k,_) d-> - (match d with - | field -> - let field_name = fst (field.f_var.v_name) in - if field_name = field_name_ then - begin - pr "field_name equal \n"; - pr "field_name_ "; - pr field_name_; -(* flag.contents <- true; *) - let object_name = resolve_typ field.f_var.v_type in - let str_name_td = match name_ with - | [] -> flag.contents <- false; - (* pr "str_name_td []"; *) - "None" - | _::name_td -> str_of_name_this_super name_td - in - (* - *pr "str_name_td"; - *pr str_name_td; - *pr "--------"; - *) - str.contents <- - (match str_name_td with - | "" -> object_name - | q -> object_name ^ "."^q - ) - end; - - ); - k d - ) - - } - in traverse_ast(Ast.AProgram ast); - if flag.contents = true then - str.contents - else - str_of_name_this_super name_ - -and resolve_typ = function - | TBasic ident_ -> Ast.unwrap ident_ - | TClass class_type_ -> str_of_class_type class_type_ - | TArray typ_ -> resolve_typ typ_ - -*) and exprs env xs = List.iter (expr env) xs and init env = function | ExprInit e -> expr env e From c6096aa512a168931a1204756fd41474ad6ae613 Mon Sep 17 00:00:00 2001 From: Krishna Vaidyanathan Date: Tue, 19 May 2015 09:05:42 +0530 Subject: [PATCH 6/6] Refactored functions in graph_code_java.ml, changed option to set method to method calls in java. eg., ./codegraph -lang java -build -method_to_method If option -method_to_method is not set, by default set to false --- find_source.ml | 2 - lang_java/analyze/graph_code_java.ml | 462 ++++++++++++++------------- main_codegraph.ml | 13 +- 3 files changed, 241 insertions(+), 236 deletions(-) diff --git a/find_source.ml b/find_source.ml index f57905e26..5e05da3a1 100644 --- a/find_source.ml +++ b/find_source.ml @@ -17,8 +17,6 @@ let finder lang = Lib_parsing_ml.find_cmt_files_of_dir_or_files | "java" -> Lib_parsing_java.find_source_files_of_dir_or_files - | "javam" -> - Lib_parsing_java.find_source_files_of_dir_or_files | "js" -> Lib_parsing_js.find_source_files_of_dir_or_files ~include_scripts:false | "clang2" -> diff --git a/lang_java/analyze/graph_code_java.ml b/lang_java/analyze/graph_code_java.ml index 40805be03..cb9543975 100644 --- a/lang_java/analyze/graph_code_java.ml +++ b/lang_java/analyze/graph_code_java.ml @@ -65,6 +65,16 @@ module V = Visitor_java * *) +(*****************************************************************************) +(* Constants *) +(*****************************************************************************) +let depth_of_dfs = 10 + +(*****************************************************************************) +(* Global variables *) +(*****************************************************************************) +let printer = ref [""] + (*****************************************************************************) (* Types *) (*****************************************************************************) @@ -74,7 +84,10 @@ type env = { phase: phase; current: Graph_code.node; current_qualifier: Ast_java.qualified_ident; - (*Track class classifiers, for mapping nodes *) + (* top_level_qualifier class qualifiers, for method calls. current_qualifier + * tracks field/method in ast. This is not needed, adds extra qualifiers + * which might get in the way. + * *) top_level_qualifer: Ast_java.qualified_ident; (* import x.y.* => [["x";"y"]; ...] *) imported_namespace: (string list) list; @@ -99,6 +112,9 @@ type env = { * The inheritance is a kind of use, but certain uses like using * a field needs the full inheritance tree to already be computed * as we may need to lookup entities up in the parents. + * + * Note: 4th phase MethodToMethod added for adding edges during method + * call. *) and phase = Defs | Inheritance | Uses | MethodToMethod @@ -106,9 +122,8 @@ type env = { (* Helpers *) (*****************************************************************************) -(* - *Iterates over list [a1; a2; ... ] with f until f ai returns true. Return Some f ai, - *or None if f returns false for all ai's +(* Iterates over list [a1; a2; ... ] with f until f ai returns true. Returns + * Some f ai, or None if f returns false for all ai's *) let rec iter_until_true ~f list_ = match list_ with @@ -117,23 +132,9 @@ let rec iter_until_true ~f list_ = match f hd with | false -> iter_until_true ~f tl | true -> Some hd - -(* - *Fold function, already defined in commons/common.ml in git_diff parser version - *of pfff. Should use that when integrating - *) -let fold x_list ~init ~f = - let rec aux ~acc ~x ~f= - (match x with - | [] -> acc - | hd::tl -> aux ~acc:(f acc hd) ~f:f ~x:tl - ) - in - aux ~acc:init ~x:x_list ~f:f - -(* - *Returns last element of list and the beginning of the list too, think of it as - *of let a::b = list_, in reverse + +(* Returns last element of list and the beginning of the list too, think of it + * as of let a::b = list_, in reverse *) let last_and_beginning_of_list list_ = match List.rev list_ with @@ -141,17 +142,21 @@ let last_and_beginning_of_list list_ = | last::[] -> Some (last,[]) | last::rest -> Some (last, List.rev rest) -(*Returns string list, without string x as an element *) -let remove_char_from_string_list x x_list = - List.flatten (List.map - (fun y -> - if y = x then [] - else - [y] - ) - x_list) - -(*Joins string list, into a string with a separator *) +(* Removes element x from x_list, returns (x_list \ x). + * eg. remove_element_from_list "*" ["A";"B";"*"] => ["A";"B"] + *) +let remove_element_from_list x x_list = + x_list +> List.filter (fun s -> + match s with + | _ when s = x -> false + | _ -> true) + +(* Joins string list, into a string with a separator. Similar function + * commons/join, joins string list with separator. But want to check for + * "this" operator (occurs at the beginning) and neglect [] + * sep is the separator, when joining elements of string list. + * eg. join_list ~sep:"." ["a1";...;"an"] => "a1.a2...an" + *) let join_list ~sep a= let a = (match a with @@ -159,12 +164,7 @@ let join_list ~sep a= | _ -> a ) in - let aux = fold ~init:"" ~f:(fun a b -> (Common.join sep [a;b])) in - (match a with - | [] -> "" - | [a] -> a - | hd::tl -> hd ^ (aux tl) - ) + String.concat sep a let parse ~show_parse_error file = try @@ -244,10 +244,11 @@ let add_use_edge env (name, kind) = let dst = (name, kind) in (match () with | _ when not (G.has_node src env.g) -> - if env.phase = MethodToMethod then - pr2 (spf "MTM: (add_use_edge) lookup fail on %s" name) - else - pr2 (spf "LOOKUP SRC FAIL %s --> %s, src does not exist???" (G.string_of_node src) (G.string_of_node dst)); + if env.phase = MethodToMethod then + pr2 (spf "MTM: (add_use_edge) lookup fail on %s" name) + else + pr2 (spf "LOOKUP SRC FAIL %s --> %s, src does not exist???" + (G.string_of_node src) (G.string_of_node dst)); | _ when G.has_node dst env.g -> G.add_edge (src, dst) G.Use env.g | _ -> @@ -277,7 +278,8 @@ let add_use_edge env (name, kind) = pr2 (spf "MTM: (add_use_edge) lookup fail on %s (in %s)" (G.string_of_node dst) (G.string_of_node src)) | _ -> - pr2 (spf "PB: lookup fail on %s (in %s)" (G.string_of_node dst) (G.string_of_node src)); + pr2 (spf "PB: lookup fail on %s (in %s)" (G.string_of_node dst) + (G.string_of_node src)); G.add_node dst env.g; env.g +> G.add_edge (parent_target, dst) G.Has; env.g +> G.add_edge (src, dst) G.Use; @@ -285,49 +287,88 @@ let add_use_edge env (name, kind) = ) ) - -(* - *Depth first search, checks which class path has the method called in the current - *node's successors +(* Auxiliary function for dfs, does depth first search on node, with name:node_str + * Params: + * - verbose: If set to true, prints log for debugging + * - node_str: string of method name (eg. calledFn(), string is "calledFn") + * - d: height upto which dfs searchs to + * - list_: Successors of node with name:node_str + * - get_succ: Successor nodes of passed node is returned + * - f: checks if graph contains node with passed string as name *) -let dfs ?(verbose=false) ~env ~node ~node_str ~get_edges ~f = - let printer = ref [""] in - let full_str = (str_of_qualified_ident env.top_level_qualifer) ^"." ^ +let rec dfs_aux ~verbose ~node_str ~d ~list_ ~get_succ ~f = +(* Maximum depth that the funtion searched uptil *) + if (d < depth_of_dfs) then + begin + (match list_ with + (* No successor *) + | [] -> None + (* More than one element in list *) + | hd::tl -> + let node_str_hd = (fst hd) ^ "." ^ node_str in + if verbose = true then + printer.contents <- printer.contents @ [node_str_hd]; + (match f node_str_hd with + (* Node with name:node_str_hd exists *) + | true -> + Some node_str_hd + (* No node with name:node_str_hd exists, search child of node_str_hd *) + | false -> + let node_list = get_succ ~n:hd in + (match dfs_aux ~verbose ~node_str:node_str ~d:(d+1) ~list_:node_list + ~get_succ:get_succ ~f:f with + (* Search in siblings of node_str_hd *) + | None -> dfs_aux ~verbose ~d:d ~node_str:node_str ~list_:tl + ~get_succ:get_succ ~f:f + | Some x -> Some x + ) + ) + ) + end + else + None + +(* Method calls: method needs to be identified in the graph, so that edge can + * be drawn to it, from the node called. Method call is generally not in the + * fully qualified form, so to search for method in the graph, method name with + * fully qualified name is required. To guess fully qualified name, the + * successors of the source node is searched. The class paths of the successors + * are prepended to the method name and checked. If unsuccessful, go further up + * (successor of successor etc.), i.e dfs. + * Params: + * - verbose: If set to true, prints log for debugging + * - env: type env defined above + * - node: graph node called from + * - node_str: string of method name (eg. calledFn(), string is "calledFn") + * - get_succ: Successor nodes of passed node is returned + * - f: checks if graph contains node with passed string as name + * Returns string option of fully qualified method, if not resolved it returns + * None. + *) +let dfs ?(verbose=false) ~env ~node ~node_str ~get_succ ~f = + let full_str = (str_of_qualified_ident env.top_level_qualifer) ^ "." ^ node_str in if verbose = true then begin - pr (spf "dfs on str: %s, %s" full_str node_str); - pr (spf "Current method/class/fied: %s" (str_of_qualified_ident env.current_qualifier ^"."^node_str)); + printer.contents <- printer.contents @ [(spf "dfs on str: %s, %s" full_str + node_str)]; + printer.contents <- printer.contents @ [(spf "Current method/class/fied: %s" + (str_of_qualified_ident env.current_qualifier ^ "." ^ node_str))]; end; - (*Checks if method exists in imported namespaces *) - (*if verbose = true then*) - (*pr "imported_namespace_check";*) - let f_imported_namespace_check = - iter_until_true ~f:(fun a-> let str = (( a +> remove_char_from_string_list - "*" +> (join_list ~sep:".") ) ^ "." ^ node_str) in - let is_node_present = f str in - (*if verbose = true then*) - (*begin*) - (*pr str; *) - (*end;*) - is_node_present ) - env.imported_namespace + (* Checks if method exists in imported namespaces *) + let f_imported_namespace_check = iter_until_true ~f:(fun a -> + let str = (( a +> remove_element_from_list + "*" +> (join_list ~sep:".") ) ^ "." ^ node_str) in + let is_node_present = f str in + is_node_present) env.imported_namespace in - (*Checks if method exists in imported qualifiers *) - (*if verbose = true then*) - (*pr "imported_qualifier_check"; *) - let f_imported_qualifier_check = - iter_until_true ~f:(fun (a,(_,b))-> let str = (a ^ "."^(str_of_qualified_ident b) - ^"." ^ node_str) in - let is_node_present = f str in - (*if verbose = true then*) - (*begin*) - (*pr str;*) - (*end;*) - is_node_present) - env.imported_qualified + (* Checks if method exists in imported qualifiers *) + let f_imported_qualifier_check = iter_until_true ~f:(fun (a,(_,b)) -> + let str = (a ^ "."^ (str_of_qualified_ident b) ^ "." ^ node_str) in + let is_node_present = f str in + is_node_present) env.imported_qualified in - (*Checks if method exists in current class, or main class - for nested classes*) + (* Checks if method exists in current class, or main class - for nested classes *) let check_current_class = if not (f full_str) then let base_class_o = @@ -339,11 +380,11 @@ let dfs ?(verbose=false) ~env ~node ~node_str ~get_edges ~f = in (match base_class_o with | Some base_class_list -> - (match f( (str_of_qualified_ident base_class_list) ^ "."^ - node_str) + (match f((str_of_qualified_ident base_class_list) ^ "." ^ + node_str) with | true -> Some (str_of_qualified_ident base_class_list - ^"."^node_str ) + ^ "." ^ node_str ) | false -> None ) | None -> None @@ -351,59 +392,46 @@ let dfs ?(verbose=false) ~env ~node ~node_str ~get_edges ~f = else Some full_str in - - let op = - (match (check_current_class, f node_str, f_imported_namespace_check , f_imported_qualifier_check) with - | (None,false,Some str, _) -> - if verbose = true then - printer.contents <- printer.contents @ ["Imported namespace edge drawn"]; - - Some ( (str +> remove_char_from_string_list "*" +> join_list ~sep:".") ^ "." ^ node_str) - (*Some (join_list ~sep:"." str ^"."^node_str)*) - | (None, false, _ , Some (str,_)) -> - if verbose = true then - printer.contents <- printer.contents @[ "Imported qualifier edge drawn"]; - Some ( str ^ "." ^ node_str ) - | (Some str,_,_,_) -> - if verbose = true then - printer.contents <- printer.contents @ ["Fully qualified "]; Some str - | (_,true,_,_) -> - if verbose = true then - printer.contents <- printer.contents @ ["Method name as is"]; Some node_str - | (None, false,None, None) -> - let rec aux ~verbose ~node_str ~d ~list_ ~get_edges ~f = - (* Maximum depth that the funtion searched uptil *) - if (d < 10) then - begin - (match list_ with - | [] -> None - | hd::tl -> - let node_str_hd = (fst hd) ^ "." ^ node_str in - if verbose = true then - printer.contents <- printer.contents @ [node_str_hd]; - (match f node_str_hd with - | true -> - Some node_str_hd - | false -> - let node_list = get_edges ~n:hd in - (match aux ~verbose ~node_str:node_str ~d:(d+1) ~list_:node_list ~get_edges:get_edges ~f:f with - | None -> aux ~verbose ~d:d ~node_str:node_str ~list_:tl ~get_edges:get_edges ~f:f - | Some x -> Some x - ) - ) - ) - end - else - None - in - (match aux ~verbose ~d:0 ~node_str:node_str ~list_:(get_edges - ~n:node) ~get_edges:get_edges ~f with - | Some x -> printer.contents <- printer.contents @ ["dfs, node existing"]; Some x - | None -> None - ) - ) - in - (op, printer) + (* Four tuple checks for: + * check_current_class + * - Returns Some string, if method gets resolved in current class, or base + * class (if nested clasas) + * f node_str: + * - Returns true if node_str is a fully qualified name of the method. + * f_imported_namespace_check: + * - Returns Some string list of namespace, for which method gets resolved. + * None if method isn't resolved in any of the namespaces + * f_imported_qualifier_check: + * - Similar to f_imported_namespace_check, but checks imported qualifiers. + *) + (match (check_current_class, f node_str, f_imported_namespace_check , + f_imported_qualifier_check) with + | (None, false, Some str_list, _) -> + if verbose = true then + printer.contents <- printer.contents @ ["Imported namespace edge drawn"]; + Some ((str_list +> remove_element_from_list "*" +> join_list ~sep:".") + ^ "." ^ node_str) + | (None, false, _, Some (str_list, _)) -> + if verbose = true then + printer.contents <- printer.contents @ ["Imported qualifier edge drawn"]; + Some (str_list ^ "." ^ node_str) + | (Some str, _, _, _) -> + if verbose = true then + printer.contents <- printer.contents @ ["Fully qualified"]; + Some str + | (_, true, _, _) -> + if verbose = true then + printer.contents <- printer.contents @ ["Method name as is"]; + Some node_str + | (None, false, None, None) -> + (match dfs_aux ~verbose ~d:0 ~node_str:node_str ~list_:(get_succ + ~n:node) ~get_succ:get_succ ~f with + | Some str -> + printer.contents <- printer.contents @ ["dfs, node existing"]; + Some str + | None -> None + ) + ) (*****************************************************************************) (* Class/Package Lookup *) @@ -489,7 +517,7 @@ let rec extract_defs_uses ~phase ~g ~ast ~readable ~lookup_fails = current = (match ast.package with | Some long_ident -> (str_of_qualified_ident long_ident, E.Package) - | None -> (readable, E.File) + | None -> (readable, E.File) ); current_qualifier = (match ast.package with @@ -531,24 +559,18 @@ let rec extract_defs_uses ~phase ~g ~ast ~readable ~lookup_fails = match ast.package with (* have None usually for scripts, tests, or entry points *) | None -> -(* pr "None --\n"; *) let dir = Common2.dirname readable in G.create_intermediate_directories_if_not_present g dir; - pr "Create defs"; - pr readable; g +> G.add_node (readable, E.File); g +> G.add_edge ((dir, E.Dir), (readable, E.File)) G.Has; | Some long_ident -> -(* pr "Some long_indent\n"; *) create_intermediate_packages_if_not_present g G.root long_ident; -(* pr "End Some long indent\n"; *) end; (* double check if we can find some of the imports * (especially useful when have a better java_stdlib/ to report * third-party packages not-yet handled). *) if phase = Inheritance then begin -(* pr "Phase inheritance \n"; *) ast.imports +> List.iter (fun (_is_static, qualified_ident) (* Replaced is_static with _is_static *)-> let qualified_ident_bis = @@ -584,20 +606,11 @@ let rec extract_defs_uses ~phase ~g ~ast ~readable ~lookup_fails = (* Declarations (classes, fields, etc) *) (* ---------------------------------------------------------------------- *) and decl env = function - | Class def, _ -> -(* pr "Class def \n"; *) - class_decl env def - | Method def, _ -> -(* pr "method def\n"; *) - method_decl env def - | Field def, _ -> -(* pr "Def\n"; *) - field_decl env def - | Enum def, _ -> -(* pr "Enum\n"; *) - enum_decl env def + | Class def, _ -> class_decl env def + | Method def, _ -> method_decl env def + | Field def, _ -> field_decl env def + | Enum def, _ -> enum_decl env def | Init (_is_static, st), n -> -(* pr "Init\n"; *) let name = spf "__init__%d" n in let full_ident = env.current_qualifier @ [name, fakeInfo name] in let full_str = str_of_qualified_ident full_ident in @@ -614,32 +627,23 @@ and decl env = function stmt env st and decls env xs = -(* pr "Decls env xs \n"; *) List.iter (decl env) (Common.index_list_1 xs); -(* pr "Done with decls env xs" *) and class_decl env def = -(* pr "Class decl env def\n"; *) let full_ident = env.current_qualifier @ [def.cl_name] in let full_str = str_of_qualified_ident full_ident in let node = (full_str, E.Class) in -(* pr "env.phase = Defs\n "; *) if env.phase = Defs then begin (* less: def.c_type? *) - begin -(* pr "Inside begin block\n"; *) - if not (G.has_node node env.g) then - begin -(* pr "Not existing"; *) -(* pr "This is not in the if block"; *) - env.g +> G.add_node node; - env.g +> G.add_nodeinfo node (nodeinfo def.cl_name); - env.g +> G.add_edge (env.current, node) G.Has; -(* pr "This is not the error" *) - end; + begin + if not (G.has_node node env.g) then + begin + env.g +> G.add_node node; + env.g +> G.add_nodeinfo node (nodeinfo def.cl_name); + end; + env.g +> G.add_edge (env.current, node) G.Has; end; end; -(* pr "End adding nodes\n"; *) let env = { env with current = node; current_qualifier = full_ident; @@ -651,14 +655,11 @@ and class_decl env def = ); } in -(* pr "parents operation \n"; *) let parents = Common2.option_to_list def.cl_extends @ (def.cl_impls) in -(* pr "List iter \n"; *) List.iter (typ env) parents; -(* pr "imports \n"; *) let imports = if env.phase = Defs then [] else @@ -688,13 +689,10 @@ and method_decl env def = if G.has_node (full_str, E.Method) env.g then () else begin - (*pr "Print Method";*) - (*pr full_str;*) - (*pr "----";*) env.g +> G.add_node node; env.g +> G.add_nodeinfo node (nodeinfo def.m_var.v_name); - env.g +> G.add_edge (env.current, node) G.Has; - end + end; + env.g +> G.add_edge (env.current, node) G.Has; end; let env = { env with current = node; @@ -730,14 +728,15 @@ and field_decl env def = let node = (full_str, kind) in if env.phase = Defs then begin (* less: static? *) - if not (G.has_node node env.g) - then - begin - env.g +> G.add_node node; - env.g +> G.add_nodeinfo node (nodeinfo def.f_var.v_name); + (* Error thrown when run on FOS, for duplicate nodes. *) + if not (G.has_node node env.g) then + begin + env.g +> G.add_node node; + env.g +> G.add_nodeinfo node (nodeinfo def.f_var.v_name); + end + else pr2 (spf "Package: %s already existing" (G.string_of_node node)); + (* Edge drawn even if node already exists previously *) env.g +> G.add_edge (env.current, node) G.Has; - end - else pr2 (spf "Package: %s already existing" (G.string_of_node node)) end; let env = { env with current = node; @@ -753,17 +752,16 @@ and enum_decl env def = let node = (full_str, E.Class) in if env.phase = Defs then begin -(* pr "Enum decl env.phases = Def"; *) - if not (G.has_node node env.g) - then - begin - env.g +> G.add_node node; - env.g +> G.add_nodeinfo node (nodeinfo def.en_name); - env.g +> G.add_edge (env.current, node) G.Has; - end - else begin pr2 (spf "Package: %s already existing" (G.string_of_node - node)) end - end; + if not (G.has_node node env.g) then + begin + env.g +> G.add_node node; + env.g +> G.add_nodeinfo node (nodeinfo def.en_name); + end + else + pr2 (spf "Package: %s already existing" (G.string_of_node + node)); + env.g +> G.add_edge (env.current, node) G.Has; + end; let env = { env with current = node; current_qualifier = full_ident; @@ -787,15 +785,19 @@ and enum_decl env def = let full_str = str_of_qualified_ident full_ident in let node = (full_str, E.Constant) in if env.phase = Defs then begin - if not (G.has_node node env.g) then - begin - env.g +> G.add_node node; - env.g +> G.add_nodeinfo node (nodeinfo ident); - env.g +> G.add_edge (env.current, node) G.Has; - end - else begin pr2 (spf ": %s already existing" - (G.string_of_node node)) end - end; + (* Check for duplicate node *) + if not (G.has_node node env.g) then + begin + env.g +> G.add_node node; + env.g +> G.add_nodeinfo node (nodeinfo ident); + end + else + begin pr2 (spf ": %s already existing" + (G.string_of_node node)) + end; + (* Edge drawn even if node already existed. *) + env.g +> G.add_edge (env.current, node) G.Has; + end; let env = { env with current = node; current_qualifier = full_ident; @@ -1022,7 +1024,6 @@ and expr env = function expr env e; typ env (tref); -(* TODO: Remove ast, if it is not used *) and resolve_call env (expr_,_) = let rec aux expr_ = (match expr_ with @@ -1051,55 +1052,60 @@ and resolve_call env (expr_,_) = ) in let node_str_array = aux expr_ in - (*let node_str = (Common2.list_last node_str_array) in*) - (* - *Verbose flag can be set to false/true here. Stack overflow error - *results when imported namespaces & qualifiers is printed, so commented out. + (* Verbose flag can be set to false/true here. *) + let verbose = false in + let dfs = dfs ~verbose:verbose ~env ~node:env.current ~get_succ:(fun + ~n -> G.succ n G.Use env.g) ~f:(fun node -> G.has_node + (node,E.Method) env.g) + in + (* For calls of type a.b.c.d, checks if d() then c.d(), then b.c.d() and so + * on. *) - let dfs_f = ref (dfs ~verbose:false ~env ~node:env.current ~get_edges:(fun - ~n -> G.succ n G.Use env.g) ~f:(fun node -> G.has_node - (node,E.Method) env.g) ) - in let read_from_last ~node_str_list ~f = - let printer = ref [""] in let rec aux ~acc ~node_str_list ~f = (match last_and_beginning_of_list node_str_list with | Some (last_node, rest) -> (match f (last_node ^ acc ) with - | (Some a,_) -> Some a - | (None, printer2) -> - printer.contents <- printer.contents @ printer2.contents; - let acc2 = "."^last_node ^ acc + | Some a -> Some a + | None -> + let acc2 = "." ^ last_node ^ acc in aux ~acc:acc2 ~node_str_list:rest ~f ) | None -> - pr "Print dfs"; - pr (join_list ~sep:"\n" printer.contents); + if verbose = true then + begin + pr "Print dfs"; + pr (join_list ~sep:"\n" printer.contents); + printer.contents <- []; (* Resetting print variable after + printing *) + end; None ) in aux ~acc:"" ~node_str_list ~f in let node_str_o = - read_from_last ~node_str_list:node_str_array ~f:(fun x -> dfs_f.contents + read_from_last ~node_str_list:node_str_array ~f:(fun x -> dfs ~node_str: x ) in (match node_str_o with | None -> pr (spf "MTM: (resolve_call) lookup fail on method %s, source: %s " (node_str_array +> - join_list ~sep:".") (env.current_qualifier +> str_of_qualified_ident) ) + join_list ~sep:".") (env.current_qualifier +> str_of_qualified_ident) ) | Some str -> add_use_edge env (str, E.Method); - pr (spf "MTM: (resolve_call) Edge drawn to method %s, resolved qualifier: %s, source: %s" (node_str_array +> join_list ~sep:".") str - (env.current_qualifier +> str_of_qualified_ident)) + pr (spf "MTM: (resolve_call) Edge drawn to method %s, resolved qualifier: %s, source: %s" + (node_str_array +> join_list ~sep:".") str + (env.current_qualifier +> str_of_qualified_ident)) ); () (* Removes the object's name in method calls, NOTE: this is a heuristic which * relies on the fact that most method calls are of the form A.x(), where A is * an object. Also, it assumes that in type name, first element of the list can - * be removed*) + * be removed + *) and resolve_name name_ = List.map (fun (_tyarg_todo, ident) -> Ast.unwrap ident) name_ @@ -1213,7 +1219,7 @@ let build ?(verbose=true) ?(only_defs=false) ?(method_to_method=false) root file if method_to_method then begin if verbose then pr2 "\nstep4: methodtomethod"; -(* pr "Step 4\n"; *) + (* step4: drawing 'Use' edges between methods during method call *) files +> Console.progress ~show:verbose (fun k -> List.iter (fun file -> k(); diff --git a/main_codegraph.ml b/main_codegraph.ml index 36bed0021..3424621a0 100644 --- a/main_codegraph.ml +++ b/main_codegraph.ml @@ -189,6 +189,8 @@ let class_analysis = ref false (* action mode *) let action = ref "" +let method_to_method = ref false + (*****************************************************************************) (* Helpers *) (*****************************************************************************) @@ -327,12 +329,9 @@ let build_graph_code lang xs = Graph_code_c.build ~verbose:!verbose root files, empty | "clang2" -> Graph_code_clang.build ~verbose:!verbose root files, empty - | "java" -> Graph_code_java.build ~verbose:!verbose root files, empty + | "java" -> Graph_code_java.build ~verbose:!verbose + ~method_to_method:!method_to_method root files, empty - | "javam" -> Graph_code_java.build ~verbose:!verbose ~method_to_method:true - root files, empty (*TODO: move method_to_method option to build, and not - language - this takes more time to complete than the previous case so - setting a flag to activate it*) #if FEATURE_BYTECODE | "bytecode" -> let graph_code_java = None @@ -385,7 +384,6 @@ let build_graph_code lang xs = let build_stdlib lang root dst = let files = Find_source.files_of_root ~lang root in match lang with - | "javam" | "java" -> Builtins_java.extract_from_sources ~src:root ~dst files | "clang" -> @@ -705,6 +703,9 @@ let options () = [ "-lang", Arg.Set_string lang, (spf " choose language (default = %s) (for -build)" !lang); + + "-method_to_method", Arg.Set method_to_method, + ""; "-o", Arg.String (fun s -> output_dir := Some s), " save graph_code.marshall in another dir (for -build)"; "-derived_data", Arg.Set gen_derived_data,