diff options
author | Pascal Rigaux <pixel@mandriva.com> | 2002-11-28 00:57:32 +0000 |
---|---|---|
committer | Pascal Rigaux <pixel@mandriva.com> | 2002-11-28 00:57:32 +0000 |
commit | 88100399efa487df4145f0ed53cc7ee8305e0b3d (patch) | |
tree | a5055d960f052386ba94096d4ab5ac4bcf9cadf1 | |
parent | 1537738cd9023b08d8730a56eb7bc1e1cab0dc90 (diff) | |
download | perl-MDK-Common-88100399efa487df4145f0ed53cc7ee8305e0b3d.tar perl-MDK-Common-88100399efa487df4145f0ed53cc7ee8305e0b3d.tar.gz perl-MDK-Common-88100399efa487df4145f0ed53cc7ee8305e0b3d.tar.bz2 perl-MDK-Common-88100399efa487df4145f0ed53cc7ee8305e0b3d.tar.xz perl-MDK-Common-88100399efa487df4145f0ed53cc7ee8305e0b3d.zip |
*** empty log message ***
-rw-r--r-- | perl_checker.src/common.ml | 47 | ||||
-rw-r--r-- | perl_checker.src/common.mli | 5 | ||||
-rw-r--r-- | perl_checker.src/lexer.mll | 14 | ||||
-rw-r--r-- | perl_checker.src/parser.mly | 178 | ||||
-rw-r--r-- | perl_checker.src/parser_helper.ml | 250 | ||||
-rw-r--r-- | perl_checker.src/parser_helper.mli | 56 | ||||
-rw-r--r-- | perl_checker.src/perl_checker.ml | 41 | ||||
-rw-r--r-- | perl_checker.src/tree.ml | 323 | ||||
-rw-r--r-- | perl_checker.src/tree.mli | 9 | ||||
-rw-r--r-- | perl_checker.src/types.mli | 8 |
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 |