diff options
Diffstat (limited to 'perl_checker.src/tree.ml')
-rw-r--r-- | perl_checker.src/tree.ml | 323 |
1 files changed, 191 insertions, 132 deletions
diff --git a/perl_checker.src/tree.ml b/perl_checker.src/tree.ml index 33cc111..e91e0e1 100644 --- a/perl_checker.src/tree.ml +++ b/perl_checker.src/tree.ml @@ -1,12 +1,15 @@ open Types open Common open Printf +open Parser_helper + +type special_export = Re_export_all | Export_all type exports = { export_ok : (context * string) list ; export_auto : (context * string) list ; export_tags : (string * (context * string) list) list ; - re_export_all : bool ; + special_export : special_export option ; } type uses = (string * ((context * string) list option * pos)) list @@ -15,12 +18,14 @@ type per_package = { file_name : string ; package_name : string ; has_package_name : bool ; vars_declared : (context * string, pos) Hashtbl.t ; + imported : ((context * string) * string) list option ref ; exports : exports ; uses : uses ; body : fromparser list; } type state = { per_package : (string * per_package) list ; + files_parsed : string list ; global_vars_declared : (context * string * string, pos) Hashtbl.t ; global_vars_used : ((context * string * string) * pos) list ref ; } @@ -28,28 +33,20 @@ type state = { type vars = { my_vars : (context * string) list list ; our_vars : (context * string) list list ; - imported : ((context * string) * string) list ; + locally_imported : ((context * string) * string) list ; required_vars : (context * string * string) list ; current_package : per_package ; state : state ; } let anonymous_package_count = ref 0 -let default_state = { per_package = []; global_vars_declared = Hashtbl.create 256; global_vars_used = ref [] } -let empty_exports = { export_ok = []; export_auto = []; export_tags = []; re_export_all = false } +let default_state = { per_package = []; files_parsed = []; global_vars_declared = Hashtbl.create 256; global_vars_used = ref [] } +let empty_exports = { export_ok = []; export_auto = []; export_tags = []; special_export = None } let ignored_packages = ref [] let die_with_pos pos msg = failwith (Info.pos2sfull pos ^ msg) let warn_with_pos pos msg = prerr_endline (Info.pos2sfull pos ^ msg) -let context2s = function - | I_scalar -> "$" - | I_hash -> "%" - | I_array -> "@" - | I_func -> "&" - | I_raw -> "" - | I_star -> "*" -let variable2s(context, ident) = context2s context ^ ident let s2context s = match s.[0] with | '$' -> I_scalar, skip_n_char 1 s @@ -63,14 +60,22 @@ let s2context s = let get_current_package t = match t with - | Package(Ident _ as ident) :: _ -> - Some (Parser_helper.string_of_Ident ident) + | Package(Ident _ as ident) :: body -> + let rec bundled_packages packages current_package found_body = function + | [] -> (Some current_package, List.rev found_body) :: packages + | Package(Ident _ as ident) :: body -> + let packages = (Some current_package, List.rev found_body) :: packages in + bundled_packages packages (string_of_Ident ident) [] body + | instr :: body -> + bundled_packages packages current_package (instr :: found_body) body + in + bundled_packages [] (string_of_Ident ident) [] body | _ -> if str_ends_with !Info.current_file ".pm" then warn_with_pos (!Info.current_file, 0, 0) (sprintf "module %s does not have \"package xxxx;\" on its first line" !Info.current_file) ; - None + [ None, t ] let from_qw = function - | Call_op("qw", [ Raw_string(s, pos)]) -> + | Call_op("qw", [ Raw_string(s, pos)], _) -> List.map (fun s -> let context, s' = s2context s in let context = @@ -88,20 +93,21 @@ let from_qw = function let get_exported t = List.fold_left (fun exports e -> match e with - | List [ Call_op("=", [ Deref(I_array, Ident(None, "EXPORT", pos)); Call _ ]) ] - | List [ Call_op("=", [ My_our("our", [(I_array, "EXPORT")], pos); Call _ ]) ] -> - if not exports.re_export_all then warn_with_pos pos "unrecognised @EXPORT" ; + | List [ Call_op("=", [ Deref(I_array, Ident(None, "EXPORT", _)); Call _ ], pos) ] + | List [ Call_op("=", [ My_our("our", [(I_array, "EXPORT")], _); Call _ ], pos) ] -> + if exports.special_export = None then warn_with_pos pos "unrecognised @EXPORT" ; exports - | List [ Call_op("=", [ Deref(I_array, Ident(None, "EXPORT", pos)); v ])] - | List [ Call_op("=", [ My_our("our", [(I_array, "EXPORT")], pos); v ])] -> + | List [ Call_op("=", [ Deref(I_array, Ident(None, "EXPORT", _)); v ], pos)] + | List [ Call_op("=", [ My_our("our", [(I_array, "EXPORT")], _); v ], pos)] -> if exports.export_auto <> [] then warn_with_pos pos "weird, @EXPORT set twice" ; { exports with export_auto = from_qw v } - | Perl_checker_comment("RE-EXPORT-ALL", _) -> { exports with re_export_all = true } + | Perl_checker_comment("RE-EXPORT-ALL", _) -> { exports with special_export = Some Re_export_all } + | Perl_checker_comment("EXPORT-ALL", _) -> { exports with special_export = Some Export_all } - | List [ Call_op("=", [ Deref(I_array, Ident(None, "EXPORT_OK", pos)); v ])] - | List [ Call_op("=", [ My_our("our", [(I_array, "EXPORT_OK")], pos); v ])] -> + | List [ Call_op("=", [ Deref(I_array, Ident(None, "EXPORT_OK", _)); v ], pos)] + | List [ Call_op("=", [ My_our("our", [(I_array, "EXPORT_OK")], _); v ], pos)] -> if exports.export_ok <> [] then warn_with_pos pos "weird, @EXPORT_OK set twice" ; (match v with | Call(Deref(I_func, Ident(None, "map", _)), @@ -110,8 +116,8 @@ let get_exported t = { exports with export_ok = collect snd exports.export_tags } | _ -> { exports with export_ok = from_qw v }) - | List [ Call_op("=", [ Deref(I_hash, Ident(None, "EXPORT_TAGS", pos)); v ])] - | List [ Call_op("=", [ My_our("our", [(I_hash, "EXPORT_TAGS")], pos); v ])] -> + | List [ Call_op("=", [ Deref(I_hash, Ident(None, "EXPORT_TAGS", _)); v ], pos)] + | List [ Call_op("=", [ My_our("our", [(I_hash, "EXPORT_TAGS")], _); v ], pos)] -> (try let export_tags = match v with @@ -147,9 +153,9 @@ let uses_external_package = function let get_uses t = List.fold_left (fun uses e -> match e with - | Use(Ident _ as pkg, _) when uses_external_package (Parser_helper.string_of_Ident pkg) -> uses + | Use(Ident _ as pkg, _) when uses_external_package (string_of_Ident pkg) -> uses | Use(Ident(_, _, pos) as ident, l) -> - let package = Parser_helper.string_of_Ident ident in + let package = string_of_Ident ident in let para = if l = [] then None else Some(from_qw (List.hd l)) in (package, (para, pos)) :: uses | _ -> uses @@ -162,7 +168,7 @@ let get_vars_declaration state package = | Sub_declaration(Ident(Some fq, name, pos), _proto, _) -> Hashtbl.replace state.global_vars_declared (I_func, fq, name) pos - | List [ Call_op("=", [My_our("our", ours, pos); _]) ] + | List [ Call_op("=", [My_our("our", ours, pos); _], _) ] | List [ My_our("our", ours, pos) ] | My_our("our", ours, pos) -> List.iter (fun (context, name) -> Hashtbl.replace package.vars_declared (context, name) pos) ours @@ -171,38 +177,71 @@ let get_vars_declaration state package = | Use(Ident(None, "vars", pos), [ours]) -> List.iter (fun (context, name) -> Hashtbl.replace package.vars_declared (context, name) pos) (from_qw ours) | Use(Ident(None, "vars", pos), _) -> - die_with_pos pos "usage: \"use vars qw($var func)\"" + die_with_pos pos "usage: use vars qw($var func)" + + | List [ Method_call(Raw_string(pkg, pos), Raw_string("bootstrap", _), _) ] -> + if pkg <> package.package_name then + warn_with_pos pos "strange bootstrap (the package name is not the same as the current package)" + else + (try + let cfile = Filename.chop_extension package.file_name ^ ".c" in + let prefix = "newXS(\"" ^ pkg ^ "::" in + ignore (fold_lines (fun in_bootstrap s -> + if in_bootstrap then + (try + let offset = strstr s prefix + String.length prefix in + let end_ = String.index_from s offset '"' in + let ident = String.sub s offset (end_ - offset) in + match split_at2 ':'':' ident with + | [_] -> Hashtbl.replace package.vars_declared (I_func, ident) pos + | l -> + if l <> [] then + let fql, name = split_last l in + let fq = String.concat "::" (pkg :: fql) in + Hashtbl.replace state.global_vars_declared (I_func, fq, name) pos + with Not_found -> ()); + in_bootstrap || str_contains s "XS_VERSION_BOOTCHECK" + ) false (open_in cfile)) + with Invalid_argument _ | Sys_error _ -> ()) | _ -> () ) package.body -let get_imports state package = - let rec get_one (package_name, (imports, pos)) = - try - let package_used = List.assoc package_name state.per_package in - let exports = package_used.exports in - match imports with - | None -> - let re = if exports.re_export_all then collect get_one package_used.uses else [] in - let l = List.map (fun (context, name) -> (context, name), package_name) exports.export_auto in - re @ l - | Some l -> - let imports_vars = - collect (function - | I_raw, tag -> - (try - List.assoc tag exports.export_tags - with Not_found -> die_with_pos pos (sprintf "package %s doesn't export tag %s" package_name tag)) - | variable -> - if List.mem variable exports.export_ok then - [ variable ] - else - die_with_pos pos (sprintf "package %s doesn't export %s" package_name (variable2s variable)) - ) l - in - List.map (fun (context, name) -> (context, name), package_name) imports_vars - with Not_found -> [] - in - collect get_one package.uses +let rec get_imported state (package_name, (imports, pos)) = + try + let package_used = List.assoc package_name state.per_package in + let exports = package_used.exports in + match imports with + | None -> + let re = match exports.special_export with + | Some Re_export_all -> get_imports state package_used + | Some Export_all -> Hashtbl.fold (fun var _ l -> (var, package_name) :: l) package_used.vars_declared [] + | _ -> [] in + let l = List.map (fun (context, name) -> (context, name), package_name) exports.export_auto in + re @ l + | Some l -> + let imports_vars = + collect (function + | I_raw, tag -> + (try + List.assoc tag exports.export_tags + with Not_found -> die_with_pos pos (sprintf "package %s doesn't export tag %s" package_name tag)) + | variable -> + if List.mem variable exports.export_ok then + [ variable ] + else + die_with_pos pos (sprintf "package %s doesn't export %s" package_name (variable2s variable)) + ) l + in + List.map (fun (context, name) -> (context, name), package_name) imports_vars + with Not_found -> [] + +and get_imports state package = + match !(package.imported) with + | Some l -> l + | None -> + let l = collect (get_imported state) package.uses in + package.imported := Some l ; + l let rec fold_tree f env e = match f env e with @@ -218,8 +257,7 @@ let rec fold_tree f env e = -> fold_tree_option f env e' | Sub_declaration(e1, _, e2) - | Deref_with(_, e1, e2) - | Binop(_, e1, e2) + | Deref_with(_, _, e1, e2) -> let env = fold_tree f env e1 in let env = fold_tree f env e2 in @@ -228,31 +266,20 @@ let rec fold_tree f env e = | Use(_, l) | List l | Block l - | Call_op(_, l) + | Call_op(_, l, _) -> List.fold_left (fold_tree f) env l | Call(e', l) - | CallP(e', l) -> let env = fold_tree f env e' in List.fold_left (fold_tree f) env l | Method_call(e1, e2, l) - | Method_callP(e1, e2, l) -> let env = fold_tree f env e1 in let env = fold_tree f env e2 in List.fold_left (fold_tree f) env l - | If_then_else(_, t_l, e') - -> - let env = fold_tree_option f env e' in - List.fold_left (fun env (e1, e2) -> - let env = fold_tree f env e1 in - let env = fold_tree f env e2 in - env - ) env t_l - | _ -> env and fold_tree_option f env = function @@ -261,45 +288,50 @@ and fold_tree_option f env = function let get_global_info_from_package t = - let exports = get_exported t in - let uses = get_uses t in - let current_package = get_current_package t in - let package_name = - match current_package with - | None -> - if exports.export_ok <> [] || exports.export_auto <> [] || exports.export_tags <> [] then - die_with_pos (!Info.current_file, 0, 0) "file with no \"package\" wants to export!" - else - (incr anonymous_package_count ; sprintf "anonymous%d" !anonymous_package_count) - | Some name -> name - in - let required_packages = List.fold_left (fold_tree (fun l -> - function - | Call(Deref(I_func, Ident (None, "require", pos)), [Raw_string (package, _)]) - when not (uses_external_package package) -> Some((package, pos) :: l) - | _ -> None) - ) [] t in - required_packages, { - file_name = !Info.current_file ; - package_name = package_name; - has_package_name = current_package <> None ; - exports = exports ; - vars_declared = Hashtbl.create 16 ; - uses = uses ; - body = t ; - } - + let current_packages = get_current_package t in + map_withenv (fun required_packages (current_package, t) -> + let exports = get_exported t in + let uses = get_uses t in + let package_name = + match current_package with + | None -> + if exports.export_ok <> [] || exports.export_auto <> [] || exports.export_tags <> [] then + die_with_pos (!Info.current_file, 0, 0) "file with no package name wants to export!" + else + (incr anonymous_package_count ; sprintf "anonymous%d" !anonymous_package_count) + | Some name -> name + in + let required_packages = List.fold_left (fold_tree (fun l -> + function + | Call(Deref(I_func, Ident (None, "require", pos)), [Ident _ as pkg]) -> + let package = string_of_Ident pkg in + if uses_external_package package then None else Some((package, pos) :: l) + | _ -> None) + ) required_packages t in + { + file_name = !Info.current_file ; + package_name = package_name; + has_package_name = current_package <> None ; + exports = exports ; + imported = ref None ; + vars_declared = Hashtbl.create 16 ; + uses = uses ; + body = t ; + }, required_packages + ) [] current_packages let is_my_declared vars t = List.exists (List.exists ((=) t)) vars.my_vars let is_our_declared vars t = List.exists (List.exists ((=) t)) vars.our_vars let is_var_declared vars (context, name) = - List.mem_assoc (context, name) vars.imported || + List.mem_assoc (context, name) vars.locally_imported || + List.mem_assoc (context, name) (get_imports vars.state vars.current_package) || Hashtbl.mem vars.current_package.vars_declared (context, name) let is_global_var_declared vars (context, fq, name) = Hashtbl.mem vars.state.global_vars_declared (context, fq, name) || (try let package = List.assoc fq vars.state.per_package in - Hashtbl.mem package.vars_declared (context, name) + Hashtbl.mem package.vars_declared (context, name) || + List.mem_assoc (context, name) (get_imports vars.state package) with Not_found -> false) @@ -358,7 +390,7 @@ let check_variable (context, var) vars = then () else if context = I_func then - warn_with_pos pos ("unknown function " ^ Parser_helper.string_of_Ident var) + warn_with_pos pos ("unknown function " ^ string_of_Ident var) else lpush vars.state.global_vars_used ((context, fq, name), pos) | _ -> () @@ -366,12 +398,12 @@ let check_variable (context, var) vars = let declare_My vars (mys, pos) = let l_new = List.filter (fun (context, ident) -> if context = I_raw then - if ident = "undef" then false else die_with_pos pos (sprintf "bad ident \"%s\" in my" ident) + if ident = "undef" then false else die_with_pos pos (sprintf "bad ident %s in my" ident) else true ) mys in let l_pre = List.hd vars.my_vars in List.iter (fun v -> - if List.exists ((=) v) l_pre then warn_with_pos pos (sprintf "redeclared variable \"%s\"" (variable2s v)) + if List.exists ((=) v) l_pre then warn_with_pos pos (sprintf "redeclared variable %s" (variable2s v)) ) l_new ; { vars with my_vars = (l_new @ l_pre) :: List.tl vars.my_vars } @@ -380,7 +412,7 @@ let declare_Our vars (ours, pos) = | [] -> vars (* we're at the toplevel, already declared in vars_declared *) | l_pre :: other -> List.iter (fun v -> - if List.exists ((=) v) l_pre then warn_with_pos pos (sprintf "redeclared variable \"%s\"" (variable2s v)) + if List.exists ((=) v) l_pre then warn_with_pos pos (sprintf "redeclared variable %s" (variable2s v)) ) ours ; { vars with our_vars = (ours @ l_pre) :: other } @@ -405,11 +437,11 @@ let check_variables vars t = let _vars' = List.fold_left check_variables_ vars' f in Some vars - | Call_op("foreach my", [my; expr; Block block]) -> + | Call_op("foreach my", [my; expr; Block block], _) -> let vars = check_variables_ vars expr in let vars = check_variables_ vars (Block (my :: block)) in Some vars - | Call_op(op, cond :: Block first_bl :: other) when op = "if" || op = "while" || op = "unless" || op = "until" -> + | Call_op(op, cond :: Block first_bl :: other, _) when op = "if" || op = "while" || op = "unless" || op = "until" -> let vars' = { vars with my_vars = [] :: vars.my_vars ; our_vars = [] :: vars.our_vars } in let vars' = check_variables_ vars' cond in let _vars' = List.fold_left check_variables_ vars' first_bl in @@ -417,7 +449,7 @@ let check_variables vars t = Some vars | Sub_declaration(Ident(_, _, pos) as ident, _proto, body) -> - let vars = declare_Our vars ([ I_func, Parser_helper.string_of_Ident ident ], pos) in + let vars = declare_Our vars ([ I_func, string_of_Ident ident ], pos) in let vars = check_variables_ vars body in Some vars @@ -429,31 +461,37 @@ let check_variables vars t = | Deref(context, (Ident _ as var)) -> check_variable (context, var) vars ; Some vars - | Deref_with(context, (Ident _ as var), para) -> + | Deref_with(context, _, (Ident _ as var), para) -> let vars = check_variables_ vars para in check_variable (context, var) vars ; Some vars - | Call_op(op, [My_our(my_or_our, mys, pos); e]) -> - if op = "=" then - (* check e first *) - let vars = check_variables_ vars e in - List.iter (fun (context, var) -> - if context = I_hash || context = I_array then die_with_pos pos (sprintf "%s takes all the arguments, %s is undef in any case" (variable2s (context, var)) (variable2s (last mys))) - ) (removelast mys) ; (* mys is never empty *) - Some(declare_My_our vars (my_or_our, mys, pos)) - else - (warn_with_pos pos "weird" ; None) - - | Call(Deref(I_func, Ident(None, "require", _)), [Raw_string (package_name, _)]) -> - (try - let package = List.assoc package_name vars.state.per_package in - let required_vars = Hashtbl.fold (fun (context, ident) _ l -> - (context, vars.current_package.package_name, ident) :: l - ) package.vars_declared vars.required_vars in - let vars = { vars with required_vars = required_vars } in - Some vars - with Not_found -> Some vars) + | Call_op("=", [My_our(my_or_our, mys, pos); e], _) -> + (* check e first *) + let vars = check_variables_ vars e in + List.iter (fun (context, var) -> + if non_scalar_context context then die_with_pos pos (sprintf "%s takes all the arguments, %s is undef in any case" (variable2s (context, var)) (variable2s (last mys))) + ) (removelast mys) ; (* mys is never empty *) + Some(declare_My_our vars (my_or_our, mys, pos)) + + | Call_op("if infix", [List [My_our _]; List [Num("0", _)]], _) -> None (* special allowed case *) + | Call_op(op, List (My_our _ :: _) :: _, pos) + | Call_op(op, My_our _ :: _, pos) + | Call_op(op, Call_op("local", _, _) :: _, pos) -> + if op <> "=" then warn_with_pos pos (sprintf "applying %s on a new initialized variable is wrong" op); + None + + | Call(Deref(I_func, Ident(None, "require", _)), [Ident _]) -> Some vars + + | Method_call(Raw_string(package_name, pos), Raw_string ("import", _), para) -> + let args = + match para with + | [] -> None + | [ List [v] ] -> Some(from_qw v) + | _ -> die_with_pos pos "bad import statement" in + let l = get_imported vars.state (package_name, (args, pos)) in + let vars = { vars with locally_imported = l @ vars.locally_imported } in + Some vars | _ -> None in @@ -461,7 +499,28 @@ let check_variables vars t = vars let check_tree state package = - let imports = get_imports state package in - let vars = { my_vars = [[]]; our_vars = []; imported = imports; required_vars = []; current_package = package; state = state } in + let vars = { my_vars = [[]]; our_vars = []; locally_imported = []; required_vars = []; current_package = package; state = state } in let _vars = check_variables vars package.body in () + +let add_package_to_state state package = + let per_package = + try + update_assoc (fun existing_package -> + (*prerr_endline (existing_package.file_name ^ " vs " ^ package.file_name); *) + Hashtbl.iter (fun var pos -> Hashtbl.replace existing_package.vars_declared var pos) package.vars_declared ; + { existing_package with + body = existing_package.body @ package.body ; + uses = existing_package.uses @ package.uses ; + exports = { export_ok = existing_package.exports.export_ok @ package.exports.export_ok ; + export_auto = existing_package.exports.export_auto @ package.exports.export_auto ; + export_tags = existing_package.exports.export_tags @ package.exports.export_tags ; + special_export = None } + } + ) package.package_name state.per_package + with Not_found -> + (package.package_name, package) :: state.per_package + in + { state with + per_package = per_package ; + files_parsed = package.file_name :: state.files_parsed } |