diff options
| -rw-r--r-- | perl_checker.src/lexer.mll | 29 | ||||
| -rw-r--r-- | perl_checker.src/parser.mly | 28 | ||||
| -rw-r--r-- | perl_checker.src/parser_helper.ml | 143 | ||||
| -rw-r--r-- | perl_checker.src/parser_helper.mli | 14 | ||||
| -rw-r--r-- | perl_checker.src/perl_checker.ml | 2 | ||||
| -rw-r--r-- | perl_checker.src/tree.ml | 34 |
6 files changed, 175 insertions, 75 deletions
diff --git a/perl_checker.src/lexer.mll b/perl_checker.src/lexer.mll index e54e968..bf344a4 100644 --- a/perl_checker.src/lexer.mll +++ b/perl_checker.src/lexer.mll @@ -229,20 +229,16 @@ let warn lexbuf err = prerr_endline (pos2sfull_with (lexeme_start lexbuf) (lexem let die lexbuf err = failwith (pos2sfull_with (lexeme_start lexbuf) (lexeme_end lexbuf) ^ err) let die_in_string lexbuf err = failwith (pos2sfull_with !current_string_start_pos (lexeme_end lexbuf) ^ err) +let next_interpolated toks = + let r = Stack.top building_current_string in + Queue.push (!r, toks) (Stack.top building_current_interpolated_string) ; + r := "" + let raw_ins t lexbuf = Stack.push (ref "") building_current_string; current_string_start_pos := lexeme_start lexbuf; t lexbuf ; !(Stack.pop building_current_string), (!current_string_start_pos, lexeme_end lexbuf) -let raw_ins_to_string t lexbuf = - let s, pos = raw_ins t lexbuf in - not_ok_for_match := lexeme_end lexbuf; - RAW_STRING(s, pos) - -let next_interpolated toks = - let r = Stack.top building_current_string in - Queue.push (!r, toks) (Stack.top building_current_interpolated_string) ; - r := "" let ins t lexbuf = Stack.push (Queue.create()) building_current_interpolated_string ; @@ -252,6 +248,11 @@ let ins t lexbuf = next_interpolated [] ; let _ = Stack.pop building_current_string in queue2list (Stack.pop building_current_interpolated_string), (!current_string_start_pos, lexeme_end lexbuf) + +let raw_ins_to_string t lexbuf = + let s, pos = raw_ins t lexbuf in + not_ok_for_match := lexeme_end lexbuf; + RAW_STRING(s, pos) let ins_to_string t lexbuf = let s, pos = ins t lexbuf in not_ok_for_match := lexeme_end lexbuf; @@ -417,9 +418,9 @@ rule token = parse | "split" | "grep" { (* ok_for_match! *) BAREWORD(lexeme lexbuf, pos lexbuf) } -| "print " ident ' ' { - putback lexbuf 1; - PRINT_TO_STAR(skip_n_char 6 (lexeme lexbuf), pos lexbuf); +| "print " ['A'-'Z'] ['A'-'Z' '0'-'9']* ' ' { + putback lexbuf 1; + PRINT_TO_STAR(skip_n_char 6 (lexeme lexbuf), pos lexbuf) } | "print $" ident ' ' { putback lexbuf 1; @@ -588,14 +589,14 @@ rule token = parse } | '"' { ins_to_string string lexbuf } -| "'" { ins_to_string rawstring lexbuf } +| "'" { raw_ins_to_string rawstring lexbuf } | '`' { delimit_char := '`'; current_string_start_line := !current_file_current_line; not_ok_for_match := lexeme_end lexbuf; let s, pos = ins delimited_string lexbuf in check_multi_line_delimited_string None pos ; COMMAND_STRING(s, pos) } -| "q(" { ins_to_string qstring lexbuf } +| "q(" { raw_ins_to_string qstring lexbuf } | "qq(" { ins_to_string qqstring lexbuf } | "qw(" { let s, pos = raw_ins qstring lexbuf in QUOTEWORDS(s, pos) } diff --git a/perl_checker.src/parser.mly b/perl_checker.src/parser.mly index 2114de6..2279ac1 100644 --- a/perl_checker.src/parser.mly +++ b/perl_checker.src/parser.mly @@ -190,8 +190,8 @@ expr: /* Ordinary expressions; logical combinations */ argexpr: /* Expressions are a list of terms joined by commas */ | argexpr comma {(P_comma, sndfst $1), sp_pos_range $1 $2} -| argexpr comma term {if not_simple (sndfst $3) then sp_p($3); (P_comma, sndfst $1 @ [sndfst $3]), sp_pos_range $1 $3} -| argexpr comma BRACKET expr BRACKET_END {sp_p($3); sp_p($5); (P_comma, sndfst $1 @ [ Ref(I_hash, sndfst $4) ]), sp_pos_range $1 $5} +| argexpr comma term {if not_simple (sndfst $3) then sp_p($3); (P_comma, followed_by_comma $1 $2 @ [sndfst $3]), sp_pos_range $1 $3} +| argexpr comma BRACKET expr BRACKET_END {sp_p($3); sp_p($5); (P_comma, followed_by_comma $1 $2 @ [ Ref(I_hash, sndfst $4) ]), sp_pos_range $1 $5} | term %prec PREC_LOW {(fstfst $1, [sndfst $1]), snd $1} /********************************************************************************/ @@ -252,7 +252,7 @@ term: | 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(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 */ @@ -283,19 +283,22 @@ term: /* function_calls */ -| func parenthesized {sp_0($2); (P_tok, call(fst $1, sndfst $2)), sp_pos_range $1 $2} /* &foo(@args) */ +| 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 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, 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, 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, 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, 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_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 */ -| NEW word listexpr { (P_call_no_paren, Method_call(fst $2, Ident(None, "new", get_pos $1), sndfst $3)), sp_pos_range $1 $3} /* new Class @args */ +| 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 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("print", var_STDOUT :: [ var_dollar_ ])), snd $1} | PRINT argexpr {check_parenthesized_first_argexpr (fst $1) $2; (P_call_no_paren, Call_op("print", var_STDOUT :: sndfst $2)), sp_pos_range $1 $2} @@ -306,8 +309,10 @@ term: | hash PKG_SCOPE {sp_0($2); (P_tok, Too_complex), sp_pos_range $1 $2} /* %main:: */ -| word {(P_tok, check_word_alone $1), snd $1} +| terminal {$1} +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} | RAW_STRING {(P_tok, to_Raw_string $1), snd $1} @@ -366,6 +371,7 @@ my_our: /* Things that can be "my"'d */ | MY_OUR SCALAR_IDENT {My_our(fst $1, [I_scalar, sndfst $2], get_pos $2), sp_pos_range $1 $2} | MY_OUR HASH_IDENT {My_our(fst $1, [I_hash, sndfst $2], get_pos $2), sp_pos_range $1 $2} | MY_OUR ARRAY_IDENT {My_our(fst $1, [I_array, sndfst $2], get_pos $2), sp_pos_range $1 $2} +| MY_OUR STAR_IDENT {if fst $1 <> "our" then die_rule "syntax error"; My_our(fst $1, [I_star, sndfst $2], get_pos $2), sp_pos_range $1 $2} my_our_paren: | MY_OUR PAREN {sp_1($2); ((true, fst $1), []), sp_pos_range $1 $2} @@ -395,7 +401,7 @@ word: | bareword { $1 } | RAW_IDENT { to_Ident $1, snd $1} -comma: COMMA {$1} | RIGHT_ARROW {sp_p($1); $1} +comma: COMMA {true, snd $1} | RIGHT_ARROW {sp_p($1); false, snd $1} semi_colon: SEMI_COLON {sp_0($1); $1} diff --git a/perl_checker.src/parser_helper.ml b/perl_checker.src/parser_helper.ml index ed89c8d..0fe96b7 100644 --- a/perl_checker.src/parser_helper.ml +++ b/perl_checker.src/parser_helper.ml @@ -180,12 +180,25 @@ let sp_same (_, (spaces1, _) as ter1) (_, (spaces2, _) as ter2) = else if spaces2 <> Space_0 then sp_p ter1 let check_word_alone (word, _) = - (match word with - | Ident(None, ("time" as f), _) - | Ident(None, ("wantarray" as f), _) -> - die_rule (sprintf "please use %s() instead of %s" f f) - | _ -> ()); - word + match word with + | Ident(None, f, _) -> + (match f with + | "length" | "stat" | "lstat" | "chop" | "chomp" | "quotemeta" | "lc" | "lcfirst" | "uc" | "ucfirst" -> + Deref(I_func, word) + + | "split" | "shift" + | "return" | "eof" | "die" | "caller" + | "redo" | "next" | "last" -> + Deref(I_func, word) + + | "hex" | "ref" -> + warn_rule (sprintf "please use \"%s $_\" instead of \"%s\"" f f) ; + Deref(I_func, word) + | "time" | "wantarray" | "fork" | "getppid" | "arch" -> + warn_rule (sprintf "please use %s() instead of %s" f f) ; + Deref(I_func, word) + | _ -> word) + | _ -> word let check_parenthesized_first_argexpr word ((_, e), (_, (start, _)) as ex) = let want_space = word.[0] = '-' in @@ -207,13 +220,6 @@ let check_for (s, (_, pos)) = if s = "foreach" then warn pos "write \"for\" 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_my_our op para (_, pos) = - match op, para with - | "=", [List [My_our _]; Ident(None, "undef", _)] -> warn pos "no need to initialize variable, it's done by default" - | "=", [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" - | _ -> () - let check_block_sub (l, (_, (_, end_)) as ter_lines) (_, (space, _) as ter_BRACKET_END) = if l = [] then sp_0_or_cr ter_BRACKET_END @@ -233,7 +239,7 @@ let check_block_ref (l, (_, (_, end_)) as ter_lines) (_, (space, _) as ter_BRACK if space <> Space_cr then (if l <> [] && last l = Semi_colon then warn_verb end_ "spurious \";\" before closing block") -let check_my_our_paren (((comma_closed, _), _), _) = +let check_my_our_paren (((comma_closed, _), _), _) = if not comma_closed then die_rule "syntax error" let rec only_one (l, (spaces, pos)) = @@ -248,13 +254,21 @@ let only_one_in_List ((_, e), both) = | List l -> only_one(l, both) | _ -> e + +let maybe_to_Raw_string = function + | Ident(None, s, pos) -> Raw_string(s, pos) + | Ident(Some fq, s, pos) -> Raw_string(fq ^ "::" ^ s, pos) + | e -> e + let to_List = function | [e] -> e | l -> List l -let deref_arraylen e = Call(Ident(None, "int", raw_pos2pos bpos), [Deref(I_array, e)]) +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_Local ((_, e), (_, pos)) = let l = match e with @@ -281,28 +295,87 @@ let to_Local ((_, e), (_, pos)) = let op prio s (_, both) = prio, (((), both), s) let op_p prio s e = sp_p e ; op prio s e -let call_op((prio, (prev_ter, op)), ter, para) = - sp_same prev_ter ter ; - check_my_our op para (snd ter); - prio, Call_op(op, para) - let sub_declaration (name, proto) body = Sub_declaration(name, proto, Block body) let anonymous_sub body = Anonymous_sub (Block body) -let call(e, para) = - (match e with - | Ident(None, "require", _) -> - (match para with - | [ Ident _ ] -> () - | [ String _ ] -> () - | [ Raw_string _ ] -> () - | _ -> die_rule "use either \"require PACKAGE\" or \"require 'PACKAGE.pm'\"") - | Ident(None, "N", _) -> - (match para with - | [List(String _ :: _)] -> () - | _ -> die_rule "N() must be used with a string") - | _ -> ()); - Call(e, para) +let call_op((prio, (prev_ter, op)), (_, (_, pos) as ter), para) = + sp_same prev_ter ter ; + + 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 followed_by_comma ((_,e), _) (true_comma, _) = + if true_comma then e else + match split_last e with + | l, Ident(None, s, pos) -> l @ [Raw_string(s, pos)] + | _ -> e + +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) ] + | [ Call(Deref(I_func, (Ident(_, _, pos) as s)), l) ] -> Some(Raw_string(string_of_Ident s, pos) :: l) + | _ -> die_rule "use \"no PACKAGE <para>\"") + | "N" | "N_" -> + (match para with + | [List(String _ :: _)] -> None + | _ -> die_rule (sprintf "%s() must be used with a string" f)) + + | "goto" -> + (match para with + | [ Ident(None, s, pos) ] -> Some [ Raw_string(s, pos) ] + | _ -> None) + + | "last" | "next" | "redo" when not is_a_func -> + (match para with + | [ Ident(None, s, pos) ] -> Some [ Raw_string(s, pos) ] + | _ -> die_rule (sprintf "%s must be used with a raw string" f)) + + | _ -> None + in Call(e, some_or para' para) + | _ -> Call(e, para) + +let call(e, para) = call_func false (e, para) + let call_one_scalar_para (e, (_, pos)) para = let pri = @@ -310,7 +383,7 @@ let call_one_scalar_para (e, (_, pos)) para = | "defined" -> P_expr | _ -> P_add in - pri, Call(Ident(None, e, raw_pos2pos pos), para) + pri, Call(Deref(I_func, Ident(None, e, raw_pos2pos pos)), para) let (current_lexbuf : Lexing.lexbuf option ref) = ref None diff --git a/perl_checker.src/parser_helper.mli b/perl_checker.src/parser_helper.mli index 66395c1..879d194 100644 --- a/perl_checker.src/parser_helper.mli +++ b/perl_checker.src/parser_helper.mli @@ -21,6 +21,7 @@ val warn : int * int -> string -> unit val die_rule : string -> 'a val warn_rule : string -> unit val debug : string -> unit +val warn_verb : int -> string -> unit val warn_too_many_space : int -> unit val warn_no_space : int -> unit val warn_cr : int -> unit @@ -54,8 +55,6 @@ val check_foreach : string * ('a * (int * int)) -> unit val check_for : string * ('a * (int * int)) -> unit val check_MULT_is_x : string * 'a -> unit val check_my : string * 'a -> unit -val check_my_our : - string -> Types.fromparser list -> 'a * (int * int) -> unit val check_block_sub : Types.fromparser list * (Types.spaces * (int * int)) -> 'a * (Types.spaces * (int * 'b)) -> unit @@ -66,11 +65,18 @@ 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 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_Local : ('a * Types.fromparser) * ('b * (int * int)) -> Types.fromparser val op : 'a -> 'b -> 'c * 'd -> 'a * ((unit * 'd) * 'b) @@ -86,6 +92,10 @@ val call_op : val sub_declaration : Types.fromparser * string -> Types.fromparser list -> Types.fromparser val anonymous_sub : Types.fromparser list -> Types.fromparser +val followed_by_comma : + ('a * Types.fromparser list) * 'b -> bool * 'c -> Types.fromparser list +val call_func : + bool -> Types.fromparser * Types.fromparser list -> Types.fromparser val call : Types.fromparser * Types.fromparser list -> Types.fromparser val call_one_scalar_para : string * ('a * (int * int)) -> diff --git a/perl_checker.src/perl_checker.ml b/perl_checker.src/perl_checker.ml index 78dc2d5..d5d4945 100644 --- a/perl_checker.src/perl_checker.ml +++ b/perl_checker.src/perl_checker.ml @@ -67,6 +67,6 @@ let parse_options = let usage = "Usage: perl_checker [-v] [-q] <files>\nOptions are:" in Arg.parse options (lpush args_r) usage; - let args = if !args_r = [] then ["../t.pl"] else !args_r in + 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 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 7353629..69a72fb 100644 --- a/perl_checker.src/tree.ml +++ b/perl_checker.src/tree.ml @@ -115,7 +115,7 @@ let get_exported t = match v with | List [ List l ] -> List.map (function - | Ident(None, tag, _), Ref(I_array, List [List [v]]) -> + | Raw_string(tag, _), Ref(I_array, List [List [v]]) -> let para = match v with | Deref(I_array, Ident(None, "EXPORT_OK", _)) -> exports.export_ok @@ -129,7 +129,7 @@ let get_exported t = if exports.export_tags <> [] then warn_with_pos pos "weird, %EXPORT_TAGS set twice" ; { exports with export_tags = export_tags } with _ -> - warn_with_pos pos "unrecognised @EXPORT_TAGS" ; + warn_with_pos pos "unrecognised %EXPORT_TAGS" ; exports) | List (My_our _ :: _) -> let _,_ = e,e in @@ -138,7 +138,8 @@ let get_exported t = ) empty_exports t let uses_external_package = function - | "vars" | "Exporter" | "diagnostics" | "strict" | "lib" | "POSIX" | "Config" | "Socket" | "Net::FTP" | "IO::Socket" | "DynaLoader" -> true + | "vars" | "MDK::Common::Globals" | "Exporter" | "diagnostics" | "strict" | "lib" | "POSIX" + | "Config" | "Socket" | "Net::FTP" | "IO::Socket" | "DynaLoader" -> true | _ -> false let get_uses t = @@ -172,8 +173,11 @@ let get_global_vars_declaration state package = Hashtbl.add state.global_vars_declared (I_func, some_or fq package.package_name, name) pos | List [ Call_op("=", [My_our("our", ours, pos); _]) ] + | List [ My_our("our", ours, pos) ] | My_our("our", ours, pos) -> List.iter (fun (context, name) -> Hashtbl.add state.global_vars_declared (context, package.package_name, name) pos) ours + + | Use(Ident(Some "MDK::Common", "Globals", pos), [ String _ ; ours ]) | Use(Ident(None, "vars", pos), [ours]) -> List.iter (fun (context, name) -> Hashtbl.add state.global_vars_declared (context, package.package_name, name) pos) (from_qw ours) | Use(Ident(None, "vars", pos), _) -> @@ -188,10 +192,12 @@ let get_imports state package = let exports = package_used.exports in let imports_vars = match imports with - | None -> - if exports.re_export_all then - collect (fun (package_name, _) -> (List.assoc package_name state.per_package).exports.export_ok) package_used.uses - else exports.export_auto + | None -> + let re = + if exports.re_export_all + then collect (fun (package_name, _) -> (List.assoc package_name state.per_package).exports.export_ok) package_used.uses + else [] in + exports.export_auto @ re | Some l -> collect (function | I_raw, tag -> @@ -205,7 +211,7 @@ let get_imports state package = 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.package_name) imports_vars + List.map (fun (context, name) -> (context, name), package_name) imports_vars with Not_found -> [] in collect get_one package.uses @@ -218,7 +224,6 @@ let rec fold_tree f env e = | Anonymous_sub(e') | Ref(_, e') | Deref(_, e') - | Package(e') -> fold_tree f env e' | Diamond(e') @@ -232,6 +237,7 @@ let rec fold_tree f env e = let env = fold_tree f env e2 in env + | Use(_, l) | List l | Block l | Call_op(_, l) @@ -239,7 +245,6 @@ let rec fold_tree f env e = | Call(e', l) | CallP(e', l) - | Use(e', l) -> let env = fold_tree f env e' in List.fold_left (fold_tree f) env l @@ -282,7 +287,7 @@ let is_global_var context ident = | _ -> false) | I_array -> (match ident with - | "_" | "ARGV" -> true + | "_" | "ARGV" | "INC" -> true | _ -> false) | I_hash -> (match ident with @@ -290,7 +295,8 @@ let is_global_var context ident = | _ -> false) | I_star -> (match ident with - | "STDIN" | "STDOUT" | "STDERR" -> true + | "STDIN" | "STDOUT" | "STDERR" + | "__FILE__" | "__LINE__" | "undef" -> true | _ -> false) | I_func -> (match ident with @@ -386,6 +392,10 @@ let check_variables vars t = let vars = check_variables_ vars body in Some vars + | Ident _ as var -> + check_variable (I_star, var) vars ; + Some vars + | My_our(my_or_our, mys, pos) -> Some(declare_My_our vars (my_or_our, mys, pos)) | Deref(context, (Ident _ as var)) -> check_variable (context, var) vars ; |