diff options
author | Pascal Rigaux <pixel@mandriva.com> | 2002-12-18 16:02:09 +0000 |
---|---|---|
committer | Pascal Rigaux <pixel@mandriva.com> | 2002-12-18 16:02:09 +0000 |
commit | 1e9b027b5bb760a1b15d76a7b4574052853930e0 (patch) | |
tree | cd7b06bac95a507a11842d50d837392d23b8b108 /perl_checker.src | |
parent | 00cbf7c47c0f642a9fe3d6b0189ed1ed642564e6 (diff) | |
download | perl-MDK-Common-1e9b027b5bb760a1b15d76a7b4574052853930e0.tar perl-MDK-Common-1e9b027b5bb760a1b15d76a7b4574052853930e0.tar.gz perl-MDK-Common-1e9b027b5bb760a1b15d76a7b4574052853930e0.tar.bz2 perl-MDK-Common-1e9b027b5bb760a1b15d76a7b4574052853930e0.tar.xz perl-MDK-Common-1e9b027b5bb760a1b15d76a7b4574052853930e0.zip |
new features including checking methods being available and unused functions
Diffstat (limited to 'perl_checker.src')
-rw-r--r-- | perl_checker.src/.cvsignore | 1 | ||||
-rw-r--r-- | perl_checker.src/Makefile | 13 | ||||
-rw-r--r-- | perl_checker.src/build.mli | 2 | ||||
-rw-r--r-- | perl_checker.src/common.ml | 26 | ||||
-rw-r--r-- | perl_checker.src/common.mli | 7 | ||||
-rw-r--r-- | perl_checker.src/config_file.ml | 38 | ||||
-rw-r--r-- | perl_checker.src/config_file.mli | 6 | ||||
-rw-r--r-- | perl_checker.src/flags.ml | 1 | ||||
-rw-r--r-- | perl_checker.src/flags.mli | 1 | ||||
-rw-r--r-- | perl_checker.src/global_checks.ml | 447 | ||||
-rw-r--r-- | perl_checker.src/global_checks.mli | 19 | ||||
-rw-r--r-- | perl_checker.src/info.ml | 2 | ||||
-rw-r--r-- | perl_checker.src/info.mli | 3 | ||||
-rw-r--r-- | perl_checker.src/lexer.mll | 2 | ||||
-rw-r--r-- | perl_checker.src/parser_helper.ml | 6 | ||||
-rw-r--r-- | perl_checker.src/perl_checker.ml | 121 | ||||
-rw-r--r-- | perl_checker.src/tree.ml | 504 | ||||
-rw-r--r-- | perl_checker.src/tree.mli | 34 |
18 files changed, 797 insertions, 436 deletions
diff --git a/perl_checker.src/.cvsignore b/perl_checker.src/.cvsignore index d715755..2bd7e98 100644 --- a/perl_checker.src/.cvsignore +++ b/perl_checker.src/.cvsignore @@ -11,3 +11,4 @@ lexer.ml parser.ml parser.mli parser.output +build.ml diff --git a/perl_checker.src/Makefile b/perl_checker.src/Makefile index 9b33410..727b38d 100644 --- a/perl_checker.src/Makefile +++ b/perl_checker.src/Makefile @@ -4,12 +4,21 @@ YFLAGS = -v TRASH = parser.output TAGS RESULT = perl_checker BCSUFFIX = _debug -SOURCES = common.ml flags.ml types.mli info.ml parser_helper.ml parser.mly lexer.mll tree.ml perl_checker.ml +SOURCES = build.ml common.ml flags.ml config_file.ml types.mli info.ml parser_helper.ml parser.mly lexer.mll tree.ml global_checks.ml perl_checker.ml LIBS = unix +VENDORLIB = $(shell dirname `pwd`)/perl_checker_fake_packages NAME = shyant -default: TAGS debug-code native-code +default: TAGS build_ml build.ml debug-code native-code + +build_ml: + rm -f build.ml + $(MAKE) build.ml + +build.ml: + date '+let date = %s' > $@ + echo 'let fake_packages_dir = "'$(VENDORLIB)'"' >> $@ tags: ocamltags *.ml diff --git a/perl_checker.src/build.mli b/perl_checker.src/build.mli new file mode 100644 index 0000000..49acf6e --- /dev/null +++ b/perl_checker.src/build.mli @@ -0,0 +1,2 @@ +val date : int +val fake_packages_dir : string diff --git a/perl_checker.src/common.ml b/perl_checker.src/common.ml index 9d21a48..44e63fd 100644 --- a/perl_checker.src/common.ml +++ b/perl_checker.src/common.ml @@ -496,10 +496,6 @@ let adjustModDown m n = n - (n mod m) let adjustModUp m n = adjustModDown m (n + m - 1) -let hashtbl_set h k v = - Hashtbl.remove h k; - Hashtbl.add h k v - let hashtbl_find f h = let r = ref None in Hashtbl.iter (fun v c -> if f v c then r := Some v) h ; @@ -507,11 +503,20 @@ let hashtbl_find f h = | Some v -> v | None -> raise Not_found -let hashtbl_filter f h = - Hashtbl.iter (fun v c -> hashtbl_set h v (f v c)) h +let hashtbl_map f h = Hashtbl.iter (fun v c -> Hashtbl.replace h v (f v c)) h + +let hashtbl_values h = Hashtbl.fold (fun _ v l -> v :: l) h [] +let hashtbl_keys h = Hashtbl.fold (fun k _ l -> k :: l) h [] +let hashtbl_to_list h = Hashtbl.fold (fun k v l -> (k,v) :: l) h [] + +let hashtbl_collect f h = + rev (Hashtbl.fold (fun k v l -> rev_append (f k v) l) h []) -let hashtbl_to_list h = - Hashtbl.fold (fun k v l -> (k,v) :: l) h [] +let hashtbl_exists f h = + try + Hashtbl.iter (fun v c -> if f v c then raise Found) h ; + false + with Found -> true let array_shift a = Array.sub a 1 (Array.length a - 1) let array_last_n n a = @@ -677,7 +682,10 @@ let rec times e = function | n -> e :: times e (n-1) let skip_n_char_ beg end_ s = - String.sub s beg (String.length s - beg - end_) + let full_len = String.length s in + if beg < full_len && full_len - beg - end_ > 0 + then String.sub s beg (full_len - beg - end_) + else "" let skip_n_char n s = skip_n_char_ n 0 s let rec non_index_from s beg c = diff --git a/perl_checker.src/common.mli b/perl_checker.src/common.mli index f3a66c7..7f2c341 100644 --- a/perl_checker.src/common.mli +++ b/perl_checker.src/common.mli @@ -144,10 +144,13 @@ val getset_nth : 'a list -> int -> ('a -> 'a) -> 'a list val set_nth : 'a list -> int -> 'a -> 'a list val adjustModDown : int -> int -> int val adjustModUp : int -> int -> int -val hashtbl_set : ('a, 'b) Hashtbl.t -> 'a -> 'b -> unit val hashtbl_find : ('a -> 'b -> bool) -> ('a, 'b) Hashtbl.t -> 'a -val hashtbl_filter : ('a -> 'b -> 'b) -> ('a, 'b) Hashtbl.t -> unit +val hashtbl_map : ('a -> 'b -> 'b) -> ('a, 'b) Hashtbl.t -> unit +val hashtbl_values : ('a, 'b) Hashtbl.t -> 'b list +val hashtbl_keys : ('a, 'b) Hashtbl.t -> 'a list val hashtbl_to_list : ('a, 'b) Hashtbl.t -> ('a * 'b) list +val hashtbl_collect : ('a -> 'b -> 'c list) -> ('a, 'b) Hashtbl.t -> 'c list +val hashtbl_exists : ('a -> 'b -> bool) -> ('a, 'b) Hashtbl.t -> bool val array_shift : 'a array -> 'a array val array_last_n : int -> 'a array -> 'a array val array_collect : ('a -> 'b list) -> 'a array -> 'b list diff --git a/perl_checker.src/config_file.ml b/perl_checker.src/config_file.ml new file mode 100644 index 0000000..f4453f5 --- /dev/null +++ b/perl_checker.src/config_file.ml @@ -0,0 +1,38 @@ +open Common + +type config_file = { + basedir : int option ; + } + +let ignored_packages = ref [] + +let default = { basedir = None } + + +let config_cache = Hashtbl.create 16 + +let read dir = + try Hashtbl.find config_cache dir with Not_found -> + try + let file_name = dir ^ "/.perl_checker" in + let fh = open_in file_name in + let config = + fold_lines (fun config line -> + match words line with + | [ "Basedir"; ".." ] -> { config with basedir = Some 1 } + | [ "Basedir"; "../.." ] -> { config with basedir = Some 2 } + | [] -> config (* blank line *) + | [ "Ignore"; pkg ] + | [ pkg ] (* the deprecated form *) + -> lpush ignored_packages pkg; config + | _ -> prerr_endline (Printf.sprintf "bad line \"%s\" in %s" line file_name); config + ) default fh + in + Hashtbl.add config_cache dir config ; + config + with Sys_error _ -> default + +let rec read_any dir depth = + if depth = 0 then () else + let _ = read dir in + read_any (dir ^ "/..") (depth - 1) diff --git a/perl_checker.src/config_file.mli b/perl_checker.src/config_file.mli new file mode 100644 index 0000000..d5ad2f2 --- /dev/null +++ b/perl_checker.src/config_file.mli @@ -0,0 +1,6 @@ +type config_file = { basedir : int option; } +val ignored_packages : string list ref +val default : config_file +val config_cache : (string, config_file) Hashtbl.t +val read : string -> config_file +val read_any : string -> int -> unit diff --git a/perl_checker.src/flags.ml b/perl_checker.src/flags.ml index 8c88b81..85f405c 100644 --- a/perl_checker.src/flags.ml +++ b/perl_checker.src/flags.ml @@ -4,4 +4,5 @@ let verbose = ref false let quiet = ref false let generate_pot = ref false let expand_tabs = ref (Some 8) +let check_unused_global_vars = ref false diff --git a/perl_checker.src/flags.mli b/perl_checker.src/flags.mli index d52b5fa..16d929a 100644 --- a/perl_checker.src/flags.mli +++ b/perl_checker.src/flags.mli @@ -2,3 +2,4 @@ val verbose : bool ref val quiet : bool ref val generate_pot : bool ref val expand_tabs : int option ref +val check_unused_global_vars : bool ref diff --git a/perl_checker.src/global_checks.ml b/perl_checker.src/global_checks.ml new file mode 100644 index 0000000..0ce4d7e --- /dev/null +++ b/perl_checker.src/global_checks.ml @@ -0,0 +1,447 @@ +open Types +open Common +open Printf +open Config_file +open Parser_helper +open Tree + +type state = { + per_package : (string, per_package) Hashtbl.t ; + methods : (string, (pos * bool ref) list) Hashtbl.t ; + global_vars_declared : (context * string * string, pos) Hashtbl.t ; + global_vars_used : ((context * string * string) * pos) list ref ; + } + +type vars = { + my_vars : ((context * string) * (pos * bool ref)) list list ; + our_vars : ((context * string) * (pos * bool ref)) list list ; + locally_imported : ((context * string) * (string * bool ref)) list ; + required_vars : (context * string * string) list ; + current_package : per_package ; + state : state ; + } + + +let rec get_imported state current_package (package_name, (imports, pos)) = + try + let package_used = Hashtbl.find state.per_package package_name in + let exports = package_used.exports in + let get_var_by_name var = + let b = + try snd (Hashtbl.find package_used.vars_declared var) + with Not_found -> + try + snd (List.assoc var (get_imports state package_used)) + with Not_found -> + warn_with_pos pos (sprintf "name %s is not defined in package %s" (variable2s var) package_name) ; + ref true + in + var, (package_name, b) + in + match imports with + | None -> + let re = match exports.special_export with + | Some Re_export_all -> get_imports state package_used + | Some Fake_export_all -> + (* HACK: if package exporting-all is ignored, ignore package importing *) + if List.mem package_name !ignored_packages then Tree.ignore_package current_package.package_name; + + Hashtbl.fold (fun var (_pos, b) l -> (var, (package_name, b)) :: l) package_used.vars_declared [] + | _ -> [] in + let l = List.map get_var_by_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 get_var_by_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) package.uses in + package.imported := Some l ; + l + + +let is_my_declared vars t = + List.exists (fun l -> + List.mem_assoc t l && (snd (List.assoc t l) := true ; true) + ) vars.my_vars +let is_our_declared vars t = + List.exists (fun l -> + List.mem_assoc t l && (snd (List.assoc t l) := true ; true) + ) vars.our_vars + +let is_var_declared_and_set state package var = + try + let (_pos, used) = Hashtbl.find package.vars_declared var in + used := true ; + true + with Not_found -> + try + let (_pos, used) = List.assoc var (get_imports state package) in + used := true ; + true + with Not_found -> + false + +let is_var_declared vars var = + List.mem_assoc var vars.locally_imported || + is_var_declared_and_set vars.state vars.current_package var + +let is_global_var_declared vars (context, fq, name) = + Hashtbl.mem vars.state.global_vars_declared (context, fq, name) || + (try + let package = Hashtbl.find vars.state.per_package fq in + is_var_declared_and_set vars.state package (context, name) + with Not_found -> false) + + +let is_global_var context ident = + match context with + | I_scalar -> + (match ident with + | "@" | "!" | ">" | "\\" | "$" | "^A" | "'" | "/" | "?" | "<" | "^W" | "|" | "^I" | "&" + | "0" | "1" | "2" | "3" | "4" | "5" | "6" | "7" | "8" | "9" -> true + | _ -> false) + | I_array -> + (match ident with + | "ARGV" | "INC" -> true + | _ -> false) + | I_hash -> + (match ident with + | "ENV" | "SIG" -> true + | _ -> false) + | I_star -> + (match ident with + | "STDIN" | "STDOUT" | "STDERR" + | "__FILE__" | "__LINE__" | "undef" -> true + | _ -> false) + | I_func -> + (match ident with + | "-b" | "-d" | "-e" | "-f" | "-l" | "-r" | "-s" | "-w" | "-x" + | "abs" | "alarm" | "basename" | "bless" + | "caller" | "chdir" | "chmod" | "chomp" | "chop" | "chown" | "chr" | "chroot" | "close" | "closedir" | "crypt" + | "defined" | "delete" | "die" + | "each" | "endpwent" | "eof" | "eval" | "exec" | "exists" | "exit" + | "fcntl" | "fileno" | "flock" | "formline" | "fork" + | "gethostbyaddr" | "gethostbyname" | "getgrnam" | "getgrgid" | "getppid" | "getpwent" | "getpwnam" | "getpwuid" | "gmtime" | "goto" | "grep" | "hex" + | "index" | "int" | "ioctl" | "join" | "keys" | "kill" + | "last" | "lc" | "length" | "link" | "localtime" | "log" | "lstat" + | "map" | "mkdir" | "next" | "no" | "oct" | "open" | "opendir" | "ord" + | "pack" | "pipe" | "pop" | "print" | "printf" | "push" | "quotemeta" + | "rand" | "read" | "readdir" | "readlink" | "redo" | "ref" | "rename" | "require" | "return" | "reverse" | "rmdir" + | "scalar" | "seek" | "select" | "setpwent" | "shift" | "sleep" | "sort" | "splice" | "split" | "sprintf" | "stat" | "substr" + | "symlink" | "syscall" | "sysopen" | "sysread" | "sysseek" | "system" | "syswrite" | "tie" | "time" + | "uc" | "umask" | "undef" | "unlink" | "unpack" | "unshift" | "utime" | "values" | "vec" | "waitpid" | "wantarray" | "warn" | "write" + -> true + + | _ -> false) + | _ -> false + +let check_variable (context, var) vars = + match var with + | Ident(Some pkg, _, _) when uses_external_package pkg || List.mem pkg !ignored_packages -> () + | Ident(None, ident, pos) -> + if is_my_declared vars (context, ident) || is_our_declared vars (context, ident) || is_var_declared vars (context, ident) || is_global_var context ident + then () + else warn_with_pos pos (if context = I_func then "unknown function " ^ ident else "undeclared variable " ^ variable2s(context, ident)) + | Ident(Some fq, name, pos) -> + if (fq = "CORE") && is_global_var context name || is_global_var_declared vars (context, fq, name) + then () + else + if context = I_func then + warn_with_pos pos ("unknown function " ^ string_of_Ident var) + else + lpush vars.state.global_vars_used ((context, fq, name), pos) + | _ -> () + +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) + else true + ) mys in + let l_pre = List.hd vars.my_vars in + List.iter (fun v -> + if List.mem_assoc v l_pre then warn_with_pos pos (sprintf "redeclared variable %s" (variable2s v)) + ) l_new ; + { vars with my_vars = (List.map (fun v -> v, (pos, ref false)) l_new @ l_pre) :: List.tl vars.my_vars } + +let declare_Our vars (ours, pos) = + match vars.our_vars with + | [] -> vars (* we're at the toplevel, already declared in vars_declared *) + | l_pre :: other -> + List.iter (fun v -> + if List.mem_assoc v l_pre && v <> (I_scalar, "_") then warn_with_pos pos (sprintf "redeclared variable %s" (variable2s v)) + ) ours ; + { vars with our_vars = (List.map (fun v -> v, (pos, ref false)) ours @ l_pre) :: other } + +let declare_My_our vars (my_or_our, l, pos) = + match my_or_our with + | "my" -> declare_My vars (l, pos) + | "local" + | "our" -> declare_Our vars (l, pos) + | _ -> internal_error "declare_My_our" + +let check_unused_local_variables vars = + List.iter (fun ((_, s as v), (pos, used)) -> + if not !used && s.[0] != '_' && not (List.mem s [ "BEGIN"; "END"; "DESTROY" ]) then warn_with_pos pos (sprintf "unused variable %s" (variable2s v)) + ) (List.hd vars.my_vars) + + + +let check_variables vars t = + let rec check_variables_ vars t = fold_tree check vars t + and check vars = function + | Block l -> + let vars' = { vars with my_vars = [] :: vars.my_vars ; our_vars = [] :: vars.our_vars } in + let vars' = List.fold_left check_variables_ vars' l in + check_unused_local_variables vars' ; + Some vars + | Call(Deref(I_func, Ident(None, "sort", _)), (Anonymous_sub(Block f, pos) :: l)) -> + let vars = List.fold_left check_variables_ vars l in + let vars' = { vars with my_vars = [ (I_scalar, "a"), (pos, ref true) ; (I_scalar, "b"), (pos, ref true) ] :: vars.my_vars ; our_vars = [] :: vars.our_vars } in + let vars' = List.fold_left check_variables_ vars' f in + check_unused_local_variables vars' ; + Some vars + + | Call(Deref(I_func, Ident(None, func, func_pos)), Anonymous_sub(Block f, pos) :: l) when func = "grep" || func = "map" || func = "substInFile" || func = "map_index" || func = "each_index" || func = "partition" || func = "find_index" || func = "grep_index" -> + let vars = List.fold_left check_variables_ vars l in + let vars' = { vars with my_vars = [] :: vars.my_vars ; our_vars = [(I_scalar, "_"), (pos, ref true)] :: vars.our_vars } in + let vars' = List.fold_left check_variables_ vars' f in + check_unused_local_variables vars' ; + check_variable (I_func, Ident(None, func, func_pos)) vars ; + Some vars + + | Call_op("while infix", [ expr ; (List [ Call_op("<>", _, _) ] as l) ], pos) + | Call_op("for infix", [ expr ; l ], pos) -> + let vars = check_variables_ vars l in + let vars' = { vars with my_vars = [] :: vars.my_vars ; our_vars = [(I_scalar, "_"), (pos, ref true)] :: vars.our_vars } in + let vars' = check_variables_ vars' expr in + if List.hd(vars'.my_vars) <> [] then warn_with_pos pos "you can't declare variables in foreach infix"; + Some vars + + | 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" -> + 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 + check_unused_local_variables vars' ; + let vars = List.fold_left check_variables_ vars other in + Some vars + + | Sub_declaration(Ident(fq, name, pos) as ident, _proto, Block l) -> + let vars = declare_Our vars ([ I_func, string_of_Ident ident ], pos) in + let local_vars = ((I_array, "_"), (pos, ref true)) :: (if fq = None && name = "AUTOLOAD" then [ (I_scalar, "AUTOLOAD"), (pos, ref true) ] else []) in + let vars' = { vars with my_vars = [] :: vars.my_vars ; our_vars = local_vars :: vars.our_vars } in + let vars' = List.fold_left check_variables_ vars' l in + check_unused_local_variables vars' ; + Some vars + + | Anonymous_sub(Block l, pos) -> + let vars' = { vars with my_vars = [] :: vars.my_vars ; our_vars = [(I_array, "_"), (pos, ref true)] :: vars.our_vars } in + let vars' = List.fold_left check_variables_ vars' l in + check_unused_local_variables vars' ; + Some vars + + | Call_op("foreach", [ expr ; Block l ], pos) -> + let vars = check_variables_ vars expr in + let vars' = { vars with my_vars = [] :: vars.my_vars ; our_vars = [(I_scalar, "_"), (pos, ref true)] :: vars.our_vars } in + let vars' = List.fold_left check_variables_ vars' l in + check_unused_local_variables vars' ; + Some vars + + | Anonymous_sub _ + | Sub_declaration _ -> internal_error "check_variables" + + | Ident _ as var -> + check_variable (I_star, var) vars ; + Some vars + + | My_our(my_or_our, mys, pos) -> Some(declare_My_our vars (my_or_our, mys, pos)) + | Deref(context, (Ident _ as var)) -> + check_variable (context, var) vars ; + Some vars + | Deref_with(context, _, (Ident _ as var), para) -> + let vars = check_variables_ vars para in + check_variable (context, var) vars ; + 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 vars.current_package (package_name, (args, pos)) in + let vars = { vars with locally_imported = l @ vars.locally_imported } in + Some vars + + | Method_call(Raw_string(pkg, _), Raw_string(method_, pos), para) -> + let vars = List.fold_left check_variables_ vars para in + let rec search pkg = + if is_global_var_declared vars (I_func, pkg, method_) then true + else + let package = Hashtbl.find vars.state.per_package pkg in + List.exists search (List.map fst (some_or package.isa [])) + in + (try + if not (uses_external_package pkg || List.mem pkg !ignored_packages || search pkg || method_ = "bootstrap") then + warn_with_pos pos (sprintf "unknown method %s starting in package %s" method_ pkg); + with Not_found -> (* no warning, "can't find package" is already warned *)()); + Some vars + + | Method_call(o, Raw_string(method_, pos), para) -> + let vars = check_variables_ vars o in + let vars = List.fold_left check_variables_ vars para in + (try + let l = Hashtbl.find vars.state.methods method_ in + List.iter (fun (_, used) -> used := true) l + with Not_found -> + if not (List.mem method_ [ "isa" ]) then + warn_with_pos pos ("unknown method " ^ method_)) ; + Some vars + + | _ -> None + in + let vars = List.fold_left check_variables_ { vars with my_vars = [[]] } t in + vars + +let check_tree state package = + 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 package = + try + let existing_package = Hashtbl.find state.per_package package.package_name in + if existing_package.from_cache then raise Not_found; + (* print_endline_flush (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 } + } + with Not_found -> package + in + Hashtbl.replace state.per_package package.package_name package + +let check_unused_vars package = + Hashtbl.iter (fun v (pos, is_used) -> + if not !is_used then + warn_with_pos pos (sprintf "unused function %s::%s" package.package_name (variable2s v)) + ) package.vars_declared + +let arrange_global_vars_declared state = + let h = Hashtbl.create 16 in + Hashtbl.iter (fun (context, fq, name) pos -> + try + let package = Hashtbl.find state.per_package fq in + if not (Hashtbl.mem package.vars_declared (context, name)) then + Hashtbl.add package.vars_declared (context, name) (pos, ref false) + (* otherwise dropping this second declaration *) + with Not_found -> + (* keeping it in global_vars_declared *) + Hashtbl.add h (context, fq, name) pos + ) state.global_vars_declared ; + { state with global_vars_declared = h } + +let get_methods_available state = + let get_classes state = + let l = hashtbl_collect (fun _ package -> + match package.isa with + | None -> + if Hashtbl.mem package.vars_declared (I_func, "new") then [package] else [] + | Some l -> + package :: List.map (fun (pkg, pos) -> + try + Hashtbl.find state.per_package pkg + with Not_found -> die_with_pos pos ("bad package " ^ pkg) + ) l + ) state.per_package in + uniq l + in + List.iter (fun pkg -> + Hashtbl.iter (fun (context, v) (pos, is_used) -> + if context = I_func then + let l = try Hashtbl.find state.methods v with Not_found -> [] in + Hashtbl.replace state.methods v ((pos, is_used) :: l) + ) pkg.vars_declared + ) (get_classes state) ; + state + + +let default_state() = { per_package = Hashtbl.create 16; methods = Hashtbl.create 256 ; global_vars_declared = Hashtbl.create 256; global_vars_used = ref [] } + +let cache_cache = Hashtbl.create 16 + +let read_packages_from_cache state dir = + if Hashtbl.mem cache_cache dir then () else + try + Hashtbl.add cache_cache dir (); + let file = dir ^ "/.perl_checker.cache" in + let fh = open_in file in + let magic = input_line fh in + if magic <> "perl_checker cache " ^ string_of_int Build.date then () else + let l = Marshal.from_channel fh in + close_in fh ; + + let l = List.filter (fun pkg -> not (Hashtbl.mem state.per_package pkg.package_name)) l in + + if !Flags.verbose then print_endline_flush (sprintf "using cached packages %s from %s" (String.concat " " (List.map (fun pkg -> pkg.package_name) l)) file) ; + + List.iter (fun pkg -> + Info.add_a_file pkg.file_name pkg.lines_starts ; + Hashtbl.add state.per_package pkg.package_name { pkg with from_cache = true } + ) l + with Sys_error _ -> () + +let write_packages_cache state dir = + try + let file = dir ^ "/.perl_checker.cache" in + let fh = open_out file in + output_string fh ("perl_checker cache " ^ string_of_int Build.date ^ "\n") ; + let l = List.filter (fun pkg -> pkg.has_package_name) (List.map (fun pkg -> { pkg with imported = ref None }) (hashtbl_values state.per_package)) in + Marshal.to_channel fh l [] ; + close_out fh ; + if !Flags.verbose then print_endline_flush ("saving cached packages in " ^ file) + with Sys_error _ -> () diff --git a/perl_checker.src/global_checks.mli b/perl_checker.src/global_checks.mli new file mode 100644 index 0000000..8fc2240 --- /dev/null +++ b/perl_checker.src/global_checks.mli @@ -0,0 +1,19 @@ +open Types +open Tree + +type state = { + per_package : (string, per_package) Hashtbl.t; + methods : (string, (pos * bool ref) list) Hashtbl.t ; + global_vars_declared : (context * string * string, pos) Hashtbl.t; + global_vars_used : ((context * string * string) * pos) list ref; + } + +val default_state : unit -> state +val check_tree : state -> per_package -> unit +val add_package_to_state : state -> per_package -> unit +val check_unused_vars : per_package -> unit +val arrange_global_vars_declared : state -> state +val get_methods_available : state -> state + +val read_packages_from_cache : state -> string -> unit +val write_packages_cache : state -> string -> unit diff --git a/perl_checker.src/info.ml b/perl_checker.src/info.ml index 947dc50..f64af7a 100644 --- a/perl_checker.src/info.ml +++ b/perl_checker.src/info.ml @@ -12,6 +12,8 @@ let start_a_new_file file = current_file := file ; current_file_lines_starts := [0] +let add_a_file file file_lines_starts = Hashtbl.replace lines_starts file file_lines_starts + let get_lines_starts_for_file file = if file = !current_file then !current_file_lines_starts else Hashtbl.find lines_starts file diff --git a/perl_checker.src/info.mli b/perl_checker.src/info.mli index 4082306..cca0709 100644 --- a/perl_checker.src/info.mli +++ b/perl_checker.src/info.mli @@ -1,7 +1,10 @@ +val lines_starts : (string, int list) Hashtbl.t val current_file_lines_starts : int list ref val current_file_current_line : int ref val current_file : string ref val start_a_new_file : string -> unit +val add_a_file : string -> int list -> unit +val get_lines_starts_for_file : string -> int list val raw_pos2raw_line : string -> int -> int * int val pos2line : string * int * int -> string * int * int * int val pos2s : string * int * int -> string diff --git a/perl_checker.src/lexer.mll b/perl_checker.src/lexer.mll index c9ce890..430770f 100644 --- a/perl_checker.src/lexer.mll +++ b/perl_checker.src/lexer.mll @@ -451,7 +451,7 @@ rule token = parse | "{" ident "}" { (* needed so that $h{if} works *) not_ok_for_match := lexeme_end lexbuf; - COMPACT_HASH_SUBSCRIPT(lexeme lexbuf, pos lexbuf) + COMPACT_HASH_SUBSCRIPT(skip_n_char_ 1 1 (lexeme lexbuf), pos lexbuf) } | '@' { AT(pos lexbuf) } diff --git a/perl_checker.src/parser_helper.ml b/perl_checker.src/parser_helper.ml index e70e94f..19ee2da 100644 --- a/perl_checker.src/parser_helper.ml +++ b/perl_checker.src/parser_helper.ml @@ -389,7 +389,11 @@ let to_List = function let deref_arraylen e = Call(Deref(I_func, Ident(None, "int", raw_pos2pos bpos)), [Deref(I_array, e)]) let to_Ident ((fq, name), (_, pos)) = Ident(fq, name, raw_pos2pos pos) let to_Raw_string (s, (_, pos)) = Raw_string(s, raw_pos2pos pos) -let to_Method_call (object_, method_, para) = Method_call(maybe_to_Raw_string object_, maybe_to_Raw_string method_, para) +let to_Method_call (object_, method_, para) = + match method_ with + | Ident(Some "SUPER", name, pos) -> Method_call(maybe_to_Raw_string object_, Raw_string(name, pos), para) + | Ident(Some _, _, _) -> Call(Deref(I_func, method_), maybe_to_Raw_string object_ :: para) + | _ -> Method_call(maybe_to_Raw_string object_, maybe_to_Raw_string method_, para) let to_Deref_with(from_context, to_context, ref_, para) = if is_not_a_scalar ref_ then warn_rule "bad deref"; Deref_with(from_context, to_context, ref_, para) diff --git a/perl_checker.src/perl_checker.ml b/perl_checker.src/perl_checker.ml index 6ad9ce2..0d1bb28 100644 --- a/perl_checker.src/perl_checker.ml +++ b/perl_checker.src/perl_checker.ml @@ -1,32 +1,34 @@ open Types open Common open Tree +open Global_checks -let inc = - let inc_ref = ref [] in - let rec updir dir nb = - if nb = 0 then dir else - match dir with - | "." -> String.concat "/" (times ".." nb) - | _ -> updir (Filename.dirname dir) (nb-1) - in - fun file_name package_name has_package_name -> - if !inc_ref = [] then ( - let reldir = if has_package_name then updir file_name (List.length(split_at2 ':'':' package_name)) else "." in - let default = readlines (Unix.open_process_in "perl -le 'print foreach @INC'") in - inc_ref := reldir :: default ; - - try - ignored_packages := readlines (open_in (reldir ^ "/.perl_checker")) @ !ignored_packages - with Sys_error _ -> () - ); - !inc_ref +let rec updir dir nb = + if nb = 0 then dir else + match dir with + | "." -> String.concat "/" (times ".." nb) + | _ -> updir (Filename.dirname dir) (nb-1) + +let search_basedir file_name nb = + let dir = Filename.dirname file_name in + let config = Config_file.read dir in + let nb = some_or config.Config_file.basedir nb in + updir dir nb -let findfile dirs f = List.find Sys.file_exists (List.map (fun dir -> dir ^ "/" ^ f) dirs) +let basedir = ref "" +let set_basedir state package = + let nb = List.length (split_at2 ':'':' package.package_name) - 1 in + let dir = search_basedir package.file_name nb in + lpush Tree.use_lib dir ; + read_packages_from_cache state dir ; + basedir := dir -let rec parse_file state file = +let mtime f = int_of_float ((Unix.stat f).Unix.st_mtime) + +let rec parse_file from_basedir state file = try if !Flags.verbose then print_endline_flush ("checking " ^ file) ; + let build_time = int_of_float (Unix.time()) in let command = match !Flags.expand_tabs with | Some width -> "expand -t " ^ string_of_int width @@ -36,14 +38,17 @@ let rec parse_file state file = try Info.start_a_new_file file ; let tokens = Lexer.get_token Lexer.token lexbuf in - (*let _ = Unix.close_process_in channel in*) + let _ = Unix.close_process_in channel in let t = Parser_helper.parse_tokens Parser.prog tokens (Some lexbuf) in - let packages, required_packages = get_global_info_from_package t in - List.fold_left (fun (required_packages, state) package -> - Tree.get_vars_declaration state package ; - let state = Tree.add_package_to_state state package in - List.map (fun (s, (_, pos)) -> s, pos) package.uses @ required_packages, state - ) (required_packages, state) packages + let packages = get_global_info_from_package from_basedir build_time t in + let required_packages = + collect (fun package -> + get_vars_declaration state.global_vars_declared package ; + Global_checks.add_package_to_state state package ; + set_basedir state package ; + package.required_packages + ) packages in + required_packages, state with Failure s -> ( print_endline_flush s ; exit 1 @@ -52,19 +57,38 @@ let rec parse_file state file = | Not_found -> internal_error "runaway Not_found" and parse_package_if_needed state (package_name, pos) = - if List.mem_assoc package_name state.per_package then [], state else + if List.mem package_name !Config_file.ignored_packages then [], state else + let splitted = split_at2 ':'':' package_name in + let rel_file = String.concat "/" splitted ^ ".pm" in + + (*print_endline_flush ("wondering about " ^ package_name) ;*) try - let package = snd (List.hd state.per_package) in - let inc = !Tree.use_lib @ inc package.file_name package.package_name package.has_package_name in - if List.mem package_name !ignored_packages then [], state - else - let rel_file = String.concat "/" (split_at2 ':'':' package_name) ^ ".pm" in - let file = findfile inc rel_file in - if List.mem file state.files_parsed - then [], state (* already seen, it happens when many files have the same package_name *) - else parse_file state file + let dir = findfile (Build.fake_packages_dir :: !use_lib) rel_file in + let file = dir ^ "/" ^ rel_file in + Config_file.read_any dir (List.length splitted) ; + let already_done = + try + let pkg = Hashtbl.find state.per_package package_name in + if pkg.from_cache then + if pkg.build_time > mtime file then ( + Hashtbl.replace state.per_package package_name { pkg with from_cache = false }; + (*print_endline_flush (package_name ^ " wants " ^ String.concat " " (List.map fst pkg.required_packages)) ; *) + Some pkg.required_packages + ) else ( + if !Flags.verbose then print_endline_flush (Printf.sprintf "cached version of %s is outdated, re-parsing" file); + Hashtbl.remove state.per_package package_name ; (* so that check on file name below doesn't need to check from_cache *) + None + ) + else Some [] + with Not_found -> None in + match already_done with + | Some required_packages -> required_packages, state + | None -> + if hashtbl_exists (fun _ pkg -> pkg.file_name = file) state.per_package + then [], state (* already seen, it happens when many files have the same package_name *) + else parse_file (dir = !basedir) state file with Not_found -> - Tree.warn_with_pos pos (Printf.sprintf "can't find package %s" package_name) ; + warn_with_pos pos (Printf.sprintf "can't find package %s" package_name) ; [], state let rec parse_required_packages state = function @@ -88,6 +112,7 @@ let parse_options = "-v", Arg.Set Flags.verbose, " be verbose" ; "-q", Arg.Set Flags.quiet, " be quiet" ; "-t", Arg.Int (fun i -> Flags.expand_tabs := Some i), " set the tabulation width (default is 8)" ; + "--check-unused", Arg.Set Flags.check_unused_global_vars, " check unused global functions & variables" ; "--restrict-to-files", Arg.Set restrict_to_files, " only display warnings concerning the file(s) given on command line" ; "--generate-pot", Arg.String generate_pot_chosen, "" ; ] in @@ -95,7 +120,9 @@ let parse_options = Arg.parse options (lpush args_r) usage; let files = if !args_r = [] then ["../t.pl"] else !args_r in - let required_packages, state = collect_withenv parse_file default_state files in + + let required_packages, state = collect_withenv (parse_file true) (default_state()) files in + let required_packages = uniq_ (fun (a,_) (b,_) -> a = b) required_packages in if !Flags.generate_pot then Parser_helper.generate_pot !pot_file else ( @@ -103,11 +130,19 @@ let parse_options = let state = parse_required_packages state required_packages in if !restrict_to_files then Common.print_endline_flush_quiet := false ; - let l = List.map snd state.per_package in + let state = arrange_global_vars_declared state in + + write_packages_cache state !basedir ; + + let state = Global_checks.get_methods_available state in + + let l = List.map snd (hashtbl_to_list state.per_package) in + let l = List.filter (fun pkg -> not pkg.from_cache && pkg.from_basedir) l in (* HACK: skip ignored_packages. Some package may have appeared in ignored_packages due to the xs bootstrap hack *) - let l = List.filter (fun pkg -> not (List.mem pkg.package_name !ignored_packages)) l in + let l = List.filter (fun pkg -> not (List.mem pkg.package_name !Config_file.ignored_packages)) l in let l = if !restrict_to_files then List.filter (fun pkg -> List.mem pkg.file_name files) l else l in - List.iter (check_tree state) l + List.iter (Global_checks.check_tree state) l; + if !Flags.check_unused_global_vars then List.iter Global_checks.check_unused_vars l ) diff --git a/perl_checker.src/tree.ml b/perl_checker.src/tree.ml index 8cf6257..78f365b 100644 --- a/perl_checker.src/tree.ml +++ b/perl_checker.src/tree.ml @@ -1,9 +1,10 @@ open Types open Common open Printf +open Config_file open Parser_helper -type special_export = Re_export_all | Export_all +type special_export = Re_export_all | Fake_export_all type exports = { export_ok : (context * string) list ; @@ -17,33 +18,22 @@ type uses = (string * ((context * string) list option * pos)) list 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 ; + vars_declared : (context * string, pos * bool ref) Hashtbl.t ; + imported : ((context * string) * (string * bool ref)) 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 ; - } - -type vars = { - my_vars : ((context * string) * (pos * bool ref)) list list ; - our_vars : ((context * string) * (pos * bool ref)) list list ; - locally_imported : ((context * string) * string) list ; - required_vars : (context * string * string) list ; - current_package : per_package ; - state : state ; + required_packages : (string * pos) list ; + body : fromparser list ; + isa : (string * pos) list option ; + lines_starts : int list ; + build_time : int ; + from_cache : bool ; + from_basedir : bool ; } let anonymous_package_count = ref 0 -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 use_lib = ref [] +let use_lib = ref (readlines (Unix.open_process_in "perl -le 'print foreach @INC'")) let ignore_package pkg = if !Flags.verbose then print_endline_flush ("ignoring package " ^ pkg); @@ -79,21 +69,26 @@ let get_current_package t = 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, t ] -let from_qw = function +let from_qw_raw = function | Call_op("qw", [ Raw_string(s, pos)], _) -> - List.map (fun s -> - let context, s' = s2context s in - let context = - match context with - | I_raw -> if s'.[0] = ':' then I_raw else I_func - | I_func -> warn_with_pos pos "weird, exported name with a function context especially given"; I_func - | _ -> context - in context, s' - ) (words s) + List.map (fun symbol -> symbol, pos) (words s) | String(_, pos) -> warn_with_pos pos "not recognised yet" ; [] - | _ -> internal_error "get_exported" + | Raw_string(s, pos) -> + [ s, pos ] + | _ -> internal_error "from_qw_raw" + +let from_qw e = + List.map (fun (s, pos) -> + let context, s' = s2context s in + let context = + match context with + | I_raw -> if s'.[0] = ':' then I_raw else I_func + | I_func -> warn_with_pos pos "weird, exported name with a function context especially given"; I_func + | _ -> context + in context, s' + ) (from_qw_raw e) let get_exported t = List.fold_left (fun exports e -> @@ -109,7 +104,7 @@ let get_exported t = { exports with export_auto = from_qw v } | 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 } + | Perl_checker_comment("EXPORT-ALL", _) -> { exports with special_export = Some Fake_export_all } | List [ Call_op("=", [ Deref(I_array, Ident(None, "EXPORT_OK", _)); v ], pos)] | List [ Call_op("=", [ My_our("our", [(I_array, "EXPORT_OK")], _); v ], pos)] -> @@ -144,6 +139,19 @@ let get_exported t = with _ -> warn_with_pos pos "unrecognised %EXPORT_TAGS" ; exports) + + (* $EXPORT_TAGS{all} = [ map { @$_ } values %EXPORT_TAGS ]; *) + | List [Call_op("=", [ + Deref_with(I_hash, I_scalar, Ident(None, "EXPORT_TAGS", _), Raw_string("all", _)); + Ref(I_array, + List[List[ + Call(Deref(I_func, Ident(None, "map", _)), + [Anonymous_sub(Block [List [Deref(I_array, Deref(I_scalar, Ident(None, "_", _)))]], _); + Call(Deref(I_func, Ident(None, "values", _)), [Deref(I_hash, Ident(None, "EXPORT_TAGS", _))])]) + ]]) + ], _)] -> + { exports with export_tags = (":all", collect snd exports.export_tags) :: exports.export_tags } + | List (My_our _ :: _) -> let _,_ = e,e in exports @@ -151,8 +159,8 @@ let get_exported t = ) empty_exports t let uses_external_package = function - | "vars" | "MDK::Common::Globals" | "Exporter" | "diagnostics" | "strict" | "lib" | "POSIX" | "Gtk" | "Gtk2" - | "Config" | "Socket" | "Net::FTP" | "IO::Socket" | "DynaLoader" | "Data::Dumper" -> true + | "vars" | "MDK::Common::Globals" | "Exporter" | "diagnostics" | "strict" | "lib" | "POSIX" | "Gtk" | "Storable" + | "Config" | "Socket" | "IO::Socket" | "DynaLoader" | "Data::Dumper" | "Time::localtime" | "Expect" -> true | _ -> false let get_uses t = @@ -169,21 +177,87 @@ let get_uses t = | _ -> uses ) [] t -let get_vars_declaration state package = +let get_isa t = + List.fold_left (fun (isa, exporter) e -> + match e with + | List [ Call_op("=", [ Deref(I_array, Ident(None, "ISA", pos)) ; classes ], _) ] + | List [ Call_op("=", [ My_our("our", [ I_array, "ISA" ], pos) ; classes ], _) ] -> + if isa <> None || exporter <> None then die_with_pos pos "@ISA set twice"; + let special, l = List.partition (fun (s, _) -> s = "DynaLoader" || s = "Exporter") (from_qw_raw classes) in + let exporter = if List.mem_assoc "Exporter" special then Some pos else None in + let isa = if l = [] && special <> [] then None else Some l in + isa, exporter + | _ -> isa, exporter + ) (None, None) t + +let read_xs_extension_from_c global_vars_declared package pos = + try + let cfile = Filename.chop_extension package.file_name ^ ".c" in + let prefix = "newXS(\"" ^ package.package_name ^ "::" 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, ref false) + | l -> + if l <> [] then + let fql, name = split_last l in + let fq = String.concat "::" (package.package_name :: fql) in + Hashtbl.replace global_vars_declared (I_func, fq, name) pos + with Not_found -> ()); + in_bootstrap || str_contains s "XS_VERSION_BOOTCHECK" + ) false (open_in cfile)); + true + with Invalid_argument _ | Sys_error _ -> false + +let findfile dirs f = List.find (fun dir -> Sys.file_exists (dir ^ "/" ^ f)) dirs + +let read_xs_extension_from_so global_vars_declared package pos = + try + let splitted = split_at2 ':'':' package.package_name in + let rel_file = String.concat "/" ("auto" :: splitted @ [ last splitted ]) ^ ".so" in + let so = (findfile !use_lib rel_file) ^ "/" ^ rel_file in + let channel = Unix.open_process_in (Printf.sprintf "nm --defined-only -D \"%s\"" so) in + fold_lines (fun () s -> + let s = skip_n_char 11 s in + if str_begins_with s "XS_" then + let s = skip_n_char 3 s in + let len = String.length s in + let rec find_package_name accu i = + try + let i' = String.index_from s i '_' in + let accu = String.sub s i (i'-i) :: accu in + if i' + 1 < len && s.[i'+1] = '_' then + find_package_name accu (i' + 2) + else + List.rev accu, skip_n_char (i'+1) s + with Not_found -> List.rev accu, skip_n_char i s + in + let fq, name = find_package_name [] 0 in + Hashtbl.replace global_vars_declared (I_func, String.concat "::" fq, name) pos + ) () channel; + let _ = Unix.close_process_in channel in + true + with Not_found -> false + +let get_vars_declaration global_vars_declared package = List.iter (function | Sub_declaration(Ident(None, name, pos), _proto, _) -> - Hashtbl.replace package.vars_declared (I_func, name) pos + Hashtbl.replace package.vars_declared (I_func, name) (pos, ref false) | Sub_declaration(Ident(Some fq, name, pos), _proto, _) -> - Hashtbl.replace state.global_vars_declared (I_func, fq, name) pos + Hashtbl.replace global_vars_declared (I_func, fq, name) 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 + List.iter (fun (context, name) -> Hashtbl.replace package.vars_declared (context, name) (pos, ref false)) ours | Use(Ident(Some "MDK::Common", "Globals", pos), [ String _ ; ours ]) | Use(Ident(None, "vars", pos), [ours]) -> - List.iter (fun (context, name) -> Hashtbl.replace package.vars_declared (context, name) pos) (from_qw ours) + List.iter (fun (context, name) -> Hashtbl.replace package.vars_declared (context, name) (pos, ref false)) (from_qw ours) | Use(Ident(None, "vars", pos), _) -> die_with_pos pos "usage: use vars qw($var func)" @@ -191,70 +265,12 @@ let get_vars_declaration state package = 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 _ -> ignore_package pkg) + if not (read_xs_extension_from_c global_vars_declared package pos) then + if not (read_xs_extension_from_so global_vars_declared package pos) then + ignore_package pkg | _ -> () ) package.body -let rec get_imported state current_package (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 -> - (* HACK: if package exporting-all is ignored, ignore package importing *) - if List.mem package_name !ignored_packages then ignore_package current_package.package_name; - - 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) package.uses in - package.imported := Some l ; - l - let rec fold_tree f env e = match f env e with | Some env -> env @@ -302,22 +318,34 @@ and fold_tree_option f env = function | Some e -> fold_tree f env e -let get_global_info_from_package t = +let get_global_info_from_package from_basedir build_time t = let current_packages = get_current_package t in - map_withenv (fun required_packages (current_package, t) -> + List.map (fun (current_package, t) -> let exports = get_exported t in - let uses = get_uses t in + let exporting_something() = exports.export_ok <> [] || exports.export_auto <> [] || exports.export_tags <> [] || exports.special_export = Some Re_export_all in + let package_name = match current_package with | None -> - if exports.export_ok <> [] || exports.export_auto <> [] || exports.export_tags <> [] then + if exporting_something() 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 isa, exporter = get_isa t in + (match exporter with + | None -> + if exporting_something() then warn_with_pos (!Info.current_file, 0, 0) "you must have \"@ISA = qw(Exporter)\" to EXPORT something" + | Some pos -> + if not (exporting_something()) then warn_with_pos pos "Inheritating from Exporter without EXPORTing anything"); + + let uses = List.rev (get_uses t) in + let required_packages = List.map (fun (s, (_, pos)) -> s, pos) uses in let required_packages = List.fold_left (fold_tree (fun l -> function + | Perl_checker_comment(s, pos) when str_begins_with s "require " -> + Some((skip_n_char 8 s, pos) :: l) | 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) @@ -335,260 +363,12 @@ let get_global_info_from_package t = imported = ref None ; vars_declared = Hashtbl.create 16 ; uses = uses ; + required_packages = required_packages ; body = t ; - }, required_packages - ) [] current_packages - -let is_my_declared vars t = - List.exists (fun l -> - List.mem_assoc t l && (snd (List.assoc t l) := true ; true) - ) vars.my_vars -let is_our_declared vars t = - List.exists (fun l -> - List.mem_assoc t l && (snd (List.assoc t l) := true ; true) - ) vars.our_vars -let is_var_declared vars (context, name) = - 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) || - List.mem_assoc (context, name) (get_imports vars.state package) - with Not_found -> false) - - - -let is_global_var context ident = - match context with - | I_scalar -> - (match ident with - | "@" | "!" | ">" | "\\" | "$" | "^A" | "'" | "/" | "?" | "<" | "^W" | "|" | "^I" | "&" - | "0" | "1" | "2" | "3" | "4" | "5" | "6" | "7" | "8" | "9" -> true - | _ -> false) - | I_array -> - (match ident with - | "ARGV" | "INC" -> true - | _ -> false) - | I_hash -> - (match ident with - | "ENV" | "SIG" -> true - | _ -> false) - | I_star -> - (match ident with - | "STDIN" | "STDOUT" | "STDERR" - | "__FILE__" | "__LINE__" | "undef" -> true - | _ -> false) - | I_func -> - (match ident with - | "-b" | "-d" | "-e" | "-f" | "-l" | "-r" | "-s" | "-w" | "-x" - | "abs" | "alarm" | "basename" | "bless" - | "caller" | "chdir" | "chmod" | "chomp" | "chop" | "chown" | "chr" | "chroot" | "close" | "closedir" | "crypt" - | "defined" | "delete" | "die" - | "each" | "endpwent" | "eof" | "eval" | "exec" | "exists" | "exit" - | "fcntl" | "fileno" | "flock" | "formline" | "fork" - | "gethostbyaddr" | "gethostbyname" | "getgrnam" | "getgrgid" | "getppid" | "getpwent" | "getpwnam" | "getpwuid" | "gmtime" | "goto" | "grep" | "hex" - | "index" | "int" | "ioctl" | "join" | "keys" | "kill" - | "last" | "lc" | "length" | "link" | "localtime" | "log" | "lstat" - | "map" | "mkdir" | "next" | "no" | "oct" | "open" | "opendir" | "ord" - | "pack" | "pipe" | "pop" | "print" | "printf" | "push" | "quotemeta" - | "rand" | "read" | "readdir" | "readlink" | "redo" | "ref" | "rename" | "require" | "return" | "reverse" | "rmdir" - | "scalar" | "seek" | "select" | "setpwent" | "shift" | "sleep" | "sort" | "splice" | "split" | "sprintf" | "stat" | "substr" - | "symlink" | "syscall" | "sysopen" | "sysread" | "sysseek" | "system" | "syswrite" | "tie" | "time" - | "uc" | "umask" | "undef" | "unlink" | "unpack" | "unshift" | "utime" | "values" | "vec" | "waitpid" | "wantarray" | "warn" | "write" - -> true - - | _ -> false) - | _ -> false - -let check_variable (context, var) vars = - match var with - | Ident(Some pkg, _, _) when uses_external_package pkg || List.mem pkg !ignored_packages -> () - | Ident(None, ident, pos) -> - if is_my_declared vars (context, ident) || is_our_declared vars (context, ident) || is_global_var context ident || is_var_declared vars (context, ident) - then () - else warn_with_pos pos (if context = I_func then "unknown function " ^ ident else "undeclared variable " ^ variable2s(context, ident)) - | Ident(Some fq, name, pos) -> - if (fq = "CORE") && is_global_var context name || is_global_var_declared vars (context, fq, name) - then () - else - if context = I_func then - warn_with_pos pos ("unknown function " ^ string_of_Ident var) - else - lpush vars.state.global_vars_used ((context, fq, name), pos) - | _ -> () - -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) - else true - ) mys in - let l_pre = List.hd vars.my_vars in - List.iter (fun v -> - if List.mem_assoc v l_pre then warn_with_pos pos (sprintf "redeclared variable %s" (variable2s v)) - ) l_new ; - { vars with my_vars = (List.map (fun v -> v, (pos, ref false)) l_new @ l_pre) :: List.tl vars.my_vars } - -let declare_Our vars (ours, pos) = - match vars.our_vars with - | [] -> vars (* we're at the toplevel, already declared in vars_declared *) - | l_pre :: other -> - List.iter (fun v -> - if List.mem_assoc v l_pre && v <> (I_scalar, "_") then warn_with_pos pos (sprintf "redeclared variable %s" (variable2s v)) - ) ours ; - { vars with our_vars = (List.map (fun v -> v, (pos, ref false)) ours @ l_pre) :: other } - -let declare_My_our vars (my_or_our, l, pos) = - match my_or_our with - | "my" -> declare_My vars (l, pos) - | "local" - | "our" -> declare_Our vars (l, pos) - | _ -> internal_error "declare_My_our" - -let check_unused_local_variables vars = - List.iter (fun ((_, s as v), (pos, used)) -> - if not !used && s.[0] != '_' then warn_with_pos pos (sprintf "unused variable %s" (variable2s v)) - ) (List.hd vars.my_vars) - - - -let check_variables vars t = - let rec check_variables_ vars t = fold_tree check vars t - and check vars = function - | Block l -> - let vars' = { vars with my_vars = [] :: vars.my_vars ; our_vars = [] :: vars.our_vars } in - let vars' = List.fold_left check_variables_ vars' l in - check_unused_local_variables vars' ; - Some vars - | Call(Deref(I_func, Ident(None, "sort", _)), (Anonymous_sub(Block f, pos) :: l)) -> - let vars = List.fold_left check_variables_ vars l in - let vars' = { vars with my_vars = [ (I_scalar, "a"), (pos, ref true) ; (I_scalar, "b"), (pos, ref true) ] :: vars.my_vars ; our_vars = [] :: vars.our_vars } in - let vars' = List.fold_left check_variables_ vars' f in - check_unused_local_variables vars' ; - Some vars - - | Call(Deref(I_func, Ident(None, func, _)), Anonymous_sub(Block f, pos) :: l) when func = "grep" || func = "map" || func = "substInFile" || func = "map_index" || func = "each_index" || func = "partition" || func = "find_index" || func = "grep_index" -> - let vars = List.fold_left check_variables_ vars l in - let vars' = { vars with my_vars = [] :: vars.my_vars ; our_vars = [(I_scalar, "_"), (pos, ref true)] :: vars.our_vars } in - let vars' = List.fold_left check_variables_ vars' f in - check_unused_local_variables vars' ; - Some vars - - | Call_op("while infix", [ expr ; (List [ Call_op("<>", _, _) ] as l) ], pos) - | Call_op("for infix", [ expr ; l ], pos) -> - let vars = check_variables_ vars l in - let vars' = { vars with my_vars = [] :: vars.my_vars ; our_vars = [(I_scalar, "_"), (pos, ref true)] :: vars.our_vars } in - let vars' = check_variables_ vars' expr in - if List.hd(vars'.my_vars) <> [] then warn_with_pos pos "you can't declare variables in foreach infix"; - Some vars - - | 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" -> - 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 - check_unused_local_variables vars' ; - let vars = List.fold_left check_variables_ vars other in - Some vars - - | Sub_declaration(Ident(fq, name, pos) as ident, _proto, Block l) -> - let vars = declare_Our vars ([ I_func, string_of_Ident ident ], pos) in - let local_vars = ((I_array, "_"), (pos, ref true)) :: (if fq = None && name = "AUTOLOAD" then [ (I_scalar, "AUTOLOAD"), (pos, ref true) ] else []) in - let vars' = { vars with my_vars = [] :: vars.my_vars ; our_vars = local_vars :: vars.our_vars } in - let vars' = List.fold_left check_variables_ vars' l in - check_unused_local_variables vars' ; - Some vars - - | Anonymous_sub(Block l, pos) -> - let vars' = { vars with my_vars = [] :: vars.my_vars ; our_vars = [(I_array, "_"), (pos, ref true)] :: vars.our_vars } in - let vars' = List.fold_left check_variables_ vars' l in - check_unused_local_variables vars' ; - Some vars - - | Call_op("foreach", [ expr ; Block l ], pos) -> - let vars = check_variables_ vars expr in - let vars' = { vars with my_vars = [] :: vars.my_vars ; our_vars = [(I_scalar, "_"), (pos, ref true)] :: vars.our_vars } in - let vars' = List.fold_left check_variables_ vars' l in - check_unused_local_variables vars' ; - Some vars - - | Anonymous_sub _ - | Sub_declaration _ -> internal_error "check_variables" - - | Ident _ as var -> - check_variable (I_star, var) vars ; - Some vars - - | My_our(my_or_our, mys, pos) -> Some(declare_My_our vars (my_or_our, mys, pos)) - | Deref(context, (Ident _ as var)) -> - check_variable (context, var) vars ; - Some vars - | Deref_with(context, _, (Ident _ as var), para) -> - let vars = check_variables_ vars para in - check_variable (context, var) vars ; - 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 vars.current_package (package_name, (args, pos)) in - let vars = { vars with locally_imported = l @ vars.locally_imported } in - Some vars - - | _ -> None - in - let vars = List.fold_left check_variables_ { vars with my_vars = [[]] } t in - vars - -let check_tree state package = - 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 -> - (*print_endline_flush (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 } + isa = isa ; + lines_starts = !Info.current_file_lines_starts ; + build_time = build_time ; + from_cache = false ; + from_basedir = from_basedir ; + } + ) current_packages diff --git a/perl_checker.src/tree.mli b/perl_checker.src/tree.mli index e5d19c1..7fa5fad 100644 --- a/perl_checker.src/tree.mli +++ b/perl_checker.src/tree.mli @@ -1,6 +1,6 @@ open Types -type special_export = Re_export_all | Export_all +type special_export = Re_export_all | Fake_export_all type exports = { export_ok : (context * string) list; @@ -15,27 +15,29 @@ type uses = (string * ((context * string) list option * pos)) list 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; + vars_declared : (context * string, pos * bool ref) Hashtbl.t; + imported : ((context * string) * (string * bool ref)) list option ref; exports : exports ; uses : uses ; + required_packages : (string * pos) list ; body : fromparser list; + isa : (string * pos) list option ; + lines_starts : int list ; + build_time : int ; + from_cache : bool ; + from_basedir : bool ; } -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; - } - -val ignored_packages : string list ref + +val ignore_package : string -> unit val use_lib : string list ref +val uses_external_package : string -> bool +val findfile : string list -> string -> string -val default_state : state -val get_global_info_from_package : fromparser list -> per_package list * (string * pos) list -val get_vars_declaration : state -> per_package -> unit -val check_tree : state -> per_package -> unit +val get_global_info_from_package : bool -> int -> fromparser list -> per_package list +val get_vars_declaration : (context * string * string, pos) Hashtbl.t -> per_package -> unit val die_with_pos : string * int * int -> string -> 'a val warn_with_pos : string * int * int -> string -> unit -val add_package_to_state : state -> per_package -> state + +val fold_tree : ('a -> fromparser -> 'a option) -> 'a -> fromparser -> 'a +val from_qw : fromparser -> (context * string) list |