summaryrefslogtreecommitdiffstats
path: root/perl_checker.src
diff options
context:
space:
mode:
Diffstat (limited to 'perl_checker.src')
-rw-r--r--perl_checker.src/global_checks.ml52
-rw-r--r--perl_checker.src/global_checks.mli1
-rw-r--r--perl_checker.src/lexer.mll8
-rw-r--r--perl_checker.src/parser.mly34
-rw-r--r--perl_checker.src/parser_helper.ml18
-rw-r--r--perl_checker.src/parser_helper.mli6
-rw-r--r--perl_checker.src/tree.ml34
-rw-r--r--perl_checker.src/tree.mli2
-rw-r--r--perl_checker.src/types.mli4
9 files changed, 101 insertions, 58 deletions
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 <string Types.any_spaces_pos> SUB_WITH_PROTO
%token <(string * string) Types.any_spaces_pos> FUNC_DECL_WITH_PROTO
%token <string Types.any_spaces_pos> 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 "<constant> || ... is the same as <constant>"; call
| "&&", e :: _ when is_always_false e -> warn_rule "<constant> && ... is the same as <constant>"; 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
generated by cgit v1.2.1 (git 2.21.0) at 2024-11-05 06:32:44 +0000