handle "format" perl instruction

3 files changed, 42 insertions, 22 deletions

diff --git a/perl_checker.src/global_checks.ml b/perl_checker.src/global_checks.ml
index 6160590..92a0332 100644
--- a/perl_checker.src/global_checks.ml
+++ b/perl_checker.src/global_checks.ml
@@ -20,6 +20,7 @@ type vars = {
     required_vars : (context * string * string) list ;
     current_package : per_package ;
     is_toplevel : bool ;
+    write_only : bool ;
     state : state ;
   }
 
@@ -105,36 +106,39 @@ let is_anonymous_variable_name s = String.length s > 1 && s.[0] = '_'
 
 let is_my_declared vars t = 
   List.exists (fun l ->
-    List.mem_assoc t l && (snd3 (List.assoc t l) := true ; true)
+    List.mem_assoc t l && (if not vars.write_only then snd3 (List.assoc t l) := true ; true)
   ) vars.my_vars
 let is_our_declared vars t = 
   List.exists (fun l ->
-    List.mem_assoc t l && (snd3 (List.assoc t l) := true ; true)
+    List.mem_assoc t l && (if not vars.write_only then snd3 (List.assoc t l) := true ; true)
   ) vars.our_vars
 
-let is_var_declared_and_set state package var para =
-  try
-    let (_, used, proto) = Hashtbl.find package.vars_declared var in
-    check_para_comply_with_prototype para proto ;
-    used := true ; 
-    true
-  with Not_found -> 
+let is_var_declared_raw write_only state package var para =
+  match 
     try
-      let (_, used, proto) = List.assoc var (get_imports state package) in
+      let _, used, proto = Hashtbl.find package.vars_declared var in
+      Some(used, proto)
+    with Not_found -> try
+      let _, used, proto = List.assoc var (get_imports state package) in
+      Some(used, proto)
+    with Not_found ->
+      None
+  with 
+  | Some (used, proto) ->
       check_para_comply_with_prototype para proto ;
-      used := true ; 
+      if not write_only then used := true ; 
       true
-    with Not_found ->
+  | None ->
       false
 
 let is_var_declared vars var para = 
   List.mem_assoc var vars.locally_imported ||
-  is_var_declared_and_set vars.state vars.current_package var para
+  is_var_declared_raw vars.write_only vars.state vars.current_package var para
 
 let is_global_var_declared vars (context, fq, name) para =
   try
     let package = Hashtbl.find vars.state.per_packages fq in
-    is_var_declared_and_set vars.state package (context, name) para
+    is_var_declared_raw vars.write_only vars.state package (context, name) para
   with Not_found -> false
  
 
@@ -290,6 +294,8 @@ let check_variables vars t =
 	let vars = List.fold_left check_variables_ vars para in
 	Some vars
 
