perl_checker: new --generate-pot feature

9 files changed, 91 insertions, 11 deletions

diff --git a/perl_checker.src/common.ml b/perl_checker.src/common.ml
index a938ffb..f84e027 100644
--- a/perl_checker.src/common.ml
+++ b/perl_checker.src/common.ml
@@ -692,6 +692,15 @@ let rec explode_string = function
   | "" -> []
   | s -> (String.get s 0) :: explode_string (String.sub s 1 (String.length s - 1))
 
+let count_matching_char s c =
+  let rec count_matching_char_ nb i =
+    try
+      let i' = String.index_from s i c in
+      count_matching_char_ (nb+1) (i'+1)
+    with Not_found -> nb
+  in
+  count_matching_char_ 0 0
+
 let is_uppercase c = Char.lowercase c <> c
 let is_lowercase c = Char.uppercase c <> c
 
diff --git a/perl_checker.src/common.mli b/perl_checker.src/common.mli
index 162b6bd..f3a66c7 100644
--- a/perl_checker.src/common.mli
+++ b/perl_checker.src/common.mli
@@ -187,6 +187,7 @@ val non_index : string -> char -> int
 val non_rindex_from : string -> int -> char -> int
 val non_rindex : string -> char -> int
 val explode_string : string -> char list
+val count_matching_char : string -> char -> int
 val is_uppercase : char -> bool
 val is_lowercase : char -> bool
 val char_is_alphanumerical : char -> bool
diff --git a/perl_checker.src/flags.ml b/perl_checker.src/flags.ml
index 5256831..6f0949b 100644
--- a/perl_checker.src/flags.ml
+++ b/perl_checker.src/flags.ml
@@ -2,3 +2,6 @@ open Common
 
 let verbose = ref false
 let quiet = ref false
+let generate_pot = ref false
+let expand_tabs = ref false
+
diff --git a/perl_checker.src/flags.mli b/perl_checker.src/flags.mli
index 9f17f55..81045b1 100644
--- a/perl_checker.src/flags.mli
+++ b/perl_checker.src/flags.mli
@@ -1,2 +1,4 @@
 val verbose : bool ref
 val quiet : bool ref
+val generate_pot : bool ref
+val expand_tabs : bool ref
diff --git a/perl_checker.src/lexer.mll b/perl_checker.src/lexer.mll
index 448d0c9..c9ce890 100644
--- a/perl_checker.src/lexer.mll
+++ b/perl_checker.src/lexer.mll
@@ -20,6 +20,7 @@ type raw_token =
   | BAREWORD_PAREN of (string * raw_pos)
   | REVISION of (string * raw_pos)
   | PERL_CHECKER_COMMENT of (string * raw_pos)
+  | PO_COMMENT of (string * raw_pos)
   | POD of (string * raw_pos)
   | LABEL of (string * raw_pos)
   | COMMAND_STRING of (raw_interpolated_string * raw_pos)
@@ -75,6 +76,7 @@ let rec raw_token_to_pos_and_token spaces = function
   | BAREWORD_PAREN(s, pos) -> pos, Parser.BAREWORD_PAREN(s, (spaces, pos))
   | REVISION(s, pos) -> pos, Parser.REVISION(s, (spaces, pos))
   | PERL_CHECKER_COMMENT(s, pos) -> pos, Parser.PERL_CHECKER_COMMENT(s, (spaces, pos))
+  | PO_COMMENT(s, pos) -> pos, Parser.PO_COMMENT(s, (spaces, pos))
   | POD(s, pos) -> pos, Parser.POD(s, (spaces, pos))
   | LABEL(s, pos) -> pos, Parser.LABEL(s, (spaces, pos))
   | PRINT(s, pos) -> pos, Parser.PRINT(s, (spaces, pos))
@@ -327,12 +329,13 @@ let ident = ident_start ['0'-'9' 'A'-'Z' 'a'-'z' '_'] *
 let pattern_separator = [ '/' '!' ',' '|' ]
 
 rule token = parse
-| ' '+ { 
+| [' ' '\t']+ { 
     (* propagate not_ok_for_match when it was set by the previous token *)
     if lexeme_start lexbuf = !not_ok_for_match then not_ok_for_match := lexeme_end lexbuf; 
     SPACE(lexeme_end lexbuf - lexeme_start lexbuf)
   }
 | "# perl_checker: " [^ '\n']* { PERL_CHECKER_COMMENT(skip_n_char 16 (lexeme lexbuf), pos lexbuf) }
+| "#-PO: " [^ '\n']* { PO_COMMENT(skip_n_char 1 (lexeme lexbuf), pos lexbuf) }
 | '#' [^ '\n']* { SPACE(1) }
 
 | "\n=" { 
@@ -623,7 +626,6 @@ and string = parse
     add_a_new_line(lexeme_end lexbuf);
     next string lexbuf
   }
-
 | [^ '\n' '\\' '"' '$' '@']+ { next string lexbuf }
 | eof { die_in_string lexbuf "Unterminated_string" }
 
@@ -716,6 +718,8 @@ and string_escape = parse
 | '0' { next_s "\000" (Stack.pop next_rule) lexbuf }
 | '"' { next_s "\"" (Stack.pop next_rule) lexbuf }
 | ''' { next_s "'"  (Stack.pop next_rule) lexbuf }
+| ':' { next_s ":"  (Stack.pop next_rule) lexbuf }
+| '\\'{ next_s "\\" (Stack.pop next_rule) lexbuf }
 | 'n' { next_s "\n" (Stack.pop next_rule) lexbuf }
 | 't' { next_s "\t" (Stack.pop next_rule) lexbuf }
 | 'x' _ _ { 
@@ -724,6 +728,7 @@ and string_escape = parse
     next_s s (Stack.pop next_rule) lexbuf 
   with Failure("int_of_string") -> die_in_string lexbuf ("Bad_hex_in_string \"" ^ lexeme lexbuf ^ "\"")
   }
+| '\n' { die lexbuf "do not use \"\\\" before end-of-line, it's useless and generally bad" }
 | _ { next_s ("\\" ^ lexeme lexbuf) (Stack.pop next_rule) lexbuf }
 
 
@@ -738,7 +743,8 @@ and string_interpolate_scalar = parse
 
 | "{"
 | ident "->"? '{'
-| eof { next_s "$" (Stack.pop next_rule) lexbuf }
+| '"' { putback lexbuf 1; next_s "$" (Stack.pop next_rule) lexbuf }
+| eof {                   next_s "$" (Stack.pop next_rule) lexbuf }
 | _ { warn lexbuf (Printf.sprintf "weird \"%s\" in string" (lexeme lexbuf)); next_s ("$" ^ lexeme lexbuf) (Stack.pop next_rule) lexbuf }
 
 and delimited_string_interpolate_scalar = parse (* needed for delimited string like m!foo$! where $! should not be taken as is... *)
@@ -772,8 +778,9 @@ and string_interpolate_array = parse
 | (ident | (ident? ("::" ident)+)) { string_interpolate token "@" lexbuf }
 
 | [ '@' '*' '<' '>' ']' '.' '('] { next_s ("@" ^ lexeme lexbuf) (Stack.pop next_rule) lexbuf }
-| eof { next_s "$" (Stack.pop next_rule) lexbuf }
-| _ { warn lexbuf (Printf.sprintf "weird \"%s\" in string" (lexeme lexbuf)); next_s ("$" ^ lexeme lexbuf) (Stack.pop next_rule) lexbuf }
+| '"' { putback lexbuf 1; next_s "@" (Stack.pop next_rule) lexbuf }
+| eof {                   next_s "@" (Stack.pop next_rule) lexbuf }
+| _ { warn lexbuf (Printf.sprintf "weird \"%s\" in string" (lexeme lexbuf)); next_s ("@" ^ lexeme lexbuf) (Stack.pop next_rule) lexbuf }
 
 and delimited_string_interpolate_array = parse
 | '$' ident
@@ -781,12 +788,12 @@ and delimited_string_interpolate_array = parse
 | (ident | (ident? ("::" ident)+)) { string_interpolate token "@" lexbuf }
 
 | [ '@' '*' '<' '>' ']' '.' '('] { next_s ("@" ^ lexeme lexbuf) (Stack.pop next_rule) lexbuf }
-| eof { next_s "$" (Stack.pop next_rule) lexbuf }
+| eof { next_s "@" (Stack.pop next_rule) lexbuf }
 | _ { 
     let c = lexeme_char lexbuf 0 in
     if c <> !delimit_char then warn lexbuf (Printf.sprintf "weird \"%s\" in string" (lexeme lexbuf));
     putback lexbuf 1;
-    next_s "$" (Stack.pop next_rule) lexbuf
+    next_s "@" (Stack.pop next_rule) lexbuf
   }
 
 and pattern_options = parse
diff --git a/perl_checker.src/parser.mly b/perl_checker.src/parser.mly
index a2e61dc..84655eb 100644
--- a/perl_checker.src/parser.mly
+++ b/perl_checker.src/parser.mly
@@ -12,7 +12,7 @@
 
 
 %token <unit   * (Types.spaces * Types.raw_pos)> EOF
-%token <string * (Types.spaces * Types.raw_pos)> NUM RAW_STRING BAREWORD BAREWORD_PAREN REVISION COMMENT POD LABEL PERL_CHECKER_COMMENT ONE_SCALAR_PARA
+%token <string * (Types.spaces * Types.raw_pos)> NUM RAW_STRING BAREWORD BAREWORD_PAREN REVISION COMMENT POD LABEL PO_COMMENT PERL_CHECKER_COMMENT ONE_SCALAR_PARA
 %token <(string * string) * (Types.spaces * Types.raw_pos)> PRINT_TO_STAR PRINT_TO_SCALAR
 %token <string * (Types.spaces * Types.raw_pos)> QUOTEWORDS COMPACT_HASH_SUBSCRIPT
 %token <(string * Types.raw_pos) * (Types.spaces * Types.raw_pos)> RAW_HERE_DOC
@@ -425,6 +425,8 @@ bareword:
 word_paren:
 | BAREWORD_PAREN { Ident(None, fst $1, get_pos $1), snd $1}
 | RAW_IDENT_PAREN { to_Ident $1, snd $1}
+| PO_COMMENT word_paren { po_comment($1); fst $2, sp_pos_range $1 $2 }
+
 
 arraylen: ARRAYLEN_IDENT {deref_arraylen (to_Ident $1), snd $1} | ARRAYLEN  scalar {sp_0($2); deref_arraylen (fst $2), snd $1} | ARRAYLEN  bracket_subscript {deref_arraylen (fst $2), sp_pos_range $1 $2}
 scalar:   SCALAR_IDENT   {Deref(I_scalar, to_Ident $1), snd $1} | DOLLAR    scalar {sp_0($2); Deref(I_scalar, fst $2), snd $1} | DOLLAR    bracket_subscript {Deref(I_scalar, fst $2), sp_pos_range $1 $2} | DOLLAR BRACKET BRACKET expr BRACKET_END BRACKET_END {sp_0($2); sp_0($3); sp_p($5); sp_0($6); Deref(I_scalar, Ref(I_hash, sndfst $4)), sp_pos_range $1 $6}
diff --git a/perl_checker.src/parser_helper.ml b/perl_checker.src/parser_helper.ml
index 7f723a6..e562d15 100644
--- a/perl_checker.src/parser_helper.ml
+++ b/perl_checker.src/parser_helper.ml
@@ -3,6 +3,9 @@ open Common
 open Printf
 
 let bpos = -1, -1
+let pot_strings = ref []
+let pot_strings_and_file = Hashtbl.create 16
+let po_comments = ref []
 
 let raw_pos2pos(a, b) = !Info.current_file, a, b
 let pos_range (_, (_, (a1, b1))) (_, (_, (a2, b2))) = raw_pos2pos((if a1 = -1 then a2 else a1), (if b2 = -1 then b1 else b2))
@@ -25,6 +28,7 @@ let is_parenthesized = function
 
 let un_parenthesize = function
   | List[List[e]] -> e
+  | List[e] -> e
   | _ -> internal_error "un_parenthesize"
 
 let rec un_parenthesize_full = function
@@ -484,7 +488,15 @@ let call_func is_a_func (e, para) =
 
       | "N" | "N_" ->
 	  (match para with
-	  | [ List(String([ _s, List [] ], _) :: _) ] -> None
+	  | [ List(String([ s, List [] ], (file, _, _)) :: _) ] -> 
+	      if !Flags.generate_pot then (
+		lpush pot_strings (s, !po_comments) ;
+		po_comments := [] ;
+		Hashtbl.add pot_strings_and_file s file ;
+	      ) ;
+	      (*if String.contains s '\t' then warn_rule "tabulation in translated string must be written \\\\t";*)
+	      (*if count_matching_char s '\n' > 10 then warn_rule "long string";*)
+	      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))
 
@@ -595,3 +607,30 @@ let from_PATTERN_SUBST parse ((s1, s2, opts), (_, pos)) =
   [ String(parse_interpolated parse s1, raw_pos2pos pos) ; 
     String(parse_interpolated parse s2, raw_pos2pos pos) ; 
     Raw_string(opts, raw_pos2pos pos) ]
+
+let po_comment (s, _) = lpush po_comments s
+
+let generate_pot file = 
+  let fd = open_out file in   
+  let rec print_formatted_char = function
+    | '"'  -> output_char fd '\\'; output_char fd '"'
+    | '\t' -> output_char fd '\\'; output_char fd 't'
+    | '\\' -> output_char fd '\\'; output_char fd '\\'
+    | '\n' -> output_string fd "\\n\"\n\""
+    | c -> output_char fd c
+  in
+  List.iter (fun (s, po_comments) ->
+    match Hashtbl.find_all pot_strings_and_file s with
+    | [] -> ()
+    | l ->
+	List.iter (fun po_comment -> output_string fd ("#. " ^ po_comment ^ "\n")) po_comments;
+
+	List.iter (fun _ -> Hashtbl.remove pot_strings_and_file s) l ;
+	fprintf fd "#: %s\n" (String.concat " " l) ;
+
+	output_string fd (if String.contains s '\n' then "msgid \"\"\n\"" else "msgid \"") ;
+	String.iter print_formatted_char s ;
+	output_string fd "\"\n" ;
+	output_string fd "msgstr \"\"\n\n"
+  ) !pot_strings ;      
+  close_out fd
diff --git a/perl_checker.src/parser_helper.mli b/perl_checker.src/parser_helper.mli
index d3a1028..d1aba18 100644
--- a/perl_checker.src/parser_helper.mli
+++ b/perl_checker.src/parser_helper.mli
@@ -1,4 +1,7 @@
 val bpos : int * int
+val pot_strings : (string * string list) list ref
+val pot_strings_and_file : (string, string) Hashtbl.t
+val po_comments : string list ref
 val raw_pos2pos : 'a * 'b -> string * 'a * 'b
 val pos_range :
   'a * ('b * (int * int)) -> 'c * ('d * (int * int)) -> string * int * int
@@ -162,3 +165,5 @@ val from_PATTERN_SUBST :
   ((string * ((int * int) * 'a) list) list *
    (string * ((int * int) * 'a) list) list * string) *
   ('b * (int * int)) -> Types.fromparser list
+val po_comment : string * 'a -> unit
+val generate_pot : string -> unit
diff --git a/perl_checker.src/perl_checker.ml b/perl_checker.src/perl_checker.ml
index 9d88c6c..eac011f 100644
--- a/perl_checker.src/perl_checker.ml
+++ b/perl_checker.src/perl_checker.ml
@@ -27,12 +27,12 @@ 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 print_endline_flush ("checking " ^ file) ;
-    let channel = Unix.open_process_in (Printf.sprintf "expand \"%s\"" file) in
+    let channel = Unix.open_process_in (Printf.sprintf "%s \"%s\"" (if !Flags.expand_tabs then "expand" else "cat") 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 _ = Unix.close_process_in channel in*)
       let t = Parser_helper.parse_tokens Parser.prog tokens (Some lexbuf) in
       let packages, required_packages = get_global_info_from_package t in
       List.fold_left (fun (required_packages, state) package ->
@@ -69,13 +69,22 @@ let rec parse_required_packages state = function
       let el, state = parse_package_if_needed state e in
       parse_required_packages state (el @ l)
 
+
 let parse_options =
   let args_r = ref [] in
   let restrict_to_files = ref false in
+
+  let pot_file = ref "" in
+  let generate_pot_chosen file =
+    Flags.generate_pot := true ;
+    Flags.expand_tabs := false ;
+    pot_file := file
+  in
   let options = [
     "-v", Arg.Set Flags.verbose, "  be verbose" ;
     "-q", Arg.Set Flags.quiet, "  be quiet" ;
     "--restrict-to-files", Arg.Set restrict_to_files, "  only display warnings concerning the file(s) given on command line" ;
+    "--generate-pot", Arg.String generate_pot_chosen, "" ;
   ] in
   let usage = "Usage: perl_checker [-v] [-q] <files>\nOptions are:" in
   Arg.parse options (lpush args_r) usage;
@@ -83,6 +92,8 @@ let parse_options =
   let files = if !args_r = [] then ["../t.pl"] else !args_r in
   let required_packages, state = collect_withenv parse_file default_state files in
 
+  if !Flags.generate_pot then Parser_helper.generate_pot !pot_file else (
+
   if !restrict_to_files then Common.print_endline_flush_quiet := true ;
   let state = parse_required_packages state required_packages in
   if !restrict_to_files then Common.print_endline_flush_quiet := false ;
@@ -94,3 +105,4 @@ let parse_options =
   let l = if !restrict_to_files then List.filter (fun pkg -> List.mem pkg.file_name files) l else l in
 
   List.iter (check_tree state) l
+  )