From 662cfb91ccb8a61683790b76b643e966ac005e8d Mon Sep 17 00:00:00 2001 From: Pascal Rigaux Date: Thu, 24 Apr 2003 19:17:03 +0000 Subject: - handle empty prototypes - check number of parameters in method calls (ignoring empty overloaded methods) - allow non-empty prototypes for methods not using @_ --- perl_checker.src/global_checks.ml | 52 +++++++++++++++++++++++--------------- perl_checker.src/global_checks.mli | 1 + perl_checker.src/lexer.mll | 8 +++++- perl_checker.src/parser.mly | 34 ++++++++++++++++--------- perl_checker.src/parser_helper.ml | 18 ++++++++----- perl_checker.src/parser_helper.mli | 6 ++++- perl_checker.src/tree.ml | 34 +++++++++++++++---------- perl_checker.src/tree.mli | 2 +- perl_checker.src/types.mli | 4 +-- 9 files changed, 101 insertions(+), 58 deletions(-) (limited to 'perl_checker.src') diff --git a/perl_checker.src/global_checks.ml b/perl_checker.src/global_checks.ml index 53324b9..f10b6ff 100644 --- a/perl_checker.src/global_checks.ml +++ b/perl_checker.src/global_checks.ml @@ -10,6 +10,7 @@ type state = { methods : (string, (pos * bool ref * prototype option) list) Hashtbl.t ; global_vars_declared : (context * string * string, pos * prototype option) Hashtbl.t ; global_vars_used : ((context * string * string) * pos) list ref ; + packages_being_classes : (string, unit) Hashtbl.t ; } type vars = { @@ -232,7 +233,7 @@ let un_parenthesize_one_elt_List = function let check_unused_local_variables vars = List.iter (fun ((_, s as v), (pos, used, _proto)) -> - if not !used && s.[0] != '_' && not (List.mem s [ "BEGIN"; "END"; "DESTROY" ]) then warn_with_pos pos (sprintf "unused variable %s" (variable2s v)) + if not !used && (s.[0] != '_' || s = "_") && not (List.mem s [ "BEGIN"; "END"; "DESTROY" ]) then warn_with_pos pos (sprintf "unused variable %s" (variable2s v)) ) (List.hd vars.my_vars) @@ -245,14 +246,14 @@ let check_variables vars t = 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)) -> + | 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, None) ; (I_scalar, "b"), (pos, ref true, None) ] :: 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) + | Call(Deref(I_func, Ident(None, func, func_pos)), Anonymous_sub(_, Block f, pos) :: l) when List.mem func [ "grep" ; "map" ; "substInFile" ; "map_index" ; "each_index" ; "partition" ; "find_index" ; "grep_index" ; "find" ; "any" ; "every" ] -> 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, None)] :: vars.our_vars } in @@ -261,10 +262,16 @@ let check_variables vars t = check_variable (I_func, Ident(None, func, func_pos)) vars None ; Some vars + | Call(Deref(I_func, (Ident _ as ident)), [ Deref(I_star, (Ident(None, "_", _))) ]) -> + (* the &f case: allow access to @_ *) + check_variable (I_func, ident) vars None ; + let _ = is_my_declared vars (I_array, "_") in + Some vars + | Call(Deref(I_func, (Ident _ as ident)), [ List [ Deref(I_array, (Ident(None, "_", pos))) ] ]) -> (* special warning if @_ is unbound *) check_variable (I_func, ident) vars None ; - if not (is_our_declared vars (I_array, "_")) then + if not (is_my_declared vars (I_array, "_")) then warn_with_pos pos (sprintf "replace %s(@_) with &%s" (string_of_Ident ident) (string_of_Ident ident)) ; Some vars @@ -293,27 +300,32 @@ let check_variables vars t = check_unused_local_variables vars' ; Some vars - | Sub_declaration(Ident(fq, name, pos) as ident, _perl_proto, Block body) -> + | Sub_declaration(Ident(fq, name, pos) as ident, perl_proto, Block body) -> let vars = declare_Our vars ([ I_func, string_of_Ident ident ], pos) in - let local_vars, l = - match has_proto (Block body) with + let my_vars, l = + match has_proto perl_proto (Block body) with | Some(mys, mys_pos, body) -> [], My_our ("my", mys, mys_pos) :: body - | _ -> [(I_array, "_"), (pos, ref true, None)], body + | _ -> + let dont_check_use = + fq = None && List.mem name ["BEGIN"; "END"; "DESTROY"] || + Hashtbl.mem vars.state.packages_being_classes (some_or fq vars.current_package.package_name) + in + [(I_array, "_"), (pos, ref dont_check_use, None)], body in let local_vars = if fq = None && name = "AUTOLOAD" - then ((I_scalar, "AUTOLOAD"), (pos, ref true, None)) :: local_vars - else local_vars in + then [ (I_scalar, "AUTOLOAD"), (pos, ref true, None) ] + else [] in - let vars' = { vars with my_vars = [] :: vars.my_vars ; our_vars = local_vars :: vars.our_vars } in + let vars' = { vars with my_vars = 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, None)] :: vars.our_vars } in + | Anonymous_sub(_, Block l, pos) -> + let vars' = { vars with my_vars = [(I_array, "_"), (pos, ref true, None)] :: vars.my_vars } in let vars' = List.fold_left check_variables_ vars' l in check_unused_local_variables vars' ; Some vars @@ -452,8 +464,8 @@ let arrange_global_vars_declared state = { state with global_vars_declared = h } let get_methods_available state = - let get_classes state = - let l = hashtbl_collect (fun _ package -> + let classes = uniq ( + hashtbl_collect (fun _ package -> match package.isa with | None -> if Hashtbl.mem package.vars_declared (I_func, "new") then [package] else [] @@ -463,20 +475,20 @@ let get_methods_available state = Hashtbl.find state.per_package pkg with Not_found -> die_with_pos pos ("bad package " ^ pkg) ) l - ) state.per_package in - uniq l - in + ) state.per_package + ) in List.iter (fun pkg -> + Hashtbl.replace state.packages_being_classes pkg.package_name () ; Hashtbl.iter (fun (context, v) (pos, is_used, proto) -> 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, proto) :: l) ) pkg.vars_declared - ) (get_classes state) ; + ) classes ; state -let default_state() = { per_package = Hashtbl.create 16; methods = Hashtbl.create 256 ; global_vars_declared = Hashtbl.create 256; global_vars_used = ref [] } +let default_state() = { per_package = Hashtbl.create 16; methods = Hashtbl.create 256 ; global_vars_declared = Hashtbl.create 256; global_vars_used = ref []; packages_being_classes = Hashtbl.create 16 } let cache_cache = Hashtbl.create 16 diff --git a/perl_checker.src/global_checks.mli b/perl_checker.src/global_checks.mli index e081e48..6b25f73 100644 --- a/perl_checker.src/global_checks.mli +++ b/perl_checker.src/global_checks.mli @@ -6,6 +6,7 @@ type state = { methods : (string, (pos * bool ref * prototype option) list) Hashtbl.t ; global_vars_declared : (context * string * string, pos * prototype option) Hashtbl.t; global_vars_used : ((context * string * string) * pos) list ref; + packages_being_classes : (string, unit) Hashtbl.t ; } val default_state : unit -> state diff --git a/perl_checker.src/lexer.mll b/perl_checker.src/lexer.mll index 59e348e..044c562 100644 --- a/perl_checker.src/lexer.mll +++ b/perl_checker.src/lexer.mll @@ -39,6 +39,7 @@ type raw_token = | RAW_IDENT of (string option * string * raw_pos) | RAW_IDENT_PAREN of (string option * string * raw_pos) | ARRAYLEN_IDENT of (string option * string * raw_pos) + | SUB_WITH_PROTO of (string * raw_pos) | FUNC_DECL_WITH_PROTO of (string * string * raw_pos) | IF of raw_pos | ELSIF of raw_pos | ELSE of raw_pos | UNLESS of raw_pos | DO of raw_pos | WHILE of raw_pos | UNTIL of raw_pos | MY_OUR of (string * raw_pos) | CONTINUE of raw_pos | SUB of raw_pos @@ -96,6 +97,7 @@ let rec raw_token_to_pos_and_token spaces = function | RAW_IDENT(kind, name, pos) -> pos, Parser.RAW_IDENT(new_any M_special (kind, name) spaces pos) | RAW_IDENT_PAREN(kind, name, pos) -> pos, Parser.RAW_IDENT_PAREN(new_any M_special (kind, name) spaces pos) | ARRAYLEN_IDENT(kind, name, pos) -> pos, Parser.ARRAYLEN_IDENT(new_any M_special (kind, name) spaces pos) + | SUB_WITH_PROTO(proto, pos) -> pos, Parser.SUB_WITH_PROTO(new_any M_special proto spaces pos) | FUNC_DECL_WITH_PROTO(name, proto, pos) -> pos, Parser.FUNC_DECL_WITH_PROTO(new_any M_special (name, proto) spaces pos) | NEW(pos) -> pos, Parser.NEW(new_any M_special () spaces pos) @@ -584,12 +586,16 @@ rule token = parse | "\\" ' '* '(' { putback lexbuf 1; REF(pos lexbuf) } +| "sub(" [ '$' '@' '\\' '&' ';' '%' ]* ')' { + SUB_WITH_PROTO(skip_n_char_ 4 1 (lexeme lexbuf), pos lexbuf) + } + | "sub" ' '+ ident ' '* '(' [ '$' '@' '\\' '&' ';' '%' ]* ')' { (* bloody prototypes, must be caught especially otherwise "($)" is badly tokenized *) (* and alas "($@)" is both valid as an expression and a prototype *) let s = lexeme lexbuf in let ident_start = non_index_from s 3 ' ' in - + let proto_start = String.index_from s ident_start '(' in let ident_end = non_rindex_from s (proto_start-1) ' ' in let ident = String.sub s ident_start (ident_end - ident_start + 1) in diff --git a/perl_checker.src/parser.mly b/perl_checker.src/parser.mly index 0b27e80..d2a8cc9 100644 --- a/perl_checker.src/parser.mly +++ b/perl_checker.src/parser.mly @@ -23,6 +23,7 @@ %token <((string * ((int * int) * token) list) list * (string * ((int * int) * token) list) list * string) Types.any_spaces_pos> PATTERN_SUBST %token <(string option * string) Types.any_spaces_pos> SCALAR_IDENT ARRAY_IDENT HASH_IDENT FUNC_IDENT STAR_IDENT RAW_IDENT RAW_IDENT_PAREN ARRAYLEN_IDENT +%token SUB_WITH_PROTO %token <(string * string) Types.any_spaces_pos> FUNC_DECL_WITH_PROTO %token FOR PRINT @@ -154,14 +155,14 @@ sideff: /* An expression which may have a side-effect */ decl: | FORMAT BAREWORD ASSIGN {new_esp M_special Too_complex $1 $3} | FORMAT ASSIGN {new_esp M_special Too_complex $1 $2} -| func_decl semi_colon {if snd $1.any = "" then die_rule "there is no need to pre-declare in Perl!" else (warn_rule "please don't use prototype pre-declaration" ; new_esp M_special Too_complex $1 $2) } +| func_decl semi_colon {if snd $1.any = None then die_rule "there is no need to pre-declare in Perl!" else (warn_rule "please don't use prototype pre-declaration" ; new_esp M_special Too_complex $1 $2) } | func_decl BRACKET BRACKET_END {sp_n($2); sp_0_or_cr($3); let name, proto = $1.any in new_esp M_none (sub_declaration (name, proto) []) $1 $3} | func_decl BRACKET lines BRACKET_END {sp_n($2); check_block_sub $3 $4; new_esp M_none (sub_declaration $1.any $3.any) $1 $4} | func_decl BRACKET BRACKET expr BRACKET_END BRACKET_END {sp_n($2); sp_p($3); sp_p($4); sp_p($5); sp_p($6); new_esp M_none (sub_declaration $1.any [Ref(I_hash, prio_lo P_loose $4)]) $1 $6} | func_decl BRACKET BRACKET expr BRACKET_END semi_colon BRACKET_END {sp_n($2); sp_p($3); sp_p($4); sp_p($5); sp_p($7); new_esp M_none (sub_declaration $1.any [Ref(I_hash, prio_lo P_loose $4); Semi_colon]) $1 $7} | PACKAGE word semi_colon {sp_0_or_cr($1); sp_1($2); new_esp M_none (Package $2.any) $1 $3} -| BEGIN BRACKET lines BRACKET_END {sp_0_or_cr($1); sp_1($2); check_block_sub $3 $4; new_esp M_none (Sub_declaration(Ident(None, "BEGIN", get_pos $1), "", Block $3.any)) $1 $4} -| END BRACKET lines BRACKET_END {sp_0_or_cr($1); sp_1($2); check_block_sub $3 $4; new_esp M_none (Sub_declaration(Ident(None, "END", get_pos $1), "", Block $3.any)) $1 $4} +| BEGIN BRACKET lines BRACKET_END {sp_0_or_cr($1); sp_1($2); check_block_sub $3 $4; new_esp M_none (Sub_declaration(Ident(None, "BEGIN", get_pos $1), None, Block $3.any)) $1 $4} +| END BRACKET lines BRACKET_END {sp_0_or_cr($1); sp_1($2); check_block_sub $3 $4; new_esp M_none (Sub_declaration(Ident(None, "END", get_pos $1), None, Block $3.any)) $1 $4} | use {$1} use: @@ -179,8 +180,8 @@ use_revision: | USE {$1} func_decl: -| SUB word { new_esp M_none ($2.any, "") $1 $2} -| FUNC_DECL_WITH_PROTO {new_1esp (Ident(None, fst $1.any, get_pos $1), snd $1.any) $1 } +| SUB word { new_esp M_none ($2.any, None) $1 $2} +| FUNC_DECL_WITH_PROTO {new_1esp (Ident(None, fst $1.any, get_pos $1), Some (snd $1.any)) $1 } listexpr: /* Basic list expressions */ | %prec PREC_LOW { default_pesp P_tok []} @@ -276,18 +277,27 @@ term: | BRACKET BRACKET_END {new_pesp (M_ref M_hash) P_expr (Ref(I_hash, List [])) $1 $2} /* empty hash */ | BRACKET_HASHREF expr BRACKET_END %prec PREC_HIGH {sp_p($3); new_pesp (M_ref M_hash) P_expr (Ref(I_hash, $2.any.expr)) $1 $3} /* { foo => "Bar" } */ -| SUB BRACKET BRACKET_END %prec PREC_HIGH {sp_n($2); sp_0($3); new_pesp (M_ref M_sub) P_expr (anonymous_sub (new_esp (M_ref M_array) [] $2 $2)) $1 $3} -| SUB BRACKET lines BRACKET_END %prec PREC_HIGH {sp_n($2); check_block_sub $3 $4; new_pesp (M_ref M_sub) P_expr (anonymous_sub $3) $1 $4} +| SUB BRACKET BRACKET_END %prec PREC_HIGH {sp_n($2); sp_0($3); new_pesp (M_ref M_sub) P_expr (anonymous_sub None (new_esp (M_ref M_array) [] $2 $2)) $1 $3} +| SUB_WITH_PROTO BRACKET BRACKET_END %prec PREC_HIGH {sp_n($2); sp_0($3); new_pesp (M_ref M_sub) P_expr (anonymous_sub (Some $1.any) (new_esp (M_ref M_array) [] $2 $2)) $1 $3} +| SUB BRACKET lines BRACKET_END %prec PREC_HIGH {sp_n($2); check_block_sub $3 $4; new_pesp (M_ref M_sub) P_expr (anonymous_sub None $3) $1 $4} +| SUB_WITH_PROTO BRACKET lines BRACKET_END %prec PREC_HIGH {sp_n($2); check_block_sub $3 $4; new_pesp (M_ref M_sub) P_expr (anonymous_sub (Some $1.any) $3) $1 $4} | termdo {new_1pesp P_tok $1.any $1} -| REF term {new_pesp (M_ref $2.mcontext) P_expr (Ref(I_scalar, $2.any.expr)) $1 $2} /* \$x, \@y, \%z */ +| REF term {new_pesp (M_ref $2.mcontext) P_expr (Ref(I_scalar, remove_call_with_same_para_special $2.any.expr)) $1 $2} /* \$x, \@y, \%z */ | my_our %prec UNIOP {new_1pesp P_expr $1.any $1} | LOCAL term %prec UNIOP {sp_n($2); new_pesp $2.mcontext P_expr (to_Local $2) $1 $2} | parenthesized {new_1pesp $1.any.priority (List $1.any.expr) $1} /* (1, 2) */ | parenthesized arrayref {sp_0($2); let is_slice = not (is_only_one_in_List $2.any) in new_pesp (if is_slice then M_list else M_scalar) P_tok (to_Deref_with(I_array, (if is_slice then I_array else I_scalar), List $1.any.expr, List $2.any)) $1 $2} /* list indexing or slicing */ -| variable {new_1pesp P_tok $1.any $1} +| variable { + let e = + match $1.any with + | Deref(I_func, Ident _) -> + call_with_same_para_special $1.any (* not the same as f(@_) *) + | e -> e in + new_1pesp P_tok e $1 + } | subscripted {new_1pesp P_tok $1.any $1} @@ -308,9 +318,9 @@ term: | func parenthesized {sp_0($2); new_pesp M_unknown P_tok (call_func true ($1.any, $2.any.expr)) $1 $2} /* &foo(@args) */ | word argexpr {check_parenthesized_first_argexpr_with_Ident $1.any $2; new_pesp M_unknown P_call_no_paren (call(Deref(I_func, $1.any), $2.any.expr)) $1 $2} /* foo $a, $b */ | word_paren parenthesized {sp_0($2); new_pesp M_unknown P_tok (call(Deref(I_func, $1.any), $2.any.expr)) $1 $2} /* foo(@args) */ -| word BRACKET lines BRACKET_END listexpr %prec LSTOP {sp_n($2); check_block_sub $3 $4; new_pesp M_unknown (if $5.any.expr = [] then P_tok else P_call_no_paren) (call(Deref(I_func, $1.any), anonymous_sub $3 :: $5.any.expr)) $1 $5} /* map { foo } @bar */ -| word BRACKET BRACKET expr BRACKET_END BRACKET_END listexpr %prec LSTOP {sp_n($2); sp_p($3); sp_p($4); sp_p($5); sp_p($6); new_pesp M_unknown (if $7.any.expr = [] then P_tok else P_call_no_paren) (call(Deref(I_func, $1.any), anonymous_sub(new_esp (M_ref M_hash) [ Ref(I_hash, $4.any.expr) ] $4 $4) :: $7.any.expr)) $1 $7} /* map { { foo } } @bar */ -| word BRACKET BRACKET expr BRACKET_END semi_colon BRACKET_END listexpr %prec LSTOP {sp_n($2); sp_p($3); sp_p($4); sp_p($5); sp_p($7); new_pesp M_unknown (if $8.any.expr = [] then P_tok else P_call_no_paren) (call(Deref(I_func, $1.any), anonymous_sub(new_esp (M_ref M_hash) [ Ref(I_hash, $4.any.expr); Semi_colon ] $4 $4) :: $8.any.expr)) $1 $8} /* map { { foo }; } @bar */ +| word BRACKET lines BRACKET_END listexpr %prec LSTOP {sp_n($2); check_block_sub $3 $4; new_pesp M_unknown (if $5.any.expr = [] then P_tok else P_call_no_paren) (call(Deref(I_func, $1.any), anonymous_sub None $3 :: $5.any.expr)) $1 $5} /* map { foo } @bar */ +| word BRACKET BRACKET expr BRACKET_END BRACKET_END listexpr %prec LSTOP {sp_n($2); sp_p($3); sp_p($4); sp_p($5); sp_p($6); new_pesp M_unknown (if $7.any.expr = [] then P_tok else P_call_no_paren) (call(Deref(I_func, $1.any), anonymous_sub None (new_esp (M_ref M_hash) [ Ref(I_hash, $4.any.expr) ] $4 $4) :: $7.any.expr)) $1 $7} /* map { { foo } } @bar */ +| word BRACKET BRACKET expr BRACKET_END semi_colon BRACKET_END listexpr %prec LSTOP {sp_n($2); sp_p($3); sp_p($4); sp_p($5); sp_p($7); new_pesp M_unknown (if $8.any.expr = [] then P_tok else P_call_no_paren) (call(Deref(I_func, $1.any), anonymous_sub None (new_esp (M_ref M_hash) [ Ref(I_hash, $4.any.expr); Semi_colon ] $4 $4) :: $8.any.expr)) $1 $8} /* map { { foo }; } @bar */ | term ARROW word_or_scalar parenthesized {sp_0($2); sp_0($3); sp_0($4); new_pesp M_unknown P_tok (to_Method_call($1.any.expr, $3.any, $4.any.expr)) $1 $4} /* $foo->bar(list) */ | term ARROW word_or_scalar {sp_0($2); sp_0($3); new_pesp M_unknown P_tok (to_Method_call($1.any.expr, $3.any, [])) $1 $3} /* $foo->bar */ diff --git a/perl_checker.src/parser_helper.ml b/perl_checker.src/parser_helper.ml index db6182c..fb8ba16 100644 --- a/perl_checker.src/parser_helper.ml +++ b/perl_checker.src/parser_helper.ml @@ -566,7 +566,11 @@ let to_Local esp = else die_with_rawpos esp.pos "bad argument to \"local\"" let sub_declaration (name, proto) body = Sub_declaration(name, proto, Block body) -let anonymous_sub body = Anonymous_sub (Block body.any, raw_pos2pos body.pos) +let anonymous_sub proto body = Anonymous_sub (proto, Block body.any, raw_pos2pos body.pos) +let call_with_same_para_special f = Call(f, [Deref(I_star, (Ident(None, "_", raw_pos2pos bpos)))]) +let remove_call_with_same_para_special = function + | Call(f, [Deref(I_star, (Ident(None, "_", _)))]) -> f + | e -> e let cook_call_op op para pos = (match op with @@ -604,19 +608,19 @@ let cook_call_op op para pos = | "=", [ Deref(I_star, (Ident _ as f1)); Deref(I_star, (Ident _ as f2)) ] -> let s1, s2 = string_of_Ident f1, string_of_Ident f2 in warn pos (sprintf "\"*%s = *%s\" is better written \"*%s = \\&%s\"" s1 s2 s1 s2) ; - sub_declaration (f1, "") [ Deref(I_func, f2) ] + sub_declaration (f1, None) [ call_with_same_para_special(Deref(I_func, f2)) ] | "=", [ Deref(I_star, Raw_string(sf1, pos_f1)); Deref(I_star, (Ident _ as f2)) ] -> let s2 = string_of_Ident f2 in warn pos (sprintf "\"*{'%s'} = *%s\" is better written \"*{'%s'} = \\&%s\"" sf1 s2 sf1 s2) ; - sub_declaration (Ident(None, sf1, pos_f1), "") [ Deref(I_func, f2) ] + sub_declaration (Ident(None, sf1, pos_f1), None) [ call_with_same_para_special(Deref(I_func, f2)) ] | "=", [ Deref(I_star, (Ident _ as f1)); Ref(I_scalar, Deref(I_func, (Ident _ as f2))) ] -> - sub_declaration (f1, "") [ Deref(I_func, f2) ] + sub_declaration (f1, None) [ call_with_same_para_special(Deref(I_func, f2)) ] | "=", [ Deref(I_star, Raw_string(sf1, pos_f1)); Ref(I_scalar, Deref(I_func, (Ident _ as f2))) ] -> - sub_declaration (Ident(None, sf1, pos_f1), "") [ Deref(I_func, f2) ] + sub_declaration (Ident(None, sf1, pos_f1), None) [ call_with_same_para_special(Deref(I_func, f2)) ] - | "=", [ Deref(I_star, (Ident _ as f1)); (Anonymous_sub _ as sub) ] -> - sub_declaration (f1, "") [ sub ] + | "=", [ Deref(I_star, (Ident _ as f1)); (Anonymous_sub(proto, sub, _)) ] -> + sub_declaration (f1, proto) [ sub ] | "||", e :: _ when is_always_true e -> warn_rule " || ... is the same as "; call | "&&", e :: _ when is_always_false e -> warn_rule " && ... is the same as "; call diff --git a/perl_checker.src/parser_helper.mli b/perl_checker.src/parser_helper.mli index 03d9af9..77fef90 100644 --- a/perl_checker.src/parser_helper.mli +++ b/perl_checker.src/parser_helper.mli @@ -149,9 +149,13 @@ val to_Local : Types.fromparser Types.prio_anyexpr Types.any_spaces_pos -> Types.fromparser val sub_declaration : - Types.fromparser * string -> Types.fromparser list -> Types.fromparser + Types.fromparser * string option -> + Types.fromparser list -> Types.fromparser val anonymous_sub : + string option -> Types.fromparser list Types.any_spaces_pos -> Types.fromparser +val call_with_same_para_special : Types.fromparser -> Types.fromparser +val remove_call_with_same_para_special : Types.fromparser -> Types.fromparser val cook_call_op : string -> Types.fromparser list -> int * int -> Types.fromparser val to_Call_op : diff --git a/perl_checker.src/tree.ml b/perl_checker.src/tree.ml index e69bd0b..8154eb6 100644 --- a/perl_checker.src/tree.ml +++ b/perl_checker.src/tree.ml @@ -116,7 +116,7 @@ let get_exported t = if exports.export_ok <> [] then warn_with_pos pos "weird, @EXPORT_OK set twice" ; (match v with | Call(Deref(I_func, Ident(None, "map", _)), - [ Anonymous_sub(Block [List [Deref(I_array, Deref(I_scalar, Ident (None, "_", _)))]], _); + [ 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_ok = collect snd exports.export_tags } | _ -> { exports with export_ok = from_qw v }) @@ -151,7 +151,7 @@ let get_exported t = Ref(I_array, List[List[ Call(Deref(I_func, Ident(None, "map", _)), - [Anonymous_sub(Block [List [Deref(I_array, Deref(I_scalar, Ident(None, "_", _)))]], _); + [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", _))])]) ]]) ], _)] -> @@ -246,25 +246,31 @@ let read_xs_extension_from_so global_vars_declared package pos = true with Not_found -> false -let has_proto = function - | Block (List [Call_op ("=", [My_our ("my", mys, mys_pos); Deref(I_array, Ident(None, "_", _))], _pos)] :: body) -> - Some(mys, mys_pos, body) - | _ -> None - -let get_proto body = +let has_proto perl_proto body = + match perl_proto with + | Some "" -> Some([], raw_pos2pos bpos, [body]) + | _ -> + match body with + | Block [] -> + Some([ I_array, "_empty" ], raw_pos2pos bpos, []) + | Block (List [Call_op ("=", [My_our ("my", mys, mys_pos); Deref(I_array, Ident(None, "_", _))], _pos)] :: body) -> + Some(mys, mys_pos, body) + | _ -> None + +let get_proto perl_proto body = map_option (fun (mys, _pos, _) -> let scalars, others = break_at (fun (context, _) -> context <> I_scalar) mys in let must_have, optional = break_at (fun (_, s) -> String.length s > 2 && (s.[0] = 'o' || s.[0] = 'b') && s.[1] = '_') scalars in let min = List.length must_have in { proto_nb_min = min; proto_nb_max = if others = [] then Some(min + List.length optional) else None } - ) (has_proto body) + ) (has_proto perl_proto body) let get_vars_declaration global_vars_declared package = List.iter (function - | Sub_declaration(Ident(None, name, pos), _perl_proto, body) -> - Hashtbl.replace package.vars_declared (I_func, name) (pos, ref false, get_proto body) - | Sub_declaration(Ident(Some fq, name, pos), _perl_proto, body) -> - Hashtbl.replace global_vars_declared (I_func, fq, name) (pos, get_proto body) + | Sub_declaration(Ident(None, name, pos), perl_proto, body) -> + Hashtbl.replace package.vars_declared (I_func, name) (pos, ref false, get_proto perl_proto body) + | Sub_declaration(Ident(Some fq, name, pos), perl_proto, body) -> + Hashtbl.replace global_vars_declared (I_func, fq, name) (pos, get_proto perl_proto body) | List [ Call_op("=", [My_our("our", ours, pos); _], _) ] | List [ Call_op("=", [My_our("local", ([ I_scalar, "_" ] as ours), pos); _], _) ] @@ -293,7 +299,7 @@ let rec fold_tree f env e = | Some env -> env | None -> match e with - | Anonymous_sub(e', _) + | Anonymous_sub(_, e', _) | Ref(_, e') | Deref(_, e') -> fold_tree f env e' diff --git a/perl_checker.src/tree.mli b/perl_checker.src/tree.mli index 48b2657..c3b89b2 100644 --- a/perl_checker.src/tree.mli +++ b/perl_checker.src/tree.mli @@ -40,7 +40,7 @@ val findfile : string list -> string -> string val get_global_info_from_package : bool -> int -> fromparser list -> per_package list -val has_proto : fromparser -> ((context * string) list * pos * fromparser list) option +val has_proto : string option -> fromparser -> ((context * string) list * pos * fromparser list) option val get_vars_declaration : (context * string * string, pos * prototype option) Hashtbl.t -> per_package -> unit val die_with_pos : string * int * int -> string -> 'a diff --git a/perl_checker.src/types.mli b/perl_checker.src/types.mli index c8fbeaa..1a33d20 100644 --- a/perl_checker.src/types.mli +++ b/perl_checker.src/types.mli @@ -47,10 +47,10 @@ type fromparser = | Call of fromparser * fromparser list | Method_call of fromparser * fromparser * fromparser list - | Anonymous_sub of fromparser * pos + | Anonymous_sub of string option * fromparser * pos (* prototype, expr, pos *) | My_our of string * (context * string) list * pos | Use of fromparser * fromparser list - | Sub_declaration of fromparser * string * fromparser (* name, prototype, body *) + | Sub_declaration of fromparser * string option * fromparser (* name, prototype, body *) | Package of fromparser | Label of string | Perl_checker_comment of string * pos -- cgit v1.2.1