+(*    | Call_op("=", -> List.fold_left (fold_tree f) env l*)
+
     | Call_op("while infix", [ expr ; (List [ Call_op("<>", _, _) ] as l) ], pos)
     | Call_op("for infix", [ expr ; l ], pos) ->
 	let vars = check_variables_ vars l in
@@ -377,6 +383,20 @@ let check_variables vars t =
 	if op <> "=" then warn_with_pos pos (sprintf "applying %s on a new initialized variable is wrong" op);
 	None
 
+    | Call_op("=", [ Deref(context, (Ident _ as var)) ; para], _) ->
+	check_variable (context, var) { vars with write_only = true } None ;
+	Some (check_variables_ vars para)
+
+    | Call_op("=", [ List [ List l ] ; para], _) ->
+	let vars = List.fold_left (fun vars -> function
+	  | Deref(context, (Ident _ as var)) ->
+	      check_variable (context, var) { vars with write_only = true } None ;
+	      vars
+	  | e -> check_variables_ vars e
+	) vars l in
+	let vars = check_variables_ vars para in
+	Some vars
+
     | Method_call(Raw_string(package_name, pos), Raw_string ("import", _), para) ->
 	let args =
 	  match para with
@@ -434,7 +454,7 @@ let check_variables vars t =
   vars
 
 let check_tree state package =
-  let vars = { my_vars = [[]]; our_vars = []; locally_imported = []; required_vars = []; current_package = package; state = state; is_toplevel = true } in
+  let vars = { my_vars = [[]]; our_vars = []; locally_imported = []; required_vars = []; current_package = package; state = state; is_toplevel = true; write_only = false } in
   if !Flags.verbose then print_endline_flush_always ("checking package " ^ package.package_name) ;
   let vars = check_variables vars package.body in
   check_unused_local_variables vars ;
diff --git a/perl_checker.src/lexer.mll b/perl_checker.src/lexer.mll
index 27c793a..3cae1cf 100644
--- a/perl_checker.src/lexer.mll
+++ b/perl_checker.src/lexer.mll
@@ -31,6 +31,7 @@ type raw_token =
   | COMPACT_HASH_SUBSCRIPT of (string * raw_pos)
   | RAW_HERE_DOC of ((string * raw_pos) ref * raw_pos)
   | HERE_DOC of (raw_interpolated_string * raw_pos) ref * raw_pos
+  | FORMAT of (raw_interpolated_string * raw_pos) ref * raw_pos
   | SCALAR_IDENT of (string option * string * raw_pos)
   | ARRAY_IDENT of (string option * string * raw_pos)
   | HASH_IDENT of (string option * string * raw_pos)
@@ -44,7 +45,7 @@ type raw_token =
 
   | IF of raw_pos | ELSIF of raw_pos | ELSE of raw_pos | UNLESS of raw_pos | DO of raw_pos | WHILE of raw_pos | UNTIL of raw_pos | MY_OUR of (string * raw_pos) | CONTINUE of raw_pos | SUB of raw_pos
   | LOCAL of raw_pos | FOR of (string * raw_pos) | USE of raw_pos | PACKAGE of raw_pos | BEGIN of raw_pos | END of raw_pos | PRINT of (string * raw_pos) 
-  | NEW of (raw_pos) | FORMAT of (raw_pos) | AT of raw_pos | DOLLAR of raw_pos | PERCENT of raw_pos | AMPERSAND of raw_pos
+  | NEW of (raw_pos) | AT of raw_pos | DOLLAR of raw_pos | PERCENT of raw_pos | AMPERSAND of raw_pos
   | STAR of raw_pos | ARRAYLEN of raw_pos | SEMI_COLON of raw_pos | PKG_SCOPE of raw_pos | PAREN of raw_pos | PAREN_END of raw_pos | BRACKET of raw_pos
   | BRACKET_END of raw_pos | BRACKET_HASHREF of raw_pos | ARRAYREF of raw_pos | ARRAYREF_END of raw_pos | ARROW of raw_pos | INCR of raw_pos | DECR of raw_pos
   | CONCAT of raw_pos | POWER of raw_pos | TIGHT_NOT of raw_pos | BIT_NEG of raw_pos | REF of raw_pos | ONE_SCALAR_PARA of (string * raw_pos) | PATTERN_MATCH of raw_pos | PATTERN_MATCH_NOT of raw_pos | MULT of (string * raw_pos) | MULT_L_STR of raw_pos
@@ -77,6 +78,7 @@ let rec raw_token_to_pos_and_token spaces = function
   | PATTERN(s, opts, pos) -> pos, Parser.PATTERN(new_any M_special (raw_interpolated_string_to_tokens s, opts) spaces pos)
   | PATTERN_SUBST(from, to_, opts, pos) -> pos, Parser.PATTERN_SUBST(new_any M_special (raw_interpolated_string_to_tokens from, raw_interpolated_string_to_tokens to_, opts) spaces pos)
   | HERE_DOC(l, pos) -> pos, Parser.HERE_DOC(new_any M_string (raw_interpolated_string_to_tokens (fst !l), snd !l) spaces pos)
+  | FORMAT(l, pos) -> pos, Parser.FORMAT(new_any M_string (raw_interpolated_string_to_tokens (fst !l), snd !l) spaces pos)
   | BAREWORD(s, pos) -> pos, Parser.BAREWORD(new_any M_special s spaces pos)
   | BAREWORD_PAREN(s, pos) -> pos, Parser.BAREWORD_PAREN(new_any M_special s spaces pos)
   | REVISION(s, pos) -> pos, Parser.REVISION(new_any M_revision s spaces pos)
@@ -101,7 +103,6 @@ let rec raw_token_to_pos_and_token spaces = function
   | FUNC_DECL_WITH_PROTO(fq, name, proto, pos) -> pos, Parser.FUNC_DECL_WITH_PROTO(new_any M_special (fq, name, proto) spaces pos)
 
   | NEW(pos) -> pos, Parser.NEW(new_any M_special () spaces pos)
-  | FORMAT(pos) -> pos, Parser.FORMAT(new_any M_special () spaces pos)
   | COMPARE_OP(s, pos) -> pos, Parser.COMPARE_OP(new_any M_special s spaces pos)
   | COMPARE_OP_STR(s, pos) -> pos, Parser.COMPARE_OP_STR(new_any M_special s spaces pos)
   | EQ_OP(s, pos) -> pos, Parser.EQ_OP(new_any M_special s spaces pos)
@@ -491,7 +492,7 @@ rule token = parse
 | "print"    { PRINT(lexeme lexbuf, pos lexbuf) }
 | "printf"   { PRINT(lexeme lexbuf, pos lexbuf) }
 | "new"      { NEW(pos lexbuf) }
-| "format"   { let _ = raw_here_doc_next_line "." in FORMAT(pos lexbuf) }
+| "format"   { let pos = pos lexbuf in FORMAT(here_doc_next_line ".", pos) }
 | "defined"
 | "length" 
 | "keys" 
diff --git a/perl_checker.src/parser.mly b/perl_checker.src/parser.mly
index f9b5e9d..90e8631 100644
--- a/perl_checker.src/parser.mly
+++ b/perl_checker.src/parser.mly
@@ -17,7 +17,7 @@
 %token <string Types.any_spaces_pos> QUOTEWORDS COMPACT_HASH_SUBSCRIPT
 %token <(string * Types.raw_pos) Types.any_spaces_pos> RAW_HERE_DOC
 %token <(string * ((int * int) * token) list) list Types.any_spaces_pos> STRING COMMAND_STRING
-%token <((string * ((int * int) * token) list) list * Types.raw_pos) Types.any_spaces_pos> HERE_DOC
+%token <((string * ((int * int) * token) list) list * Types.raw_pos) Types.any_spaces_pos> HERE_DOC FORMAT
 
 %token <((string * ((int * int) * token) list) list * string) Types.any_spaces_pos> PATTERN QR_PATTERN
 %token <((string * ((int * int) * token) list) list * (string * ((int * int) * token) list) list * string) Types.any_spaces_pos> PATTERN_SUBST
@@ -27,7 +27,7 @@
 %token <(string option * string * string) Types.any_spaces_pos> FUNC_DECL_WITH_PROTO
 
 %token <string Types.any_spaces_pos> FOR PRINT
-%token <unit   Types.any_spaces_pos> NEW FORMAT
+%token <unit   Types.any_spaces_pos> NEW
 %token <string Types.any_spaces_pos> COMPARE_OP COMPARE_OP_STR EQ_OP EQ_OP_STR
 %token <string Types.any_spaces_pos> ASSIGN MY_OUR
 
@@ -154,7 +154,7 @@ sideff: /* An expression which may have a side-effect */
 | expr  FOR    expr {sp_p($2); sp_p($3); mcontext_check M_list $3; check_foreach($2); to_Call_op M_none "for infix"   [ prio_lo P_loose $1 ; prio_lo P_loose $3 ] $1 $3}
 
 decl:
-| FORMAT BAREWORD ASSIGN {new_esp M_none Too_complex $1 $3}
+| FORMAT BAREWORD ASSIGN {to_Call_op M_none "format" [Raw_string($2.any, get_pos $2) ; to_String false (new_1esp (fst $1.any) $1)] $1 $3}
 | FORMAT ASSIGN {new_esp M_none Too_complex $1 $2}
 | func_decl semi_colon {if snd $1.any = None then die_rule "there is no need to pre-declare in Perl!" else (warn_rule "please don't use prototype pre-declaration" ; new_esp M_special Too_complex $1 $2) }
 | func_decl BRACKET BRACKET_END {sp_n($2); sp_0_or_cr($3); let name, proto = $1.any in new_esp M_none (sub_declaration (name, proto) [] Real_sub_declaration) $1 $3}
@@ -458,7 +458,6 @@ word_or_scalar:
 
 bareword:
 | NEW { new_1esp (Ident(None, "new", get_pos $1)) $1 }
-| FORMAT { new_1esp (Ident(None, "format", get_pos $1)) $1 }
 | BAREWORD { new_1esp (Ident(None, $1.any, get_pos $1)) $1 }
 
 word_paren: