summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--perl_checker.src/common.ml47
-rw-r--r--perl_checker.src/common.mli5
-rw-r--r--perl_checker.src/lexer.mll14
-rw-r--r--perl_checker.src/parser.mly178
-rw-r--r--perl_checker.src/parser_helper.ml250
-rw-r--r--perl_checker.src/parser_helper.mli56
-rw-r--r--perl_checker.src/perl_checker.ml41
-rw-r--r--perl_checker.src/tree.ml323
-rw-r--r--perl_checker.src/tree.mli9
-rw-r--r--perl_checker.src/types.mli8
10 files changed, 606 insertions, 325 deletions
diff --git a/perl_checker.src/common.ml b/perl_checker.src/common.ml
index 64e123d..a4d0789 100644
--- a/perl_checker.src/common.ml
+++ b/perl_checker.src/common.ml
@@ -643,12 +643,24 @@ let int_sort l = sort (fun a b -> a - b) l
let str_begins_with s prefix =
String.sub s 0 (min (String.length s) (String.length prefix)) = prefix
-let rec str_contains s1 s2 =
- match s1 with
- | "" -> false
- | _ ->
- if str_begins_with s1 s2 then true
- else str_contains (String.sub s1 1 (String.length s1 - 1)) s2
+let rec strstr s subs =
+ let len_s, len_subs = String.length s, String.length subs in
+ let rec rec_ i =
+ let i' = String.index_from s i subs.[0] in
+ if i' + len_subs <= len_s then
+ if String.sub s i' len_subs = subs then
+ i'
+ else
+ rec_ (i' + 1)
+ else
+ raise Not_found
+ in
+ rec_ 0
+
+let str_contains s subs =
+ try
+ let _ = strstr s subs in true
+ with Not_found -> false
let str_ends_with s suffix =
let len = min (String.length s) (String.length suffix) in
@@ -686,6 +698,29 @@ let rec explode_string = function
let is_uppercase c = Char.lowercase c <> c
let is_lowercase c = Char.uppercase c <> c
+let char_is_alphanumerical c =
+ let i = Char.code c in
+ Char.code 'a' <= i && i <= Char.code 'z' ||
+ Char.code 'A' <= i && i <= Char.code 'Z' ||
+ Char.code '0' <= i && i <= Char.code '9'
+
+let char_is_alphanumerical_ c =
+ let i = Char.code c in
+ Char.code 'a' <= i && i <= Char.code 'z' ||
+ Char.code 'A' <= i && i <= Char.code 'Z' ||
+ Char.code '0' <= i && i <= Char.code '9' || c = '_'
+
+let char_is_alpha c =
+ let i = Char.code c in
+ Char.code 'a' <= i && i <= Char.code 'z' ||
+ Char.code 'A' <= i && i <= Char.code 'Z'
+
+let rec string_forall_with f i s =
+ try
+ f s.[i] && string_forall_with f (i+1) s
+ with Invalid_argument _ -> true
+
+
let starts_with_non_lowercase s = s <> "" && s.[0] <> '_' && not (is_lowercase s.[0])
let rec fold_lines f init chan =
diff --git a/perl_checker.src/common.mli b/perl_checker.src/common.mli
index 397af3c..cfb4780 100644
--- a/perl_checker.src/common.mli
+++ b/perl_checker.src/common.mli
@@ -175,6 +175,7 @@ val graph_sort_by :
('a * 'a list) list -> (('a * 'a list) list, 'a * 'a) or_option
val int_sort : int list -> int list
val str_begins_with : string -> string -> bool
+val strstr : string -> string -> int
val str_contains : string -> string -> bool
val str_ends_with : string -> string -> bool
val chop : string -> string
@@ -189,6 +190,10 @@ val non_rindex : string -> char -> int
val explode_string : string -> char list
val is_uppercase : char -> bool
val is_lowercase : char -> bool
+val char_is_alphanumerical : char -> bool
+val char_is_alphanumerical_ : char -> bool
+val char_is_alpha : char -> bool
+val string_forall_with : (char -> bool) -> int -> string -> bool
val starts_with_non_lowercase : string -> bool
val fold_lines : ('a -> string -> 'a) -> 'a -> in_channel -> 'a
val readlines : in_channel -> string list
diff --git a/perl_checker.src/lexer.mll b/perl_checker.src/lexer.mll
index 1e1c875..b295400 100644
--- a/perl_checker.src/lexer.mll
+++ b/perl_checker.src/lexer.mll
@@ -51,14 +51,14 @@ type raw_token =
and raw_interpolated_string = (string * raw_token list) list
-let rec concat_bareword_paren = function
+let rec concat_bareword_paren accu = function
| PRINT(s, pos1) :: PAREN(pos2) :: l
| BAREWORD(s, pos1) :: PAREN(pos2) :: l ->
- BAREWORD_PAREN(s, pos1) :: PAREN(pos2) :: concat_bareword_paren l
+ concat_bareword_paren (PAREN(pos2) :: BAREWORD_PAREN(s, pos1) :: accu) l
| RAW_IDENT(kind, ident, pos1) :: PAREN(pos2) :: l ->
- RAW_IDENT_PAREN(kind, ident, pos1) :: PAREN(pos2) :: concat_bareword_paren l
- | [] -> []
- | e :: l -> e :: concat_bareword_paren l
+ concat_bareword_paren (PAREN(pos2) :: RAW_IDENT_PAREN(kind, ident, pos1) :: accu) l
+ | [] -> List.rev accu
+ | e :: l -> concat_bareword_paren (e :: accu) l
let rec raw_token_to_pos_and_token spaces = function
| NUM(s, pos) -> pos, Parser.NUM(s, (spaces, pos))
@@ -188,7 +188,7 @@ let rec lexbuf2list accu t lexbuf =
let get_token token lexbuf =
let tokens = lexbuf2list [] token lexbuf in
- let tokens = concat_bareword_paren tokens in
+ let tokens = concat_bareword_paren [] tokens in
let tokens = concat_spaces Space_0 tokens in
tokens
@@ -268,7 +268,7 @@ let string_interpolate token pre lexbuf =
let local_lexbuf = Lexing.from_string (pre ^ s ^ " ") in (* add a space to help tokenizing "xxx$$" *)
local_lexbuf.lex_abs_pos <- lexeme_start lexbuf ;
let l = lexbuf2list [] token local_lexbuf in
- let l = concat_bareword_paren l in
+ let l = concat_bareword_paren [] l in
next_interpolated l;
(Stack.pop next_rule) lexbuf
diff --git a/perl_checker.src/parser.mly b/perl_checker.src/parser.mly
index 90eab90..7d7948a 100644
--- a/perl_checker.src/parser.mly
+++ b/perl_checker.src/parser.mly
@@ -115,8 +115,8 @@ line:
| BRACKET lines BRACKET_END {check_block_sub $2 $3; [Block(fst $2)], sp_pos_range $1 $3}
if_then_else: /* Real conditional expressions */
-| IF PAREN expr PAREN_END BRACKET lines BRACKET_END elsif else_ {sp_p($1); sp_n($2); sp_0($3); sp_0_or_cr($4); sp_p($5); check_block_sub $6 $7; Call_op("if", prio_lo P_loose $3 :: Block(fst $6) :: fst $8 @ fst $9), sp_pos_range $1 $9}
-| UNLESS PAREN expr PAREN_END BRACKET lines BRACKET_END elsif else_ {sp_p($1); sp_n($2); sp_0($3); sp_0_or_cr($4); sp_p($5); check_block_sub $6 $7; Call_op("unless", prio_lo P_loose $3 :: Block(fst $6) :: fst $8 @ fst $9), sp_pos_range $1 $9}
+| IF PAREN expr PAREN_END BRACKET lines BRACKET_END elsif else_ {sp_p($1); sp_n($2); sp_0($3); sp_0_or_cr($4); sp_p($5); check_block_sub $6 $7; to_Call_op("if", prio_lo P_loose $3 :: Block(fst $6) :: fst $8 @ fst $9) (sp_pos_range $1 $9)}
+| UNLESS PAREN expr PAREN_END BRACKET lines BRACKET_END elsif else_ {sp_p($1); sp_n($2); sp_0($3); sp_0_or_cr($4); sp_p($5); check_block_sub $6 $7; to_Call_op("unless", prio_lo P_loose $3 :: Block(fst $6) :: fst $8 @ fst $9) (sp_pos_range $1 $9)}
elsif:
| {[], (Space_none, bpos)}
@@ -127,12 +127,12 @@ else_:
| ELSE BRACKET lines BRACKET_END {sp_p($1); sp_n($2); check_block_sub $3 $4; [Block(fst $3)], sp_pos_range $1 $4}
loop:
-| WHILE PAREN expr PAREN_END BRACKET lines BRACKET_END cont {sp_p($1); sp_n($2); sp_0($3); sp_0_or_cr($4); sp_p($5); check_block_sub $6 $7; Call_op("while", [ prio_lo P_loose $3; Block(fst $6) ]), sp_pos_range $1 $8}
-| UNTIL PAREN expr PAREN_END BRACKET lines BRACKET_END cont {sp_p($1); sp_n($2); sp_0($3); sp_0_or_cr($4); sp_p($5); check_block_sub $6 $7; Call_op("until", [ prio_lo P_loose $3; Block(fst $6) ]), sp_pos_range $1 $8}
-| FOR PAREN expr_or_empty semi_colon expr_or_empty semi_colon expr_or_empty PAREN_END BRACKET lines BRACKET_END {sp_p($1); check_for($1); sp_n($2); sp_0($3); sp_p($5); sp_p($7); sp_0($8); sp_n($9); check_block_sub $10 $11; Call_op("for", [ fst $3; fst $5; fst $7; Block(fst $10) ]), sp_pos_range $1 $11}
+| WHILE PAREN expr PAREN_END BRACKET lines BRACKET_END cont {sp_p($1); sp_n($2); sp_0($3); sp_0_or_cr($4); sp_p($5); check_block_sub $6 $7; to_Call_op("while", [ prio_lo P_loose $3; Block(fst $6) ]) (sp_pos_range $1 $8)}
+| UNTIL PAREN expr PAREN_END BRACKET lines BRACKET_END cont {sp_p($1); sp_n($2); sp_0($3); sp_0_or_cr($4); sp_p($5); check_block_sub $6 $7; to_Call_op("until", [ prio_lo P_loose $3; Block(fst $6) ]) (sp_pos_range $1 $8)}
+| FOR PAREN expr_or_empty semi_colon expr_or_empty semi_colon expr_or_empty PAREN_END BRACKET lines BRACKET_END {sp_p($1); check_for($1); sp_n($2); sp_0($3); sp_p($5); sp_p($7); sp_0($8); sp_n($9); check_block_sub $10 $11; to_Call_op("for", [ fst $3; fst $5; fst $7; Block(fst $10) ]) (sp_pos_range $1 $11)}
| FOR SCALAR_IDENT PAREN expr PAREN_END BRACKET lines BRACKET_END cont { die_rule "don't use for without \"my\"ing the iteration variable" }
-| FOR PAREN expr PAREN_END BRACKET lines BRACKET_END cont {sp_p($1); sp_n($2); sp_0($3); sp_0_or_cr($4); sp_p($5); check_block_sub $6 $7; check_foreach($1); Call_op("foreach", [ prio_lo P_loose $3; Block(fst $6) ]), sp_pos_range $1 $8}
-| for_my lines BRACKET_END cont {check_block_sub $2 $3; Call_op("foreach my", fst $1 @ [ Block(fst $2) ]), sp_pos_range $1 $4}
+| FOR PAREN expr PAREN_END BRACKET lines BRACKET_END cont {sp_p($1); sp_n($2); sp_0($3); sp_0_or_cr($4); sp_p($5); check_block_sub $6 $7; check_for_foreach $1 $3; to_Call_op("foreach", [ prio_lo P_loose $3; Block(fst $6) ]) (sp_pos_range $1 $8)}
+| for_my lines BRACKET_END cont {check_block_sub $2 $3; to_Call_op("foreach my", fst $1 @ [ Block(fst $2) ]) (sp_pos_range $1 $4)}
for_my:
| FOR MY_OUR SCALAR_IDENT PAREN expr PAREN_END BRACKET {sp_p($1); check_my($2); check_foreach($1); sp_n($4); sp_0($5); sp_0_or_cr($6); sp_p($7); [ My_our(fst $2, [I_scalar, sndfst $3], get_pos $3); prio_lo P_loose $5 ], sp_pos_range $1 $7}
@@ -144,11 +144,11 @@ cont: /* Continue blocks */
sideff: /* An expression which may have a side-effect */
| expr {sndfst $1, snd $1}
-| expr IF expr {sp_p($2); sp_p($3); Call_op("if infix" , [ prio_lo P_loose $1 ; prio_lo P_loose $3 ]), sp_pos_range $1 $3}
-| expr UNLESS expr {sp_p($2); sp_p($3); Call_op("unless infix", [ prio_lo P_loose $1 ; prio_lo P_loose $3 ]), sp_pos_range $1 $3}
-| expr WHILE expr {sp_p($2); sp_p($3); Call_op("while infix" , [ prio_lo P_loose $1 ; prio_lo P_loose $3 ]), sp_pos_range $1 $3}
-| expr UNTIL expr {sp_p($2); sp_p($3); Call_op("until infix" , [ prio_lo P_loose $1 ; prio_lo P_loose $3 ]), sp_pos_range $1 $3}
-| expr FOR expr {sp_p($2); sp_p($3); check_foreach($2); Call_op("for infix" , [ prio_lo P_loose $1 ; prio_lo P_loose $3 ]), sp_pos_range $1 $3}
+| expr IF expr {sp_p($2); sp_p($3); call_op_if_infix (prio_lo P_loose $1) (prio_lo P_loose $3) (sp_pos_range $1 $3)}
+| expr UNLESS expr {sp_p($2); sp_p($3); call_op_unless_infix (prio_lo P_loose $1) (prio_lo P_loose $3) (sp_pos_range $1 $3)}
+| expr WHILE expr {sp_p($2); sp_p($3); to_Call_op("while infix" , [ prio_lo P_loose $1 ; prio_lo P_loose $3 ]) (sp_pos_range $1 $3)}
+| expr UNTIL expr {sp_p($2); sp_p($3); to_Call_op("until infix" , [ prio_lo P_loose $1 ; prio_lo P_loose $3 ]) (sp_pos_range $1 $3)}
+| expr FOR expr {sp_p($2); sp_p($3); check_foreach($2); to_Call_op("for infix" , [ prio_lo P_loose $1 ; prio_lo P_loose $3 ]) (sp_pos_range $1 $3)}
decl:
| FORMAT BAREWORD ASSIGN {Too_complex, sp_pos_range $1 $3}
@@ -185,8 +185,8 @@ listexpr: /* Basic list expressions */
| argexpr %prec PREC_LOW {$1}
expr: /* Ordinary expressions; logical combinations */
-| expr AND expr {sp_p($2); sp_p($3); (P_and, Call_op("and", [ prio_lo P_and $1; prio_lo_after P_and $3 ])), sp_pos_range $1 $3}
-| expr OR expr {sp_p($2); sp_p($3); (P_or, Call_op("or", [ prio_lo P_or $1; prio_lo_after P_or $3 ])), sp_pos_range $1 $3}
+| expr AND expr {sp_p($2); sp_p($3); to_Call_op_(P_and, "and", [ prio_lo P_and $1; prio_lo_after P_and $3 ]) (sp_pos_range $1 $3)}
+| expr OR expr {sp_p($2); sp_p($3); to_Call_op_(P_or, "or", [ prio_lo P_or $1; prio_lo_after P_or $3 ]) (sp_pos_range $1 $3)}
| argexpr %prec PREC_LOW {(fstfst $1, List(sndfst $1)), snd $1}
argexpr: /* Expressions are a list of terms joined by commas */
@@ -197,31 +197,32 @@ argexpr: /* Expressions are a list of terms joined by commas */
/********************************************************************************/
term:
-| term ASSIGN term {let pri = P_assign in call_op(op pri (fst $2) $2, $3, [sndfst $1; prio_lo_after pri $3]), sp_pos_range $1 $3}
-| term PLUS term {let pri = P_add in call_op(op pri (fst $2) $2, $3, [prio_lo pri $1; prio_lo_after pri $3]), sp_pos_range $1 $3}
-| term COMPARE_OP term {let pri = P_cmp in call_op(op_p pri (fst $2) $2, $3, [prio_lo pri $1; prio_lo_after pri $3]), sp_pos_range $1 $3}
-| term LT term {let pri = P_cmp in call_op(op_p pri "<" $2, $3, [prio_lo pri $1; prio_lo_after pri $3]), sp_pos_range $1 $3}
-| term GT term {let pri = P_cmp in call_op(op_p pri ">" $2, $3, [prio_lo pri $1; prio_lo_after pri $3]), sp_pos_range $1 $3}
-| term EQ_OP term {let pri = P_eq in call_op(op_p pri (fst $2) $2, $3, [prio_lo pri $1; prio_lo_after pri $3]), sp_pos_range $1 $3}
-| term POWER term {let pri = P_tight in call_op(op pri "**" $2, $3, [prio_lo pri $1; prio_lo_after pri $3]), sp_pos_range $1 $3}
-| term BIT_AND term {let pri = P_expr in call_op(op_p pri "&" $2, $3, [prio_lo pri $1; prio_lo_after pri $3]), sp_pos_range $1 $3}
-| term BIT_OR term {let pri = P_expr in call_op(op pri "|" $2, $3, [prio_lo pri $1; prio_lo_after pri $3]), sp_pos_range $1 $3}
-| term BIT_XOR term {let pri = P_expr in call_op(op_p pri "^" $2, $3, [prio_lo pri $1; prio_lo_after pri $3]), sp_pos_range $1 $3}
-| term AND_TIGHT term {let pri = P_tight_and in call_op(op_p pri "&&" $2, $3, [prio_lo pri $1; prio_lo_after pri $3]), sp_pos_range $1 $3}
-| term OR_TIGHT term {let pri = P_tight_or in call_op(op_p pri "||" $2, $3, [prio_lo pri $1; prio_lo_after pri $3]), sp_pos_range $1 $3}
-| term MULT term {let pri = P_mul in call_op(op pri (fst $2) $2, $3, [prio_lo_concat $1; prio_lo_after pri $3]), sp_pos_range $1 $3}
-| term DOTDOT term {let pri = P_paren_wanted P_expr in call_op(op pri (fst $2) $2, $3, [prio_lo pri $1; prio_lo_after pri $3]), sp_pos_range $1 $3}
-| term BIT_SHIFT term {let pri = P_paren_wanted P_tight in call_op(op pri (fst $2) $2, $3, [prio_lo pri $1; prio_lo_after pri $3]), sp_pos_range $1 $3}
-| term XOR term {let pri = P_paren_wanted P_expr in call_op(op_p pri "xor" $2, $3, [prio_lo pri $1; prio_lo_after pri $3]), sp_pos_range $1 $3}
-
-| term ASSIGN BRACKET expr BRACKET_END {sp_p($3); sp_p($4); sp_p($5); call_op(op_p P_assign (fst $2) $2, $3, [prio_lo P_assign $1; Ref(I_hash, sndfst $4)]), sp_pos_range $1 $5}
-| term AND_TIGHT BRACKET expr BRACKET_END {sp_p($3); sp_p($4); sp_p($5); call_op(op_p P_tight_and "&&" $2, $3, [prio_lo P_assign $1; Ref(I_hash, sndfst $4)]), sp_pos_range $1 $5}
-| term OR_TIGHT BRACKET expr BRACKET_END {sp_p($3); sp_p($4); sp_p($5); call_op(op_p P_tight_or "||" $2, $3, [prio_lo P_assign $1; Ref(I_hash, sndfst $4)]), sp_pos_range $1 $5}
-
-
-| term PATTERN_MATCH PATTERN {sp_n($2); sp_p($3); (P_expr, Call_op("m//", sndfst $1 :: from_PATTERN $3)), sp_pos_range $1 $3}
-| term PATTERN_MATCH_NOT PATTERN {sp_n($2); sp_p($3); (P_expr, Call_op("!m//", sndfst $1 :: from_PATTERN $3)), sp_pos_range $1 $3}
-| term PATTERN_MATCH PATTERN_SUBST {sp_n($2); sp_p($3); (P_expr, Call_op("s///", sndfst $1 :: from_PATTERN_SUBST $3)), sp_pos_range $1 $3}
+| term ASSIGN term {let pri = P_assign in call_op_(op pri (fst $2) $2, $3, [sndfst $1; prio_lo_after pri $3]) (sp_pos_range $1 $3)}
+| term PLUS term {let pri = P_add in call_op_(op pri (fst $2) $2, $3, [prio_lo pri $1; prio_lo_after pri $3]) (sp_pos_range $1 $3)}
+| term COMPARE_OP term {let pri = P_cmp in call_op_(op_p pri (fst $2) $2, $3, [prio_lo pri $1; prio_lo_after pri $3]) (sp_pos_range $1 $3)}
+| term LT term {let pri = P_cmp in call_op_(op_p pri "<" $2, $3, [prio_lo pri $1; prio_lo_after pri $3]) (sp_pos_range $1 $3)}
+| term GT term {let pri = P_cmp in call_op_(op_p pri ">" $2, $3, [prio_lo pri $1; prio_lo_after pri $3]) (sp_pos_range $1 $3)}
+| term EQ_OP term {let pri = P_eq in call_op_(op_p pri (fst $2) $2, $3, [prio_lo pri $1; prio_lo_after pri $3]) (sp_pos_range $1 $3)}
+| term POWER term {let pri = P_tight in call_op_(op pri "**" $2, $3, [prio_lo pri $1; prio_lo_after pri $3]) (sp_pos_range $1 $3)}
+| term BIT_AND term {let pri = P_expr in call_op_(op_p pri "&" $2, $3, [prio_lo pri $1; prio_lo_after pri $3]) (sp_pos_range $1 $3)}
+| term BIT_OR term {let pri = P_expr in call_op_(op pri "|" $2, $3, [prio_lo pri $1; prio_lo_after pri $3]) (sp_pos_range $1 $3)}
+| term BIT_XOR term {let pri = P_expr in call_op_(op_p pri "^" $2, $3, [prio_lo pri $1; prio_lo_after pri $3]) (sp_pos_range $1 $3)}
+| term AND_TIGHT term {let pri = P_tight_and in call_op_(op_p pri "&&" $2, $3, [prio_lo pri $1; prio_lo_after pri $3]) (sp_pos_range $1 $3)}
+| term OR_TIGHT term {let pri = P_tight_or in call_op_(op_p pri "||" $2, $3, [prio_lo pri $1; prio_lo_after pri $3]) (sp_pos_range $1 $3)}
+| term MULT term {let pri = P_mul in call_op_(op pri (fst $2) $2, $3, [prio_lo_concat $1; prio_lo_after pri $3]) (sp_pos_range $1 $3)}
+| term DOTDOT term {let pri = P_paren_wanted P_expr in call_op_(op pri (fst $2) $2, $3, [prio_lo pri $1; prio_lo_after pri $3]) (sp_pos_range $1 $3)}
+| term BIT_SHIFT term {let pri = P_paren_wanted P_tight in call_op_(op pri (fst $2) $2, $3, [prio_lo pri $1; prio_lo_after pri $3]) (sp_pos_range $1 $3)}
+| term XOR term {let pri = P_paren_wanted P_expr in call_op_(op_p pri "xor" $2, $3, [prio_lo pri $1; prio_lo_after pri $3]) (sp_pos_range $1 $3)}
+
+| term ASSIGN BRACKET expr BRACKET_END {sp_p($3); sp_p($4); sp_p($5); call_op_(op_p P_assign (fst $2) $2, $3, [prio_lo P_assign $1; Ref(I_hash, sndfst $4)]) (sp_pos_range $1 $5)}
+| term AND_TIGHT BRACKET expr BRACKET_END {sp_p($3); sp_p($4); sp_p($5); call_op_(op_p P_tight_and "&&" $2, $3, [prio_lo P_assign $1; Ref(I_hash, sndfst $4)]) (sp_pos_range $1 $5)}
+| term OR_TIGHT BRACKET expr BRACKET_END {sp_p($3); sp_p($4); sp_p($5); call_op_(op_p P_tight_or "||" $2, $3, [prio_lo P_assign $1; Ref(I_hash, sndfst $4)]) (sp_pos_range $1 $5)}
+
+
+| term PATTERN_MATCH PATTERN {sp_n($2); sp_p($3); check_unneeded_var_dollar_ ($1); to_Call_op_(P_expr, "m//", sndfst $1 :: from_PATTERN $3) (sp_pos_range $1 $3)}
+| term PATTERN_MATCH_NOT PATTERN {sp_n($2); sp_p($3); check_unneeded_var_dollar_s ($1); to_Call_op_(P_expr, "!m//", sndfst $1 :: from_PATTERN $3) (sp_pos_range $1 $3)}
+| term PATTERN_MATCH PATTERN_SUBST {sp_n($2); sp_p($3); check_unneeded_var_dollar_not($1); to_Call_op_(P_expr, "s///", sndfst $1 :: from_PATTERN_SUBST $3) (sp_pos_range $1 $3)}
+| term PATTERN_MATCH_NOT PATTERN_SUBST {die_with_rawpos (sndsnd $2) "use =~ instead of !~ and negate the return value"}
| term PATTERN_MATCH scalar { (P_expr, Too_complex), sp_pos_range $1 $3}
| term PATTERN_MATCH_NOT scalar { (P_expr, Too_complex), sp_pos_range $1 $3}
@@ -232,28 +233,28 @@ term:
| term PATTERN_MATCH_NOT STRING {die_with_rawpos (sndsnd $3) "use a regexp, not a string"}
-| term QUESTION_MARK term COLON term {sp_p($2); sp_p($3); sp_p($4); sp_p($5); (P_ternary, Call_op("?:", [ prio_lo P_ternary $1 ; prio_lo_after P_ternary $3; prio_lo_after P_ternary $5])), sp_pos_range $1 $5}
-| term QUESTION_MARK term COLON BRACKET expr BRACKET_END {sp_p($2); sp_p($3); sp_p($4); sp_p($5); sp_p($6); sp_p($7); (P_ternary, Call_op("?:", [ prio_lo P_ternary $1 ; prio_lo_after P_ternary $3; sndfst $6])), sp_pos_range $1 $7}
-| term QUESTION_MARK BRACKET expr BRACKET_END COLON term {sp_p($2); sp_p($3); sp_p($4); sp_p($5); sp_p($6); sp_p($7); (P_ternary, Call_op("?:", [ prio_lo P_ternary $1 ; sndfst $4; prio_lo_after P_ternary $7])), sp_pos_range $1 $7}
-| term QUESTION_MARK BRACKET expr BRACKET_END COLON BRACKET expr BRACKET_END {sp_p($2); sp_p($3); sp_p($4); sp_p($5); sp_p($6); sp_p($7); sp_p($8); sp_p($9); (P_ternary, Call_op("?:", [ prio_lo P_ternary $1 ; sndfst $4; sndfst $8])), sp_pos_range $1 $9}
+| term QUESTION_MARK term COLON term {sp_p($2); sp_p($3); sp_p($4); sp_p($5); to_Call_op_(P_ternary, "?:", [ prio_lo P_ternary $1 ; prio_lo_after P_ternary $3; prio_lo_after P_ternary $5]) (sp_pos_range $1 $5)}
+| term QUESTION_MARK term COLON BRACKET expr BRACKET_END {sp_p($2); sp_p($3); sp_p($4); sp_p($5); sp_p($6); sp_p($7); to_Call_op_(P_ternary, "?:", [ prio_lo P_ternary $1 ; prio_lo_after P_ternary $3; sndfst $6]) (sp_pos_range $1 $7)}
+| term QUESTION_MARK BRACKET expr BRACKET_END COLON term {sp_p($2); sp_p($3); sp_p($4); sp_p($5); sp_p($6); sp_p($7); to_Call_op_(P_ternary, "?:", [ prio_lo P_ternary $1 ; sndfst $4; prio_lo_after P_ternary $7]) (sp_pos_range $1 $7)}
+| term QUESTION_MARK BRACKET expr BRACKET_END COLON BRACKET expr BRACKET_END {sp_p($2); sp_p($3); sp_p($4); sp_p($5); sp_p($6); sp_p($7); sp_p($8); sp_p($9); to_Call_op_(P_ternary, "?:", [ prio_lo P_ternary $1 ; sndfst $4; sndfst $8]) (sp_pos_range $1 $9)}
/* Unary operators and terms */
-| PLUS term %prec UNARY_MINUS {if fst $1 <> "-" then die_rule "syntax error"; sp_0($2); (P_tight, Call_op("- unary", [sndfst $2])), sp_pos_range $1 $2}
-| TIGHT_NOT term {(P_tight, Call_op("not", [sndfst $2])), sp_pos_range $1 $2}
-| BIT_NEG term {(P_expr, Call_op("~", [sndfst $2])), sp_pos_range $1 $2}
-| INCR term {sp_0($2); (P_tight, Call_op("++", [sndfst $2])), sp_pos_range $1 $2}
-| DECR term {sp_0($2); (P_tight, Call_op("--", [sndfst $2])), sp_pos_range $1 $2}
-| term INCR {sp_0($2); (P_tight, Call_op("++ post", [sndfst $1])), sp_pos_range $1 $2}
-| term DECR {sp_0($2); (P_tight, Call_op("-- post", [sndfst $1])), sp_pos_range $1 $2}
-| NOT argexpr {(P_and, Call_op("not", sndfst $2)), sp_pos_range $1 $2}
+| PLUS term %prec UNARY_MINUS {if fst $1 <> "-" then die_rule "syntax error"; sp_0($2); to_Call_op_(P_tight, "- unary", [sndfst $2]) (sp_pos_range $1 $2)}
+| TIGHT_NOT term {to_Call_op_(P_tight, "not", [sndfst $2]) (sp_pos_range $1 $2)}
+| BIT_NEG term {to_Call_op_(P_expr, "~", [sndfst $2]) (sp_pos_range $1 $2)}
+| INCR term {sp_0($2); to_Call_op_(P_tight, "++", [sndfst $2]) (sp_pos_range $1 $2)}
+| DECR term {sp_0($2); to_Call_op_(P_tight, "--", [sndfst $2]) (sp_pos_range $1 $2)}
+| term INCR {sp_0($2); to_Call_op_(P_tight, "++ post", [sndfst $1]) (sp_pos_range $1 $2)}
+| term DECR {sp_0($2); to_Call_op_(P_tight, "-- post", [sndfst $1]) (sp_pos_range $1 $2)}
+| NOT argexpr {to_Call_op_(P_and, "not", sndfst $2) (sp_pos_range $1 $2)}
| ONE_SCALAR_PARA RAW_STRING {call_one_scalar_para $1 [to_Raw_string $2], sp_pos_range $1 $2}
-| ONE_SCALAR_PARA STRING {call_one_scalar_para $1 [to_String $2], sp_pos_range $1 $2}
+| ONE_SCALAR_PARA STRING {call_one_scalar_para $1 [to_String true $2], sp_pos_range $1 $2}
| ONE_SCALAR_PARA variable {call_one_scalar_para $1 [fst $2], sp_pos_range $1 $2}
| ONE_SCALAR_PARA restricted_subscripted {call_one_scalar_para $1 [fst $2], sp_pos_range $1 $2}
| ONE_SCALAR_PARA parenthesized {call_one_scalar_para $1 (sndfst $2), sp_pos_range $1 $2}
-| ONE_SCALAR_PARA word_paren parenthesized {call_one_scalar_para $1 [Call(Deref(I_func, fst $2), sndfst $3)], sp_pos_range $1 $3}
+| ONE_SCALAR_PARA word_paren parenthesized {call_one_scalar_para $1 [call(Deref(I_func, fst $2), sndfst $3)], sp_pos_range $1 $3}
/* Constructors for anonymous data */
@@ -273,40 +274,40 @@ term:
| LOCAL term %prec UNIOP {sp_n($2); (P_expr, to_Local $2), sp_pos_range $1 $2}
| parenthesized {(fstfst $1, List(sndfst $1)), snd $1} /* (1, 2) */
-| parenthesized arrayref {sp_0($2); (P_tok, Deref_with(I_array, List(sndfst $1), List(fst $2))), sp_pos_range $1 $2} /* list slice */
+| parenthesized arrayref {sp_0($2); (P_tok, to_Deref_with(I_array, (if is_only_one_in_List(fst $2) then I_scalar else I_array), List(sndfst $1), List(fst $2))), sp_pos_range $1 $2} /* list indexing or slicing */
| variable {(P_tok, fst $1), snd $1}
| subscripted {(P_tok, fst $1), snd $1}
-| array arrayref {(P_expr, Deref_with(I_array, from_array $1, List(fst $2))), sp_pos_range $1 $2} /* array slice: @array[vals] */
-| array BRACKET expr BRACKET_END {sp_0($2); sp_0($3); sp_0($4); (P_expr, Deref_with(I_hash, from_array $1, sndfst $3)), sp_pos_range $1 $4} /* hash slice: @hash{@keys} */
+| array arrayref {(P_expr, to_Deref_with(I_array, I_array, from_array $1, List(fst $2))), sp_pos_range $1 $2} /* array slice: @array[vals] */
+| array BRACKET expr BRACKET_END {sp_0($2); sp_0($3); sp_0($4); (P_expr, to_Deref_with(I_hash, I_array, from_array $1, sndfst $3)), sp_pos_range $1 $4} /* hash slice: @hash{@keys} */
/* function_calls */
| func parenthesized {sp_0($2); (P_tok, call_func true (fst $1, sndfst $2)), sp_pos_range $1 $2} /* &foo(@args) */
| word argexpr {check_parenthesized_first_argexpr (string_of_Ident (fst $1)) $2; (P_call_no_paren, call(Deref(I_func, fst $1), sndfst $2)), sp_pos_range $1 $2} /* foo $a, $b */
-| word_paren parenthesized {(P_tok, call(Deref(I_func, fst $1), sndfst $2)), sp_pos_range $1 $2} /* foo(@args) */
+| word_paren parenthesized {sp_0($2); (P_tok, call(Deref(I_func, fst $1), sndfst $2)), sp_pos_range $1 $2} /* foo(@args) */
| word BRACKET lines BRACKET_END listexpr %prec LSTOP {sp_n($2); check_block_sub $3 $4; ((if sndfst $5 = [] then P_tok else P_call_no_paren), call(Deref(I_func, fst $1), anonymous_sub(fst $3) :: sndfst $5)), sp_pos_range $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); ((if sndfst $7 = [] then P_tok else P_call_no_paren), call(Deref(I_func, fst $1), anonymous_sub [ Ref(I_hash, sndfst $4) ] :: sndfst $7)), sp_pos_range $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); ((if sndfst $8 = [] then P_tok else P_call_no_paren), call(Deref(I_func, fst $1), anonymous_sub [ Ref(I_hash, sndfst $4); Semi_colon ] :: sndfst $8)), sp_pos_range $1 $8} /* map { { foo }; } @bar */
-| term ARROW word_or_scalar parenthesized {sp_0($2); sp_0($3); sp_0($4); (P_tok, to_Method_callP(sndfst $1, fst $3, sndfst $4)), sp_pos_range $1 $4} /* $foo->bar(list) */
-| term ARROW word_or_scalar {sp_0($2); sp_0($3); (P_tok, to_Method_callP(sndfst $1, fst $3, [])), sp_pos_range $1 $3} /* $foo->bar */
-| term ARROW MULT parenthesized {check_MULT_is_x $3; sp_0($2); sp_0($3); sp_0($4); (P_tok, to_Method_callP(sndfst $1, Ident(None, "x", get_pos $3), sndfst $4)), sp_pos_range $1 $4} /* $foo->bar(list) */
-| term ARROW MULT {check_MULT_is_x $3; sp_0($2); sp_0($3); (P_tok, to_Method_callP(sndfst $1, Ident(None, "x", get_pos $3), [])), sp_pos_range $1 $3} /* $foo->bar */
+| term ARROW word_or_scalar parenthesized {sp_0($2); sp_0($3); sp_0($4); (P_tok, to_Method_call(sndfst $1, fst $3, sndfst $4)), sp_pos_range $1 $4} /* $foo->bar(list) */
+| term ARROW word_or_scalar {sp_0($2); sp_0($3); (P_tok, to_Method_call(sndfst $1, fst $3, [])), sp_pos_range $1 $3} /* $foo->bar */
+| term ARROW MULT parenthesized {check_MULT_is_x $3; sp_0($2); sp_0($3); sp_0($4); (P_tok, to_Method_call(sndfst $1, Ident(None, "x", get_pos $3), sndfst $4)), sp_pos_range $1 $4} /* $foo->bar(list) */
+| term ARROW MULT {check_MULT_is_x $3; sp_0($2); sp_0($3); (P_tok, to_Method_call(sndfst $1, Ident(None, "x", get_pos $3), [])), sp_pos_range $1 $3} /* $foo->bar */
| NEW word { sp_n($2); (P_call_no_paren, to_Method_call(fst $2, Ident(None, "new", get_pos $1), [])), sp_pos_range $1 $2} /* new Class */
| NEW word_paren parenthesized { sp_n($2); sp_0($3); (P_call_no_paren, to_Method_call(fst $2, Ident(None, "new", get_pos $1), sndfst $3)), sp_pos_range $1 $3} /* new Class(...) */
| NEW word terminal { die_rule "you must parenthesize parameters: \"new Class(...)\" instead of \"new Class ...\"" }
| NEW word variable { die_rule "you must parenthesize parameters: \"new Class(...)\" instead of \"new Class ...\"" }
-| PRINT { (P_call_no_paren, Call_op(fst $1, var_STDOUT :: [ var_dollar_ ])), snd $1}
-| PRINT argexpr {check_parenthesized_first_argexpr (fst $1) $2; (P_call_no_paren, Call_op(fst $1, var_STDOUT :: sndfst $2)), sp_pos_range $1 $2}
-| PRINT_TO_SCALAR { (P_call_no_paren, Call_op(fstfst $1, var_STDOUT :: [ Deref(I_scalar, Ident(None, sndfst $1, get_pos $1)) ])), snd $1}
-| PRINT_TO_SCALAR argexpr { (P_call_no_paren, Call_op(fstfst $1, Deref(I_scalar, Ident(None, sndfst $1, get_pos $1)) :: sndfst $2)), sp_pos_range $1 $2}
-| PRINT_TO_STAR { (P_call_no_paren, Call_op(fstfst $1, Deref(I_star, Ident(None, sndfst $1, get_pos $1)) :: [ var_dollar_ ])), snd $1}
-| PRINT_TO_STAR argexpr { (P_call_no_paren, Call_op(fstfst $1, Deref(I_star, Ident(None, sndfst $1, get_pos $1)) :: sndfst $2)), sp_pos_range $1 $2}
+| PRINT { to_Call_op_(P_call_no_paren, fst $1, var_STDOUT :: [ var_dollar_ ]) (snd $1)}
+| PRINT argexpr {check_parenthesized_first_argexpr (fst $1) $2; to_Call_op_(P_call_no_paren, fst $1, var_STDOUT :: sndfst $2) (sp_pos_range $1 $2)}
+| PRINT_TO_SCALAR { to_Call_op_(P_call_no_paren, fstfst $1, var_STDOUT :: [ Deref(I_scalar, Ident(None, sndfst $1, get_pos $1)) ]) (snd $1)}
+| PRINT_TO_SCALAR argexpr { to_Call_op_(P_call_no_paren, fstfst $1, Deref(I_scalar, Ident(None, sndfst $1, get_pos $1)) :: sndfst $2) (sp_pos_range $1 $2)}
+| PRINT_TO_STAR { to_Call_op_(P_call_no_paren, fstfst $1, Deref(I_star, Ident(None, sndfst $1, get_pos $1)) :: [ var_dollar_ ]) (snd $1)}
+| PRINT_TO_STAR argexpr { to_Call_op_(P_call_no_paren, fstfst $1, Deref(I_star, Ident(None, sndfst $1, get_pos $1)) :: sndfst $2) (sp_pos_range $1 $2)}
| hash PKG_SCOPE {sp_0($2); (P_tok, Too_complex), sp_pos_range $1 $2} /* %main:: */
@@ -315,38 +316,39 @@ term:
terminal:
| word {(P_tok, check_word_alone $1), snd $1}
| NUM {(P_tok, Num(fst $1, get_pos $1)), snd $1}
-| STRING {(P_tok, to_String $1), snd $1}
+| STRING {(P_tok, to_String true $1), snd $1}
| RAW_STRING {(P_tok, to_Raw_string $1), snd $1}
| REVISION {(P_tok, to_Raw_string $1), snd $1}
-| COMMAND_STRING {(P_expr, Call_op("``", [to_String $1])), snd $1}
-| QUOTEWORDS {(P_tok, Call_op("qw", [to_Raw_string $1])), snd $1}
+| COMMAND_STRING {to_Call_op_(P_expr, "``", [to_String false $1]) (snd $1)}
+| QUOTEWORDS {to_Call_op_(P_tok, "qw", [to_Raw_string $1]) (snd $1)}
| HERE_DOC {(P_tok, String([], raw_pos2pos (sndfst $1))), snd $1}
| RAW_HERE_DOC {(P_tok, Raw_string(fstfst $1, raw_pos2pos (sndfst $1))), snd $1}
-| PATTERN {(P_expr, Call_op("m//", var_dollar_ :: from_PATTERN $1)), snd $1}
-| PATTERN_SUBST {(P_expr, Call_op("s///", var_dollar_ :: from_PATTERN_SUBST $1)), snd $1}
+| PATTERN {to_Call_op_(P_expr, "m//", var_dollar_ :: from_PATTERN $1) (snd $1)}
+| PATTERN_SUBST {to_Call_op_(P_expr, "s///", var_dollar_ :: from_PATTERN_SUBST $1) (snd $1)}
| diamond {(P_expr, fst $1), snd $1}
diamond:
-| LT GT {sp_0($2); Call_op("<>", []), sp_pos_range $1 $2}
-| LT term GT {sp_0($2); sp_0($3); Call_op("<>", [sndfst $2]), sp_pos_range $1 $3}
+| LT GT {sp_0($2); to_Call_op("<>", []) (sp_pos_range $1 $2)}
+| LT term GT {sp_0($2); sp_0($3); to_Call_op("<>", [sndfst $2]) (sp_pos_range $1 $3)}
subscripted: /* Some kind of subscripted expression */
| variable PKG_SCOPE bracket_subscript {sp_0($2); sp_0($3); Too_complex, sp_pos_range $1 $3} /* $foo::{something} */
-| scalar bracket_subscript {sp_0($2); Deref_with(I_hash , from_scalar $1, fst $2), sp_pos_range $1 $2} /* $foo{bar} */
-| scalar arrayref {sp_0($2); Deref_with(I_array, from_scalar $1, only_one $2), sp_pos_range $1 $2} /* $array[$element] */
-| term ARROW bracket_subscript {sp_0($2); sp_0($3); Deref_with(I_hash , sndfst $1, fst $3), sp_pos_range $1 $3} /* somehref->{bar} */
-| term ARROW arrayref {sp_0($2); sp_0($3); Deref_with(I_array, sndfst $1, only_one $3), sp_pos_range $1 $3} /* somearef->[$element] */
-| term ARROW parenthesized {sp_0($2); sp_0($3); Deref_with(I_func , sndfst $1, List(sndfst $3)), sp_pos_range $1 $3} /* $subref->(@args) */
-| subscripted bracket_subscript {sp_0($2); Deref_with(I_hash , fst $1, fst $2), sp_pos_range $1 $2} /* $foo->[bar]{baz} */
-| subscripted arrayref {sp_0($2); Deref_with(I_array, fst $1, only_one $2), sp_pos_range $1 $2} /* $foo->[$bar][$baz] */
-| subscripted parenthesized {sp_0($2); Deref_with(I_func , fst $1, List(sndfst $2)), sp_pos_range $1 $2} /* $foo->{bar}(@args) */
+| scalar bracket_subscript {sp_0($2); to_Deref_with(I_hash , I_scalar, from_scalar $1, fst $2), sp_pos_range $1 $2} /* $foo{bar} */
+| scalar arrayref {sp_0($2); to_Deref_with(I_array, I_scalar, from_scalar $1, only_one $2), sp_pos_range $1 $2} /* $array[$element] */
+| term ARROW bracket_subscript {sp_0($2); sp_0($3); check_arrow_needed $1 $2; to_Deref_with(I_hash , I_scalar, sndfst $1, fst $3), sp_pos_range $1 $3} /* somehref->{bar} */
+| term ARROW arrayref {sp_0($2); sp_0($3); check_arrow_needed $1 $2; to_Deref_with(I_array, I_scalar, sndfst $1, only_one $3), sp_pos_range $1 $3} /* somearef->[$element] */
+| term ARROW parenthesized {sp_0($2); sp_0($3); to_Deref_with(I_func , I_scalar, sndfst $1, List(sndfst $3)), sp_pos_range $1 $3} /* $subref->(@args) */
+| subscripted bracket_subscript {sp_0($2); to_Deref_with(I_hash , I_scalar, fst $1, fst $2), sp_pos_range $1 $2} /* $foo->[bar]{baz} */
+| subscripted arrayref {sp_0($2); to_Deref_with(I_array, I_scalar, fst $1, only_one $2), sp_pos_range $1 $2} /* $foo->[$bar][$baz] */
+| subscripted parenthesized {sp_0($2); to_Deref_with(I_func , I_scalar, fst $1, List(sndfst $2)), sp_pos_range $1 $2} /* $foo->{bar}(@args) */
restricted_subscripted: /* Some kind of subscripted expression */
-| scalar bracket_subscript {sp_0($2); Deref_with(I_hash , from_scalar $1, fst $2), sp_pos_range $1 $2} /* $foo{bar} */
-| scalar arrayref {sp_0($2); Deref_with(I_array, from_scalar $1, only_one $2), sp_pos_range $1 $2} /* $array[$element] */
-| restricted_subscripted bracket_subscript {sp_0($2); Deref_with(I_hash , fst $1, fst $2), sp_pos_range $1 $2} /* $foo->[bar]{baz} */
-| restricted_subscripted arrayref {sp_0($2); Deref_with(I_array, fst $1, only_one $2), sp_pos_range $1 $2} /* $foo->[$bar][$baz] */
-| restricted_subscripted parenthesized {sp_0($2); Deref_with(I_func , fst $1, List(sndfst $2)), sp_pos_range $1 $2} /* $foo->{bar}(@args) */
+| variable PKG_SCOPE bracket_subscript {sp_0($2); sp_0($3); Too_complex, sp_pos_range $1 $3} /* $foo::{something} */
+| scalar bracket_subscript {sp_0($2); to_Deref_with(I_hash , I_scalar, from_scalar $1, fst $2), sp_pos_range $1 $2} /* $foo{bar} */
+| scalar arrayref {sp_0($2); to_Deref_with(I_array, I_scalar, from_scalar $1, only_one $2), sp_pos_range $1 $2} /* $array[$element] */
+| restricted_subscripted bracket_subscript {sp_0($2); to_Deref_with(I_hash , I_scalar, fst $1, fst $2), sp_pos_range $1 $2} /* $foo->[bar]{baz} */
+| restricted_subscripted arrayref {sp_0($2); to_Deref_with(I_array, I_scalar, fst $1, only_one $2), sp_pos_range $1 $2} /* $foo->[$bar][$baz] */
+| restricted_subscripted parenthesized {sp_0($2); to_Deref_with(I_func , I_scalar, fst $1, List(sndfst $2)), sp_pos_range $1 $2} /* $foo->{bar}(@args) */
arrayref:
| arrayref_start ARRAYREF_END {sp_0($2); fst $1, sp_pos_range $1 $2}
@@ -386,7 +388,7 @@ termdo: /* Things called with "do" */
| DO BRACKET lines BRACKET_END %prec PREC_HIGH {sp_n($2); check_block_sub $3 $4; Block(fst $3), sp_pos_range $1 $4} /* do { code */
bracket_subscript:
-| BRACKET expr BRACKET_END {sp_0($1); sp_same $2 $3; only_one_in_List $2, sp_pos_range $1 $3}
+| BRACKET expr BRACKET_END {sp_0($1); sp_same $2 $3; check_hash_subscript $2; only_one_in_List $2, sp_pos_range $1 $3}
| COMPACT_HASH_SUBSCRIPT {sp_0($1); to_Raw_string $1, snd $1}
variable:
diff --git a/perl_checker.src/parser_helper.ml b/perl_checker.src/parser_helper.ml
index 0fe96b7..62a85f0 100644
--- a/perl_checker.src/parser_helper.ml
+++ b/perl_checker.src/parser_helper.ml
@@ -11,7 +11,12 @@ let get_pos (_, (_, pos)) = raw_pos2pos pos
let var_dollar_ = Deref(I_scalar, Ident(None, "_", raw_pos2pos bpos))
let var_STDOUT = Deref(I_star, Ident(None, "STDOUT", raw_pos2pos bpos))
+let is_var_dollar_ = function
+ | Deref(I_scalar, Ident(None, "_", _)) -> true
+ | _ -> false
+
let is_parenthesized = function
+ | List[]
| List[List[_]] -> true
| _ -> false
@@ -26,8 +31,8 @@ let rec un_parenthesize_full = function
let not_complex e =
if is_parenthesized e then true else
let rec not_complex_ op = function
- | Call_op("?:", _) -> false
- | Call_op(op', l) -> op <> op' && List.for_all (not_complex_ op') l
+ | Call_op("?:", _, _) -> false
+ | Call_op(op', l, _) -> op <> op' && List.for_all (not_complex_ op') l
| e -> not (is_parenthesized e)
in not_complex_ "" (un_parenthesize_full e)
@@ -39,6 +44,44 @@ let string_of_Ident = function
| Ident(None, s, _) -> s
| Ident(Some fq, s, _) -> fq ^ "::" ^ s
| _ -> internal_error "string_of_Ident"
+let context2s = function
+ | I_scalar -> "$"
+ | I_hash -> "%"
+ | I_array -> "@"
+ | I_func -> "&"
+ | I_raw -> ""
+ | I_star -> "*"
+let variable2s(context, ident) = context2s context ^ ident
+
+let non_scalar_context context = context = I_hash || context = I_array
+
+let rec is_same_fromparser a b =
+ match a, b with
+ | Undef, Undef -> true
+ | Ident(fq1, s1, _), Ident(fq2, s2, _) -> fq1 = fq2 && s1 = s2
+ | Num(s1, _), Num(s2, _)
+ | Raw_string(s1, _), Raw_string(s2, _) -> s1 = s2
+
+ | String(l1, _), String(l2, _) ->
+ List.for_all2 (fun (s1, e1) (s2, e2) -> s1 = s2 && is_same_fromparser e1 e2) l1 l2
+
+ | Ref(c1, e1), Ref(c2, e2)
+ | Deref(c1, e1), Deref(c2, e2) -> c1 = c2 && is_same_fromparser e1 e2
+
+ | Deref_with(c1, c_1, e1, e_1), Deref_with(c2, c_2, e2, e_2) -> c1 = c2 && c_1 = c_2 && is_same_fromparser e1 e2 && is_same_fromparser e_1 e_2
+
+ | Diamond(None), Diamond(None) -> true
+ | Diamond(Some e1), Diamond(Some e2) -> is_same_fromparser e1 e2
+
+ | List(l1), List(l2) -> List.for_all2 is_same_fromparser l1 l2
+
+ | Call_op(op1, l1, _), Call_op(op2, l2, _) -> op1 = op2 && List.for_all2 is_same_fromparser l1 l2
+ | Call(e1, l1), Call(e2, l2) -> is_same_fromparser e1 e2 && List.for_all2 is_same_fromparser l1 l2
+
+ | Method_call(e1, m1, l1), Method_call(e2, m2, l2) ->
+ is_same_fromparser e1 e2 && is_same_fromparser m1 m2 && List.for_all2 is_same_fromparser l1 l2
+
+ | _ -> false
let from_scalar (e, _) =
match e with
@@ -204,21 +247,51 @@ let check_parenthesized_first_argexpr word ((_, e), (_, (start, _)) as ex) =
let want_space = word.[0] = '-' in
if word = "return" then () else
match e with
- | [ Call_op(_, (e' :: l)) ]
+ | [ Call_op(_, (e' :: l), _) ]
| e' :: l ->
if is_parenthesized e' then
- if want_space then
- if l = [] then sp_n(ex) else die_with_rawpos (start, start) "can't handle this nicely"
- else
- if l = [] then sp_0(ex) else die_with_rawpos (start, start) "you must not have a space here"
+ if l = [] then
+ (if want_space then sp_n else sp_0) ex
+ else die_with_rawpos (start, start) "can't handle this nicely"
+ else
+ sp_p(ex)
| _ ->
if word = "time" then die_rule "please use time() instead of time";
sp_p(ex)
-let check_foreach (s, (_, pos)) = if s = "for" then warn pos "write \"foreach\" instead of \"for\""
-let check_for (s, (_, pos)) = if s = "foreach" then warn pos "write \"for\" instead of \"foreach\""
+let check_hash_subscript ((_, e), (_, pos)) =
+ let can_be_raw_string = function
+ | "" | "x" | "y" -> false (* special case for {'y'} otherwise the emacs mode goes wild, special case for {'x'} to have the same as {'y'} (since they usually go together) *)
+ | s ->
+ char_is_alpha s.[0] && (String.length s = 1 || string_forall_with char_is_alphanumerical_ 1 s)
+ in
+ match e with
+ | List [String ([(s, List [])], _)] when can_be_raw_string s -> warn pos (sprintf "{\"%s\"} can be written {%s}" s s)
+ | List [Raw_string(s, _)] when can_be_raw_string s -> warn pos (sprintf "{'%s'} can be written {%s}" s s)
+ | _ -> ()
+
+let check_arrow_needed ((_, e), _) ter =
+ match e with
+ | Deref_with(I_array, I_scalar, List [List [Call _]], _) -> () (* "->" needed for (f())[0]->{XX} *)
+ | Deref_with _ -> warn (sndsnd ter) "the arrow \"->\" is unneeded"
+ | _ -> ()
+
+let check_unneeded_var_dollar_ ((_, e), (_, pos)) = if is_var_dollar_ e then warn pos "\"$_ =~ /regexp/\" can be written \"/regexp/\""
+let check_unneeded_var_dollar_s ((_, e), (_, pos)) = if is_var_dollar_ e then warn pos "\"$_ =~ s/regexp/.../\" can be written \"s/regexp/.../\""
+let check_unneeded_var_dollar_not ((_, e), (_, pos)) = if is_var_dollar_ e then warn pos "\"$_ !~ /regexp/\" can be written \"!/regexp/\""
+
let check_MULT_is_x (s, _) = if s <> "x" then die_rule "syntax error"
let check_my (s, _) = if s <> "my" then die_rule "syntax error"
+let check_foreach (s, (_, pos)) = if s = "for" then warn pos "write \"foreach\" instead of \"for\""
+let check_for (s, (_, pos)) = if s = "foreach" then warn pos "write \"for\" instead of \"foreach\""
+let check_for_foreach (s, (_, pos)) ((_, expr), _) =
+ match expr with
+ | List [ Deref(I_scalar, _) ] ->
+ if s = "foreach" then warn pos "you are using the special fpons trick to locally set $_ with a value, for this please use \"for\" instead of \"foreach\""
+ | List [ Deref_with(context, I_scalar, _, _) ] when context <> I_func ->
+ if s = "foreach" then warn pos "you are using the special fpons trick to locally set $_ with a value, for this please use \"for\" instead of \"foreach\""
+ | _ ->
+ if s = "for" then warn pos "write \"foreach\" instead of \"for\""
let check_block_sub (l, (_, (_, end_)) as ter_lines) (_, (space, _) as ter_BRACKET_END) =
if l = [] then
@@ -254,6 +327,15 @@ let only_one_in_List ((_, e), both) =
| List l -> only_one(l, both)
| _ -> e
+let rec is_only_one_in_List = function
+ | [List l] -> is_only_one_in_List l
+ | [_] -> true
+ | _ -> false
+
+let is_not_a_scalar = function
+ | Deref_with(_, context, _, _)
+ | Deref(context, _) -> non_scalar_context context
+ | _ -> false
let maybe_to_Raw_string = function
| Ident(None, s, pos) -> Raw_string(s, pos)
@@ -267,8 +349,12 @@ 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_callP(object_, method_, para) = Method_callP(maybe_to_Raw_string object_, maybe_to_Raw_string method_, para)
-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) = 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)
+
+
let to_Local ((_, e), (_, pos)) =
let l =
match e with
@@ -281,14 +367,14 @@ let to_Local ((_, e), (_, pos)) =
| Deref(I_scalar, Ident _)
| Deref(I_array, Ident _)
| Deref(I_star, Ident _)
- | Deref_with(I_hash, Ident _, _)
- | Deref_with(I_hash, Deref(I_scalar, _), _)
- | Deref_with(I_hash, Deref_with(I_hash, Ident _, _), _)
- | Deref_with(I_hash, Deref_with(I_hash, Deref(I_scalar, Ident _), _), _) ->
+ | Deref_with(I_hash, I_scalar, Ident _, _)
+ | Deref_with(I_hash, I_scalar, Deref(I_scalar, _), _)
+ | Deref_with(I_hash, I_scalar, Deref_with(I_hash, I_scalar, Ident _, _), _)
+ | Deref_with(I_hash, I_scalar, Deref_with(I_hash, I_scalar, Deref(I_scalar, Ident _), _), _) ->
None
| _ -> die_with_rawpos pos "bad argument to \"local\""
) l in
- if local_vars = [] then Call_op("local", local_exprs)
+ if local_vars = [] then Call_op("local", local_exprs, raw_pos2pos pos)
else if local_exprs = [] then My_our("local", local_vars, raw_pos2pos pos)
else die_with_rawpos pos "bad argument to \"local\""
@@ -298,41 +384,43 @@ let op_p prio s e = sp_p e ; op prio s e
let sub_declaration (name, proto) body = Sub_declaration(name, proto, Block body)
let anonymous_sub body = Anonymous_sub (Block body)
-let call_op((prio, (prev_ter, op)), (_, (_, pos) as ter), para) =
+let cook_call_op(op, para, pos) =
+ let call = Call_op(op, para, raw_pos2pos pos) in
+ match op, para with
+ | "=", [My_our _; Ident(None, "undef", _)] ->
+ warn pos "no need to initialize variable, it's done by default" ;
+ call
+ | "=", [My_our _; List[]] ->
+ if Info.is_on_same_line_current pos then warn pos "no need to initialize variables, it's done by default" ;
+ call
+
+ | "=", [ Deref(I_star, String ([(sf1, List [])], _)); _ ] ->
+ warn_rule (sprintf "write *{'%s'} instead of *{\"%s\"}" sf1 sf1) ;
+ call
+
+ | "=", [ 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) ]
+ | "=", [ 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) ]
+
+ | "=", [ Deref(I_star, (Ident _ as f1)); Ref(I_scalar, Deref(I_func, (Ident _ as f2))) ] ->
+ sub_declaration (f1, "") [ 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) ]
+
+ | _ ->
+ call
+
+let call_op_((prio, (prev_ter, op)), ter, para) (sp, pos) =
sp_same prev_ter ter ;
+ (prio, cook_call_op(op, para, pos)), (sp, pos)
- let call = Call_op(op, para) in
- let call =
- match op, para with
- | "=", [List [My_our _]; Ident(None, "undef", _)] ->
- warn pos "no need to initialize variable, it's done by default" ;
- call
- | "=", [List [My_our _]; List[]] ->
- if Info.is_on_same_line_current pos then warn pos "no need to initialize variables, it's done by default" ;
- call
-
- | "=", [ Deref(I_star, String ([(sf1, List [])], _)); _ ] ->
- warn_rule (sprintf "write *{'%s'} instead of *{\"%s\"}" sf1 sf1) ;
- call
-
- | "=", [ 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) ]
- | "=", [ 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) ]
-
- | "=", [ Deref(I_star, (Ident _ as f1)); Ref(I_scalar, Deref(I_func, (Ident _ as f2))) ] ->
- sub_declaration (f1, "") [ 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) ]
-
- | _ ->
- call
- in
- prio, call
+let to_Call_op(op, para) (sp, pos) = Call_op(op, para, raw_pos2pos pos), (sp, pos)
+let to_Call_op_(prio, op, para) (sp, pos) = (prio, Call_op(op, para, raw_pos2pos pos)), (sp, pos)
let followed_by_comma ((_,e), _) (true_comma, _) =
if true_comma then e else
@@ -344,12 +432,6 @@ let call_func is_a_func (e, para) =
match e with
| Deref(I_func, Ident(None, f, _)) ->
let para' = match f with
- | "require" ->
- (match para with
- | [ Ident(_, _, pos) as s ] -> Some [ Raw_string(string_of_Ident s, pos) ]
- | [ String _ ]
- | [ Raw_string _ ] -> None
- | _ -> die_rule "use either \"require PACKAGE\" or \"require 'PACKAGE.pm'\"")
| "no" ->
(match para with
| [ Ident(_, _, pos) as s ] -> Some [ Raw_string(string_of_Ident s, pos) ]
@@ -357,7 +439,8 @@ let call_func is_a_func (e, para) =
| _ -> die_rule "use \"no PACKAGE <para>\"")
| "N" | "N_" ->
(match para with
- | [List(String _ :: _)] -> None
+ | [ List(String([ _s, List [] ], _) :: _) ] -> None
+ | [ List(String _ :: _) ] -> die_rule "don't use interpolated translated string, use %s or %d instead"
| _ -> die_rule (sprintf "%s() must be used with a string" f))
| "goto" ->
@@ -370,6 +453,11 @@ let call_func is_a_func (e, para) =
| [ Ident(None, s, pos) ] -> Some [ Raw_string(s, pos) ]
| _ -> die_rule (sprintf "%s must be used with a raw string" f))
+ | "length" ->
+ if para = [] then warn_rule "length() with no parameter !?" else
+ if is_not_a_scalar (List.hd para) then warn_rule "never use \"length @l\", it returns the length of the string int(@l)" ;
+ None
+
| _ -> None
in Call(e, some_or para' para)
| _ -> Call(e, para)
@@ -383,10 +471,34 @@ let call_one_scalar_para (e, (_, pos)) para =
| "defined" -> P_expr
| _ -> P_add
in
- pri, Call(Deref(I_func, Ident(None, e, raw_pos2pos pos)), para)
+ pri, call(Deref(I_func, Ident(None, e, raw_pos2pos pos)), para)
+
+
+let call_op_if_infix left right (sp, pos) =
+ (match left, right with
+ | List [Call_op("=", [Deref(context, _); _], _)], _ when non_scalar_context context -> ()
+ | List [Call_op("=", [v; _], _)],
+ List [Call_op("not", [v'], _)] when is_same_fromparser v v' ->
+ warn_rule "\"$foo = ... if !$foo\" can be written \"$foo ||= ...\""
+ | _ -> ());
+ Call_op("if infix", [ left ; right], raw_pos2pos pos), (sp, pos)
+
+let call_op_unless_infix left right (sp, pos) =
+ (match left, right with
+ | List [Call_op("=", [Deref(context, _); _], _)], _ when non_scalar_context context -> ()
+ | List [Call_op("=", [v; _], _)], List [v'] when is_same_fromparser v v' ->
+ warn_rule "\"$foo = ... unless $foo\" can be written \"$foo ||= ...\""
+ | _ -> ());
+ (match right with
+ | List [Call_op(op, _, _)] ->
+ (match op with
+ | "&&" | "||" | "not" | "ne" | "?:" -> warn_rule "don't use \"unless\" when the condition is complex, use \"if\" instead"
+ | _ -> ());
+ | _ -> ());
+ Call_op("unless infix", [ left ; right], raw_pos2pos pos), (sp, pos)
-let (current_lexbuf : Lexing.lexbuf option ref) = ref None
+let (current_lexbuf : Lexing.lexbuf option ref) = ref None
let rec list2tokens l =
let rl = ref l in
@@ -404,9 +516,25 @@ let parse_tokens parse tokens lexbuf_opt =
if tokens = [] then [] else
parse (list2tokens tokens) (some !current_lexbuf)
-let parse_interpolated parse l = List.map (fun (s, tokens) -> s, to_List(parse_tokens parse tokens None)) l
-
-let to_String parse (l, (_, pos)) = String(parse_interpolated parse l, raw_pos2pos pos)
+let parse_interpolated parse l =
+ let l' = List.map (fun (s, tokens) -> s, to_List(parse_tokens parse tokens None)) l in
+ match split_last l' with
+ | pl, ("", List []) -> pl
+ | _ -> l'
+
+let to_String parse strict (l, (_, pos)) =
+ let l' = parse_interpolated parse l in
+ (match l' with
+ | [ "", List [Deref(I_scalar, Ident(None, ident, _))]] ->
+ if strict then warn pos (sprintf "%s is better written without the double quotes" (variable2s(I_scalar, ident)))
+ | [ "", List [Deref(I_hash, _)]] ->
+ warn pos "don't use a hash in string context"
+ | [ "", List [Deref(I_array, _)]] ->
+ ()
+ | [("", _)] ->
+ if strict then warn pos "double quotes are unneeded"
+ | _ -> ());
+ String(l', raw_pos2pos pos)
let from_PATTERN parse ((s, opts), (_, pos)) =
[ String(parse_interpolated parse s, raw_pos2pos pos) ;
diff --git a/perl_checker.src/parser_helper.mli b/perl_checker.src/parser_helper.mli
index 879d194..e617547 100644
--- a/perl_checker.src/parser_helper.mli
+++ b/perl_checker.src/parser_helper.mli
@@ -7,12 +7,17 @@ val sp_pos_range :
val get_pos : 'a * ('b * ('c * 'd)) -> string * 'c * 'd
val var_dollar_ : Types.fromparser
val var_STDOUT : Types.fromparser
+val is_var_dollar_ : Types.fromparser -> bool
val is_parenthesized : Types.fromparser -> bool
val un_parenthesize : Types.fromparser -> Types.fromparser
val un_parenthesize_full : Types.fromparser -> Types.fromparser
val not_complex : Types.fromparser -> bool
val not_simple : Types.fromparser -> bool
val string_of_Ident : Types.fromparser -> string
+val context2s : Types.context -> string
+val variable2s : Types.context * string -> string
+val non_scalar_context : Types.context -> bool
+val is_same_fromparser : Types.fromparser -> Types.fromparser -> bool
val from_scalar : Types.fromparser * 'a -> Types.fromparser
val from_array : Types.fromparser * 'a -> Types.fromparser
val msg_with_rawpos : int * int -> string -> string
@@ -51,10 +56,22 @@ val check_word_alone : Types.fromparser * 'a -> Types.fromparser
val check_parenthesized_first_argexpr :
string ->
('a * Types.fromparser list) * (Types.spaces * (int * 'b)) -> unit
-val check_foreach : string * ('a * (int * int)) -> unit
-val check_for : string * ('a * (int * int)) -> unit
+val check_hash_subscript :
+ ('a * Types.fromparser) * ('b * (int * int)) -> unit
+val check_arrow_needed :
+ ('a * Types.fromparser) * 'b -> 'c * ('d * (int * int)) -> unit
+val check_unneeded_var_dollar_ :
+ ('a * Types.fromparser) * ('b * (int * int)) -> unit
+val check_unneeded_var_dollar_s :
+ ('a * Types.fromparser) * ('b * (int * int)) -> unit
+val check_unneeded_var_dollar_not :
+ ('a * Types.fromparser) * ('b * (int * int)) -> unit
val check_MULT_is_x : string * 'a -> unit
val check_my : string * 'a -> unit
+val check_foreach : string * ('a * (int * int)) -> unit
+val check_for : string * ('a * (int * int)) -> unit
+val check_for_foreach :
+ string * ('a * (int * int)) -> ('b * Types.fromparser) * 'c -> unit
val check_block_sub :
Types.fromparser list * (Types.spaces * (int * int)) ->
'a * (Types.spaces * (int * 'b)) -> unit
@@ -65,18 +82,20 @@ val check_my_our_paren : ((bool * 'a) * 'b) * 'c -> unit
val only_one : Types.fromparser list * ('a * (int * int)) -> Types.fromparser
val only_one_in_List :
('a * Types.fromparser) * ('b * (int * int)) -> Types.fromparser
+val is_only_one_in_List : Types.fromparser list -> bool
+val is_not_a_scalar : Types.fromparser -> bool
val maybe_to_Raw_string : Types.fromparser -> Types.fromparser
val to_List : Types.fromparser list -> Types.fromparser
val deref_arraylen : Types.fromparser -> Types.fromparser
val to_Ident :
(string option * string) * ('a * (int * int)) -> Types.fromparser
val to_Raw_string : string * ('a * (int * int)) -> Types.fromparser
-val to_Method_callP :
- Types.fromparser * Types.fromparser * Types.fromparser list ->
- Types.fromparser
val to_Method_call :
Types.fromparser * Types.fromparser * Types.fromparser list ->
Types.fromparser
+val to_Deref_with :
+ Types.context * Types.context * Types.fromparser * Types.fromparser ->
+ Types.fromparser
val to_Local :
('a * Types.fromparser) * ('b * (int * int)) -> Types.fromparser
val op : 'a -> 'b -> 'c * 'd -> 'a * ((unit * 'd) * 'b)
@@ -85,13 +104,21 @@ val op_p :
'b ->
'c * (Types.spaces * (int * 'd)) ->
'a * ((unit * (Types.spaces * (int * 'd))) * 'b)
-val call_op :
- ('a * (('b * (Types.spaces * (int * 'c))) * string)) *
- ('d * (Types.spaces * (int * int))) * Types.fromparser list ->
- 'a * Types.fromparser
val sub_declaration :
Types.fromparser * string -> Types.fromparser list -> Types.fromparser
val anonymous_sub : Types.fromparser list -> Types.fromparser
+val cook_call_op :
+ string * Types.fromparser list * (int * int) -> Types.fromparser
+val call_op_ :
+ ('a * (('b * (Types.spaces * (int * 'c))) * string)) *
+ ('d * (Types.spaces * (int * 'e))) * Types.fromparser list ->
+ 'f * (int * int) -> ('a * Types.fromparser) * ('f * (int * int))
+val to_Call_op :
+ string * Types.fromparser list ->
+ 'a * (int * int) -> Types.fromparser * ('a * (int * int))
+val to_Call_op_ :
+ 'a * string * Types.fromparser list ->
+ 'b * (int * int) -> ('a * Types.fromparser) * ('b * (int * int))
val followed_by_comma :
('a * Types.fromparser list) * 'b -> bool * 'c -> Types.fromparser list
val call_func :
@@ -100,6 +127,14 @@ val call : Types.fromparser * Types.fromparser list -> Types.fromparser
val call_one_scalar_para :
string * ('a * (int * int)) ->
Types.fromparser list -> Types.priority * Types.fromparser
+val call_op_if_infix :
+ Types.fromparser ->
+ Types.fromparser ->
+ 'a * (int * int) -> Types.fromparser * ('a * (int * int))
+val call_op_unless_infix :
+ Types.fromparser ->
+ Types.fromparser ->
+ 'a * (int * int) -> Types.fromparser * ('a * (int * int))
val current_lexbuf : Lexing.lexbuf option ref
val list2tokens : ((int * int) * 'a) list -> Lexing.lexbuf -> 'a
val parse_tokens :
@@ -107,9 +142,10 @@ val parse_tokens :
((int * int) * 'a) list -> Lexing.lexbuf option -> 'b list
val parse_interpolated :
((Lexing.lexbuf -> 'a) -> Lexing.lexbuf -> Types.fromparser list) ->
- ('b * ((int * int) * 'a) list) list -> ('b * Types.fromparser) list
+ (string * ((int * int) * 'a) list) list -> (string * Types.fromparser) list
val to_String :
((Lexing.lexbuf -> 'a) -> Lexing.lexbuf -> Types.fromparser list) ->
+ bool ->
(string * ((int * int) * 'a) list) list * ('b * (int * int)) ->
Types.fromparser
val from_PATTERN :
diff --git a/perl_checker.src/perl_checker.ml b/perl_checker.src/perl_checker.ml
index 0247919..f328b32 100644
--- a/perl_checker.src/perl_checker.ml
+++ b/perl_checker.src/perl_checker.ml
@@ -27,35 +27,47 @@ let findfile dirs f = List.find Sys.file_exists (List.map (fun dir -> dir ^ "/"
let rec parse_file state file =
try
if !Flags.verbose then prerr_endline ("checking " ^ file) ;
- let lexbuf = Lexing.from_channel (Unix.open_process_in (Printf.sprintf "expand \"%s\"" file)) in
+ let channel = Unix.open_process_in (Printf.sprintf "expand \"%s\"" file) in
+ let lexbuf = Lexing.from_channel channel in
try
Info.start_a_new_file file ;
let tokens = Lexer.get_token Lexer.token lexbuf in
+ (*let _ = Unix.close_process_in channel in*)
let t = Parser_helper.parse_tokens Parser.prog tokens (Some lexbuf) in
- let required_packages, package = get_global_info_from_package t in
- Tree.get_vars_declaration state package ;
- let state = { state with per_package = (package.package_name, package) :: state.per_package } in
- let state = List.fold_left parse_package_if_needed state (required_packages @ List.map (fun (s, (_, pos)) -> s, pos) package.uses) in
- state
+ 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
with Failure s -> (
prerr_endline s ;
exit 1
)
- with _ -> failwith ("bad file " ^ file)
+ with
+ | 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_assoc package_name state.per_package then [], state else
try
let package = snd (List.hd state.per_package) in
let inc = inc package.file_name package.package_name package.has_package_name in
- if List.mem package_name !ignored_packages then state
+ if List.mem package_name !ignored_packages then [], state
else
- let file = String.concat "/" (split_at2 ':'':' package_name) ^ ".pm" in
- parse_file state (findfile inc file)
+ 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
with Not_found ->
Tree.warn_with_pos pos (Printf.sprintf "can't find package %s" package_name) ;
- state
+ [], state
+let rec parse_required_packages state = function
+ | [] -> state
+ | e :: l ->
+ let el, state = parse_package_if_needed state e in
+ parse_required_packages state (el @ l)
let parse_options =
let args_r = ref [] in
@@ -67,5 +79,8 @@ let parse_options =
Arg.parse options (lpush args_r) usage;
let args = if !args_r = [] then (Unix.chdir "/home/pixel/cooker/gi/perl-install" ; ["/home/pixel/cooker/gi/perl-install/t.pl"]) else !args_r in
- let state = List.fold_left parse_file default_state args in
+ let required_packages, state = collect_withenv parse_file default_state args in
+
+ let state = parse_required_packages state required_packages in
+
List.iter (check_tree state) (List.map snd state.per_package)
diff --git a/perl_checker.src/tree.ml b/perl_checker.src/tree.ml
index 33cc111..e91e0e1 100644
--- a/perl_checker.src/tree.ml
+++ b/perl_checker.src/tree.ml
@@ -1,12 +1,15 @@
open Types
open Common
open Printf
+open Parser_helper
+
+type special_export = Re_export_all | Export_all
type exports = {
export_ok : (context * string) list ;
export_auto : (context * string) list ;
export_tags : (string * (context * string) list) list ;
- re_export_all : bool ;
+ special_export : special_export option ;
}
type uses = (string * ((context * string) list option * pos)) list
@@ -15,12 +18,14 @@ type per_package = {
file_name : string ;
package_name : string ; has_package_name : bool ;
vars_declared : (context * string, pos) Hashtbl.t ;
+ imported : ((context * string) * string) list option ref ;
exports : exports ;
uses : uses ;
body : fromparser list;
}
type state = {
per_package : (string * per_package) list ;
+ files_parsed : string list ;
global_vars_declared : (context * string * string, pos) Hashtbl.t ;
global_vars_used : ((context * string * string) * pos) list ref ;
}
@@ -28,28 +33,20 @@ type state = {
type vars = {
my_vars : (context * string) list list ;
our_vars : (context * string) list list ;
- imported : ((context * string) * string) list ;
+ locally_imported : ((context * string) * string) list ;
required_vars : (context * string * string) list ;
current_package : per_package ;
state : state ;
}
let anonymous_package_count = ref 0
-let default_state = { per_package = []; global_vars_declared = Hashtbl.create 256; global_vars_used = ref [] }
-let empty_exports = { export_ok = []; export_auto = []; export_tags = []; re_export_all = false }
+let default_state = { per_package = []; files_parsed = []; global_vars_declared = Hashtbl.create 256; global_vars_used = ref [] }
+let empty_exports = { export_ok = []; export_auto = []; export_tags = []; special_export = None }
let ignored_packages = ref []
let die_with_pos pos msg = failwith (Info.pos2sfull pos ^ msg)
let warn_with_pos pos msg = prerr_endline (Info.pos2sfull pos ^ msg)
-let context2s = function
- | I_scalar -> "$"
- | I_hash -> "%"
- | I_array -> "@"
- | I_func -> "&"
- | I_raw -> ""
- | I_star -> "*"
-let variable2s(context, ident) = context2s context ^ ident
let s2context s =
match s.[0] with
| '$' -> I_scalar, skip_n_char 1 s
@@ -63,14 +60,22 @@ let s2context s =
let get_current_package t =
match t with
- | Package(Ident _ as ident) :: _ ->
- Some (Parser_helper.string_of_Ident ident)
+ | Package(Ident _ as ident) :: body ->
+ let rec bundled_packages packages current_package found_body = function
+ | [] -> (Some current_package, List.rev found_body) :: packages
+ | Package(Ident _ as ident) :: body ->
+ let packages = (Some current_package, List.rev found_body) :: packages in
+ bundled_packages packages (string_of_Ident ident) [] body
+ | instr :: body ->
+ bundled_packages packages current_package (instr :: found_body) body
+ in
+ bundled_packages [] (string_of_Ident ident) [] body
| _ ->
if str_ends_with !Info.current_file ".pm" then warn_with_pos (!Info.current_file, 0, 0) (sprintf "module %s does not have \"package xxxx;\" on its first line" !Info.current_file) ;
- None
+ [ None, t ]
let from_qw = function
- | Call_op("qw", [ Raw_string(s, pos)]) ->
+ | Call_op("qw", [ Raw_string(s, pos)], _) ->
List.map (fun s ->
let context, s' = s2context s in
let context =
@@ -88,20 +93,21 @@ let from_qw = function
let get_exported t =
List.fold_left (fun exports e ->
match e with
- | List [ Call_op("=", [ Deref(I_array, Ident(None, "EXPORT", pos)); Call _ ]) ]
- | List [ Call_op("=", [ My_our("our", [(I_array, "EXPORT")], pos); Call _ ]) ] ->
- if not exports.re_export_all then warn_with_pos pos "unrecognised @EXPORT" ;
+ | List [ Call_op("=", [ Deref(I_array, Ident(None, "EXPORT", _)); Call _ ], pos) ]
+ | List [ Call_op("=", [ My_our("our", [(I_array, "EXPORT")], _); Call _ ], pos) ] ->
+ if exports.special_export = None then warn_with_pos pos "unrecognised @EXPORT" ;
exports
- | List [ Call_op("=", [ Deref(I_array, Ident(None, "EXPORT", pos)); v ])]
- | List [ Call_op("=", [ My_our("our", [(I_array, "EXPORT")], pos); v ])] ->
+ | List [ Call_op("=", [ Deref(I_array, Ident(None, "EXPORT", _)); v ], pos)]
+ | List [ Call_op("=", [ My_our("our", [(I_array, "EXPORT")], _); v ], pos)] ->
if exports.export_auto <> [] then warn_with_pos pos "weird, @EXPORT set twice" ;
{ exports with export_auto = from_qw v }
- | Perl_checker_comment("RE-EXPORT-ALL", _) -> { exports with re_export_all = true }
+ | Perl_checker_comment("RE-EXPORT-ALL", _) -> { exports with special_export = Some Re_export_all }
+ | Perl_checker_comment("EXPORT-ALL", _) -> { exports with special_export = Some Export_all }
- | List [ Call_op("=", [ Deref(I_array, Ident(None, "EXPORT_OK", pos)); v ])]
- | List [ Call_op("=", [ My_our("our", [(I_array, "EXPORT_OK")], pos); v ])] ->
+ | List [ Call_op("=", [ Deref(I_array, Ident(None, "EXPORT_OK", _)); v ], pos)]
+ | List [ Call_op("=", [ My_our("our", [(I_array, "EXPORT_OK")], _); v ], pos)] ->
if exports.export_ok <> [] then warn_with_pos pos "weird, @EXPORT_OK set twice" ;
(match v with
| Call(Deref(I_func, Ident(None, "map", _)),
@@ -110,8 +116,8 @@ let get_exported t =
{ exports with export_ok = collect snd exports.export_tags }
| _ -> { exports with export_ok = from_qw v })
- | List [ Call_op("=", [ Deref(I_hash, Ident(None, "EXPORT_TAGS", pos)); v ])]
- | List [ Call_op("=", [ My_our("our", [(I_hash, "EXPORT_TAGS")], pos); v ])] ->
+ | List [ Call_op("=", [ Deref(I_hash, Ident(None, "EXPORT_TAGS", _)); v ], pos)]
+ | List [ Call_op("=", [ My_our("our", [(I_hash, "EXPORT_TAGS")], _); v ], pos)] ->
(try
let export_tags =
match v with
@@ -147,9 +153,9 @@ let uses_external_package = function
let get_uses t =
List.fold_left (fun uses e ->
match e with
- | Use(Ident _ as pkg, _) when uses_external_package (Parser_helper.string_of_Ident pkg) -> uses
+ | Use(Ident _ as pkg, _) when uses_external_package (string_of_Ident pkg) -> uses
| Use(Ident(_, _, pos) as ident, l) ->
- let package = Parser_helper.string_of_Ident ident in
+ let package = string_of_Ident ident in
let para = if l = [] then None else Some(from_qw (List.hd l)) in
(package, (para, pos)) :: uses
| _ -> uses
@@ -162,7 +168,7 @@ let get_vars_declaration state package =
| Sub_declaration(Ident(Some fq, name, pos), _proto, _) ->
Hashtbl.replace state.global_vars_declared (I_func, fq, name) pos
- | List [ Call_op("=", [My_our("our", ours, pos); _]) ]
+ | List [ Call_op("=", [My_our("our", ours, pos); _], _) ]
| List [ My_our("our", ours, pos) ]
| My_our("our", ours, pos) ->
List.iter (fun (context, name) -> Hashtbl.replace package.vars_declared (context, name) pos) ours
@@ -171,38 +177,71 @@ let get_vars_declaration state package =
| Use(Ident(None, "vars", pos), [ours]) ->
List.iter (fun (context, name) -> Hashtbl.replace package.vars_declared (context, name) pos) (from_qw ours)
| Use(Ident(None, "vars", pos), _) ->
- die_with_pos pos "usage: \"use vars qw($var func)\""
+ die_with_pos pos "usage: use vars qw($var func)"
+
+ | List [ Method_call(Raw_string(pkg, pos), Raw_string("bootstrap", _), _) ] ->
+ if pkg <> package.package_name then
+ warn_with_pos pos "strange bootstrap (the package name is not the same as the current package)"
+ else
+ (try
+ let cfile = Filename.chop_extension package.file_name ^ ".c" in
+ let prefix = "newXS(\"" ^ pkg ^ "::" in
+ ignore (fold_lines (fun in_bootstrap s ->
+ if in_bootstrap then
+ (try
+ let offset = strstr s prefix + String.length prefix in
+ let end_ = String.index_from s offset '"' in
+ let ident = String.sub s offset (end_ - offset) in
+ match split_at2 ':'':' ident with
+ | [_] -> Hashtbl.replace package.vars_declared (I_func, ident) pos
+ | l ->
+ if l <> [] then
+ let fql, name = split_last l in
+ let fq = String.concat "::" (pkg :: fql) in
+ Hashtbl.replace state.global_vars_declared (I_func, fq, name) pos
+ with Not_found -> ());
+ in_bootstrap || str_contains s "XS_VERSION_BOOTCHECK"
+ ) false (open_in cfile))
+ with Invalid_argument _ | Sys_error _ -> ())
| _ -> ()
) package.body
-let get_imports state package =
- let rec get_one (package_name, (imports, pos)) =
- try
- let package_used = List.assoc package_name state.per_package in
- let exports = package_used.exports in
- match imports with
- | None ->
- let re = if exports.re_export_all then collect get_one package_used.uses else [] in
- let l = List.map (fun (context, name) -> (context, name), package_name) exports.export_auto in
- re @ l
- | Some l ->
- let imports_vars =
- collect (function
- | I_raw, tag ->
- (try
- List.assoc tag exports.export_tags
- with Not_found -> die_with_pos pos (sprintf "package %s doesn't export tag %s" package_name tag))
- | variable ->
- if List.mem variable exports.export_ok then
- [ variable ]
- else
- die_with_pos pos (sprintf "package %s doesn't export %s" package_name (variable2s variable))
- ) l
- in
- List.map (fun (context, name) -> (context, name), package_name) imports_vars
- with Not_found -> []
- in
- collect get_one package.uses
+let rec get_imported state (package_name, (imports, pos)) =
+ try
+ let package_used = List.assoc package_name state.per_package in
+ let exports = package_used.exports in
+ match imports with
+ | None ->
+ let re = match exports.special_export with
+ | Some Re_export_all -> get_imports state package_used
+ | Some Export_all -> Hashtbl.fold (fun var _ l -> (var, package_name) :: l) package_used.vars_declared []
+ | _ -> [] in
+ let l = List.map (fun (context, name) -> (context, name), package_name) exports.export_auto in
+ re @ l
+ | Some l ->
+ let imports_vars =
+ collect (function
+ | I_raw, tag ->
+ (try
+ List.assoc tag exports.export_tags
+ with Not_found -> die_with_pos pos (sprintf "package %s doesn't export tag %s" package_name tag))
+ | variable ->
+ if List.mem variable exports.export_ok then
+ [ variable ]
+ else
+ die_with_pos pos (sprintf "package %s doesn't export %s" package_name (variable2s variable))
+ ) l
+ in
+ List.map (fun (context, name) -> (context, name), package_name) imports_vars
+ with Not_found -> []
+
+and get_imports state package =
+ match !(package.imported) with
+ | Some l -> l
+ | None ->
+ let l = collect (get_imported state) package.uses in
+ package.imported := Some l ;
+ l
let rec fold_tree f env e =
match f env e with
@@ -218,8 +257,7 @@ let rec fold_tree f env e =
-> fold_tree_option f env e'
| Sub_declaration(e1, _, e2)
- | Deref_with(_, e1, e2)
- | Binop(_, e1, e2)
+ | Deref_with(_, _, e1, e2)
->
let env = fold_tree f env e1 in
let env = fold_tree f env e2 in
@@ -228,31 +266,20 @@ let rec fold_tree f env e =
| Use(_, l)
| List l
| Block l
- | Call_op(_, l)
+ | Call_op(_, l, _)
-> List.fold_left (fold_tree f) env l
| Call(e', l)
- | CallP(e', l)
->
let env = fold_tree f env e' in
List.fold_left (fold_tree f) env l
| Method_call(e1, e2, l)
- | Method_callP(e1, e2, l)
->
let env = fold_tree f env e1 in
let env = fold_tree f env e2 in
List.fold_left (fold_tree f) env l
- | If_then_else(_, t_l, e')
- ->
- let env = fold_tree_option f env e' in
- List.fold_left (fun env (e1, e2) ->
- let env = fold_tree f env e1 in
- let env = fold_tree f env e2 in
- env
- ) env t_l
-
| _ -> env
and fold_tree_option f env = function
@@ -261,45 +288,50 @@ and fold_tree_option f env = function
let get_global_info_from_package t =
- let exports = get_exported t in
- let uses = get_uses t in
- let current_package = get_current_package t in
- let package_name =
- match current_package with
- | None ->
- if exports.export_ok <> [] || exports.export_auto <> [] || exports.export_tags <> [] then
- die_with_pos (!Info.current_file, 0, 0) "file with no \"package\" wants to export!"
- else
- (incr anonymous_package_count ; sprintf "anonymous%d" !anonymous_package_count)
- | Some name -> name
- in
- let required_packages = List.fold_left (fold_tree (fun l ->
- function
- | Call(Deref(I_func, Ident (None, "require", pos)), [Raw_string (package, _)])
- when not (uses_external_package package) -> Some((package, pos) :: l)
- | _ -> None)
- ) [] t in
- required_packages, {
- file_name = !Info.current_file ;
- package_name = package_name;
- has_package_name = current_package <> None ;
- exports = exports ;
- vars_declared = Hashtbl.create 16 ;
- uses = uses ;
- body = t ;
- }
-
+ let current_packages = get_current_package t in
+ map_withenv (fun required_packages (current_package, t) ->
+ let exports = get_exported t in
+ let uses = get_uses t in
+ let package_name =
+ match current_package with
+ | None ->
+ if exports.export_ok <> [] || exports.export_auto <> [] || exports.export_tags <> [] then
+ die_with_pos (!Info.current_file, 0, 0) "file with no package name wants to export!"
+ else
+ (incr anonymous_package_count ; sprintf "anonymous%d" !anonymous_package_count)
+ | Some name -> name
+ in
+ let required_packages = List.fold_left (fold_tree (fun l ->
+ function
+ | Call(Deref(I_func, Ident (None, "require", pos)), [Ident _ as pkg]) ->
+ let package = string_of_Ident pkg in
+ if uses_external_package package then None else Some((package, pos) :: l)
+ | _ -> None)
+ ) required_packages t in
+ {
+ file_name = !Info.current_file ;
+ package_name = package_name;
+ has_package_name = current_package <> None ;
+ exports = exports ;
+ imported = ref None ;
+ vars_declared = Hashtbl.create 16 ;
+ uses = uses ;
+ body = t ;
+ }, required_packages
+ ) [] current_packages
let is_my_declared vars t = List.exists (List.exists ((=) t)) vars.my_vars
let is_our_declared vars t = List.exists (List.exists ((=) t)) vars.our_vars
let is_var_declared vars (context, name) =
- List.mem_assoc (context, name) vars.imported ||
+ List.mem_assoc (context, name) vars.locally_imported ||
+ List.mem_assoc (context, name) (get_imports vars.state vars.current_package) ||
Hashtbl.mem vars.current_package.vars_declared (context, name)
let is_global_var_declared vars (context, fq, name) =
Hashtbl.mem vars.state.global_vars_declared (context, fq, name) ||
(try
let package = List.assoc fq vars.state.per_package in
- Hashtbl.mem package.vars_declared (context, name)
+ Hashtbl.mem package.vars_declared (context, name) ||
+ List.mem_assoc (context, name) (get_imports vars.state package)
with Not_found -> false)
@@ -358,7 +390,7 @@ let check_variable (context, var) vars =
then ()
else
if context = I_func then
- warn_with_pos pos ("unknown function " ^ Parser_helper.string_of_Ident var)
+ warn_with_pos pos ("unknown function " ^ string_of_Ident var)
else
lpush vars.state.global_vars_used ((context, fq, name), pos)
| _ -> ()
@@ -366,12 +398,12 @@ let check_variable (context, var) vars =
let declare_My vars (mys, pos) =
let l_new = List.filter (fun (context, ident) ->
if context = I_raw then
- if ident = "undef" then false else die_with_pos pos (sprintf "bad ident \"%s\" in my" ident)
+ if ident = "undef" then false else die_with_pos pos (sprintf "bad ident %s in my" ident)
else true
) mys in
let l_pre = List.hd vars.my_vars in
List.iter (fun v ->
- if List.exists ((=) v) l_pre then warn_with_pos pos (sprintf "redeclared variable \"%s\"" (variable2s v))
+ if List.exists ((=) v) l_pre then warn_with_pos pos (sprintf "redeclared variable %s" (variable2s v))
) l_new ;
{ vars with my_vars = (l_new @ l_pre) :: List.tl vars.my_vars }
@@ -380,7 +412,7 @@ let declare_Our vars (ours, pos) =
| [] -> vars (* we're at the toplevel, already declared in vars_declared *)
| l_pre :: other ->
List.iter (fun v ->
- if List.exists ((=) v) l_pre then warn_with_pos pos (sprintf "redeclared variable \"%s\"" (variable2s v))
+ if List.exists ((=) v) l_pre then warn_with_pos pos (sprintf "redeclared variable %s" (variable2s v))
) ours ;
{ vars with our_vars = (ours @ l_pre) :: other }
@@ -405,11 +437,11 @@ let check_variables vars t =
let _vars' = List.fold_left check_variables_ vars' f in
Some vars
- | Call_op("foreach my", [my; expr; Block block]) ->
+ | Call_op("foreach my", [my; expr; Block block], _) ->
let vars = check_variables_ vars expr in
let vars = check_variables_ vars (Block (my :: block)) in
Some vars
- | Call_op(op, cond :: Block first_bl :: other) when op = "if" || op = "while" || op = "unless" || op = "until" ->
+ | Call_op(op, cond :: Block first_bl :: other, _) when op = "if" || op = "while" || op = "unless" || op = "until" ->
let vars' = { vars with my_vars = [] :: vars.my_vars ; our_vars = [] :: vars.our_vars } in
let vars' = check_variables_ vars' cond in
let _vars' = List.fold_left check_variables_ vars' first_bl in
@@ -417,7 +449,7 @@ let check_variables vars t =
Some vars
| Sub_declaration(Ident(_, _, pos) as ident, _proto, body) ->
- let vars = declare_Our vars ([ I_func, Parser_helper.string_of_Ident ident ], pos) in
+ let vars = declare_Our vars ([ I_func, string_of_Ident ident ], pos) in
let vars = check_variables_ vars body in
Some vars
@@ -429,31 +461,37 @@ let check_variables vars t =
| Deref(context, (Ident _ as var)) ->
check_variable (context, var) vars ;
Some vars
- | Deref_with(context, (Ident _ as var), para) ->
+ | Deref_with(context, _, (Ident _ as var), para) ->
let vars = check_variables_ vars para in
check_variable (context, var) vars ;
Some vars
- | Call_op(op, [My_our(my_or_our, mys, pos); e]) ->
- if op = "=" then
- (* check e first *)
- let vars = check_variables_ vars e in
- List.iter (fun (context, var) ->
- if context = I_hash || context = I_array then die_with_pos pos (sprintf "%s takes all the arguments, %s is undef in any case" (variable2s (context, var)) (variable2s (last mys)))
- ) (removelast mys) ; (* mys is never empty *)
- Some(declare_My_our vars (my_or_our, mys, pos))
- else
- (warn_with_pos pos "weird" ; None)
-
- | Call(Deref(I_func, Ident(None, "require", _)), [Raw_string (package_name, _)]) ->
- (try
- let package = List.assoc package_name vars.state.per_package in
- let required_vars = Hashtbl.fold (fun (context, ident) _ l ->
- (context, vars.current_package.package_name, ident) :: l
- ) package.vars_declared vars.required_vars in
- let vars = { vars with required_vars = required_vars } in
- Some vars
- with Not_found -> Some vars)
+ | Call_op("=", [My_our(my_or_our, mys, pos); e], _) ->
+ (* check e first *)
+ let vars = check_variables_ vars e in
+ List.iter (fun (context, var) ->
+ if non_scalar_context context then die_with_pos pos (sprintf "%s takes all the arguments, %s is undef in any case" (variable2s (context, var)) (variable2s (last mys)))
+ ) (removelast mys) ; (* mys is never empty *)
+ Some(declare_My_our vars (my_or_our, mys, pos))
+
+ | Call_op("if infix", [List [My_our _]; List [Num("0", _)]], _) -> None (* special allowed case *)
+ | Call_op(op, List (My_our _ :: _) :: _, pos)
+ | Call_op(op, My_our _ :: _, pos)
+ | Call_op(op, Call_op("local", _, _) :: _, pos) ->
+ if op <> "=" then warn_with_pos pos (sprintf "applying %s on a new initialized variable is wrong" op);
+ None
+
+ | Call(Deref(I_func, Ident(None, "require", _)), [Ident _]) -> Some vars
+
+ | Method_call(Raw_string(package_name, pos), Raw_string ("import", _), para) ->
+ let args =
+ match para with
+ | [] -> None
+ | [ List [v] ] -> Some(from_qw v)
+ | _ -> die_with_pos pos "bad import statement" in
+ let l = get_imported vars.state (package_name, (args, pos)) in
+ let vars = { vars with locally_imported = l @ vars.locally_imported } in
+ Some vars
| _ -> None
in
@@ -461,7 +499,28 @@ let check_variables vars t =
vars
let check_tree state package =
- let imports = get_imports state package in
- let vars = { my_vars = [[]]; our_vars = []; imported = imports; required_vars = []; current_package = package; state = state } in
+ let vars = { my_vars = [[]]; our_vars = []; locally_imported = []; required_vars = []; current_package = package; state = state } in
let _vars = check_variables vars package.body in
()
+
+let add_package_to_state state package =
+ let per_package =
+ try
+ update_assoc (fun existing_package ->
+ (*prerr_endline (existing_package.file_name ^ " vs " ^ package.file_name); *)
+ Hashtbl.iter (fun var pos -> Hashtbl.replace existing_package.vars_declared var pos) package.vars_declared ;
+ { existing_package with
+ body = existing_package.body @ package.body ;
+ uses = existing_package.uses @ package.uses ;
+ exports = { export_ok = existing_package.exports.export_ok @ package.exports.export_ok ;
+ export_auto = existing_package.exports.export_auto @ package.exports.export_auto ;
+ export_tags = existing_package.exports.export_tags @ package.exports.export_tags ;
+ special_export = None }
+ }
+ ) package.package_name state.per_package
+ with Not_found ->
+ (package.package_name, package) :: state.per_package
+ in
+ { state with
+ per_package = per_package ;
+ files_parsed = package.file_name :: state.files_parsed }
diff --git a/perl_checker.src/tree.mli b/perl_checker.src/tree.mli
index 769b513..71eeb04 100644
--- a/perl_checker.src/tree.mli
+++ b/perl_checker.src/tree.mli
@@ -1,10 +1,12 @@
open Types
+type special_export = Re_export_all | Export_all
+
type exports = {
export_ok : (context * string) list;
export_auto : (context * string) list;
export_tags : (string * (context * string) list) list;
- re_export_all : bool;
+ special_export : special_export option;
}
@@ -14,12 +16,14 @@ type per_package = {
file_name : string ;
package_name : string ; has_package_name : bool ;
vars_declared : (context * string, pos) Hashtbl.t;
+ imported : ((context * string) * string) list option ref;
exports : exports ;
uses : uses ;
body : fromparser list;
}
type state = {
per_package : (string * per_package) list;
+ files_parsed : string list;
global_vars_declared : (context * string * string, pos) Hashtbl.t;
global_vars_used : ((context * string * string) * pos) list ref;
}
@@ -27,9 +31,10 @@ type state = {
val ignored_packages : string list ref
val default_state : state
-val get_global_info_from_package : fromparser list -> (string * pos) list * per_package
+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 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
diff --git a/perl_checker.src/types.mli b/perl_checker.src/types.mli
index d11ff9a..f69dc3d 100644
--- a/perl_checker.src/types.mli
+++ b/perl_checker.src/types.mli
@@ -22,20 +22,16 @@ type fromparser =
| Ref of context * fromparser
| Deref of context * fromparser
- | Deref_with of context * fromparser * fromparser
+ | Deref_with of context * context * fromparser * fromparser (* from_context, to_context, ref, para *)
| Diamond of fromparser option
- | Binop of string * fromparser * fromparser
- | If_then_else of string * (fromparser * fromparser) list * fromparser option
| List of fromparser list
| Block of fromparser list
- | Call_op of string * fromparser list
+ | Call_op of string * fromparser list * pos
| Call of fromparser * fromparser list
- | CallP of fromparser * fromparser list
| Method_call of fromparser * fromparser * fromparser list
- | Method_callP of fromparser * fromparser * fromparser list
| Anonymous_sub of fromparser
| My_our of string * (context * string) list * pos
generated by cgit v1.2.1 (git 2.21.0) at 2024-08-18 18:15:54 +0000