summaryrefslogtreecommitdiffstats
path: root/perl_checker.src
diff options
context:
space:
mode:
Diffstat (limited to 'perl_checker.src')
-rw-r--r--perl_checker.src/lexer.mll29
-rw-r--r--perl_checker.src/parser.mly28
-rw-r--r--perl_checker.src/parser_helper.ml143
-rw-r--r--perl_checker.src/parser_helper.mli14
-rw-r--r--perl_checker.src/perl_checker.ml2
-rw-r--r--perl_checker.src/tree.ml34
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 ;
generated by cgit v1.2.1 (git 2.21.0) at 2024-11-27 00:11:11 +0000