diff options
Diffstat (limited to 'perl_checker.src/lexer.mll')
| -rw-r--r-- | perl_checker.src/lexer.mll | 1057 |
1 files changed, 0 insertions, 1057 deletions
diff --git a/perl_checker.src/lexer.mll b/perl_checker.src/lexer.mll deleted file mode 100644 index f416499..0000000 --- a/perl_checker.src/lexer.mll +++ /dev/null @@ -1,1057 +0,0 @@ -{ (* -*- caml -*- *) -open Common -open Types -open Lexing -open Info - -let bpos = -1,-1 - -type raw_token = - | EOF of raw_pos - | SPACE of int - | CR - | INT of (string * raw_pos) - | FLOAT of (string * raw_pos) - | RAW_STRING of (string * raw_pos) - | STRING of (raw_interpolated_string * raw_pos) - | PATTERN of (raw_interpolated_string * string * raw_pos) - | QR_PATTERN of (raw_interpolated_string * string * raw_pos) - | PATTERN_SUBST of (raw_interpolated_string * raw_interpolated_string * string * raw_pos) - | BAREWORD of (string * raw_pos) - | 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) - | PRINT_TO_STAR of ((string * string) * raw_pos) - | PRINT_TO_SCALAR of ((string * string) * raw_pos) - | QUOTEWORDS of (string * raw_pos) - | 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) - | FUNC_IDENT of (string option * string * raw_pos) - | STAR_IDENT of (string option * string * raw_pos) - | RAW_IDENT of (string option * string * raw_pos) - | RAW_IDENT_PAREN of (string option * string * raw_pos) - | ARRAYLEN_IDENT of (string option * string * raw_pos) - | SUB_WITH_PROTO of (string * raw_pos) - | FUNC_DECL_WITH_PROTO of (string option * string * string * raw_pos) - - | 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) | 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 - | PLUS of (string * raw_pos) | BIT_SHIFT of (string * raw_pos) - | LT of raw_pos | GT of raw_pos | COMPARE_OP of (string * raw_pos) | COMPARE_OP_STR of (string * raw_pos) | EQ_OP of (string * raw_pos) | EQ_OP_STR of (string * raw_pos) - | BIT_AND of raw_pos | BIT_OR of raw_pos | BIT_XOR of raw_pos | AND_TIGHT of raw_pos | OR_TIGHT of raw_pos | DOTDOT of (string * raw_pos) - | QUESTION_MARK of raw_pos | COLON of raw_pos | ASSIGN of (string * raw_pos) | COMMA of raw_pos | RIGHT_ARROW of raw_pos | NOT of raw_pos | AND of raw_pos | OR of raw_pos | XOR of raw_pos - -and raw_interpolated_string = (string * raw_token list) list - -let new_any mcontext any spaces pos = { mcontext = mcontext ; any = any ; spaces = spaces ; pos = pos } - -let pos lexbuf = lexeme_start lexbuf, lexeme_end lexbuf -let pos2sfull_with start end_ = Info.pos2sfull (!current_file, start, end_) -let pos2sfull lexbuf = pos2sfull_with (lexeme_start lexbuf) (lexeme_end lexbuf) - -let warn_with_pos warn_types (start, end_) err = if Flags.are_warning_types_set warn_types then print_endline_flush (pos2sfull_with start end_ ^ err) -let warn warn_types lexbuf err = warn_with_pos warn_types (pos lexbuf) err -let die lexbuf err = failwith (pos2sfull_with (lexeme_start lexbuf) (lexeme_end lexbuf) ^ err) - -let rec concat_bareword_paren accu = function - | PRINT(s, pos1) :: PAREN(pos2) :: l - | BAREWORD(s, pos1) :: PAREN(pos2) :: l -> - concat_bareword_paren (PAREN(pos2) :: BAREWORD_PAREN(s, pos1) :: accu) l - | RAW_IDENT(kind, ident, pos1) :: PAREN(pos2) :: l -> - concat_bareword_paren (PAREN(pos2) :: RAW_IDENT_PAREN(kind, ident, pos1) :: accu) l - | PO_COMMENT(_, pos) as e :: l -> - let l = drop_while (function CR | SPACE _ -> true | _ -> false) l in - (match l with - | PO_COMMENT _ :: _ - (* the check will be done on this PO_COMMENT *) - | BAREWORD("N", _) :: PAREN(_) :: _ - | BAREWORD("N_", _) :: PAREN(_) :: _ -> - concat_bareword_paren (e :: accu) l - | _ -> - warn_with_pos [Warn_MDK_Common] pos "N(...) must follow the #-PO: comment, with nothing in between" ; - concat_bareword_paren accu l) - | [] -> List.rev accu - | e :: l -> - concat_bareword_paren (e :: accu) l - -let rec bracket_bareword_is_hashref accu = function - | (pos, Parser.BRACKET bracket) :: (_, Parser.BAREWORD _ as bareword) :: (_, Parser.RIGHT_ARROW _ as right_arrow) :: l -> - bracket_bareword_is_hashref (right_arrow :: bareword :: (pos, Parser.BRACKET_HASHREF bracket) :: accu) l - | [] -> List.rev accu - | e :: l -> - bracket_bareword_is_hashref (e :: accu) l - - -let rec raw_token_to_pos_and_token spaces = function - | INT(s, pos) -> pos, Parser.NUM(new_any M_int s spaces pos) - | FLOAT(s, pos) -> pos, Parser.NUM(new_any M_float s spaces pos) - | RAW_STRING(s, pos) -> pos, Parser.RAW_STRING(new_any M_string s spaces pos) - | RAW_HERE_DOC(r, pos) -> pos, Parser.RAW_HERE_DOC(new_any M_string !r spaces pos) - | STRING(l, pos) -> pos, Parser.STRING(new_any M_string (raw_interpolated_string_to_tokens l) spaces pos) - | COMMAND_STRING(l, pos) -> pos, Parser.COMMAND_STRING(new_any (M_mixed [M_string; M_array]) (raw_interpolated_string_to_tokens l) spaces pos) - | QR_PATTERN(s, opts, pos) -> pos, Parser.QR_PATTERN(new_any M_special (raw_interpolated_string_to_tokens s, opts) spaces pos) - | 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) - | PERL_CHECKER_COMMENT(s, pos) -> pos, Parser.PERL_CHECKER_COMMENT(new_any M_none s spaces pos) - | PO_COMMENT(s, pos) -> pos, Parser.PO_COMMENT(new_any M_special s spaces pos) - | POD(s, pos) -> pos, Parser.POD(new_any M_special s spaces pos) - | LABEL(s, pos) -> pos, Parser.LABEL(new_any M_none s spaces pos) - | PRINT(s, pos) -> pos, Parser.PRINT(new_any M_special s spaces pos) - | PRINT_TO_STAR(s, pos) -> pos, Parser.PRINT_TO_STAR(new_any M_special s spaces pos) - | PRINT_TO_SCALAR(s, pos) -> pos, Parser.PRINT_TO_SCALAR(new_any M_special s spaces pos) - | QUOTEWORDS(s, pos) -> pos, Parser.QUOTEWORDS(new_any M_array s spaces pos) - | COMPACT_HASH_SUBSCRIPT(s, pos) -> pos, Parser.COMPACT_HASH_SUBSCRIPT(new_any M_special s spaces pos) - | SCALAR_IDENT(kind, name, pos) -> pos, Parser.SCALAR_IDENT(new_any M_special (kind, name) spaces pos) - | ARRAY_IDENT(kind, name, pos) -> pos, Parser.ARRAY_IDENT(new_any M_special (kind, name) spaces pos) - | HASH_IDENT(kind, name, pos) -> pos, Parser.HASH_IDENT(new_any M_special (kind, name) spaces pos) - | FUNC_IDENT(kind, name, pos) -> pos, Parser.FUNC_IDENT(new_any M_special (kind, name) spaces pos) - | STAR_IDENT(kind, name, pos) -> pos, Parser.STAR_IDENT(new_any M_special (kind, name) spaces pos) - | RAW_IDENT(kind, name, pos) -> pos, Parser.RAW_IDENT(new_any M_special (kind, name) spaces pos) - | RAW_IDENT_PAREN(kind, name, pos) -> pos, Parser.RAW_IDENT_PAREN(new_any M_special (kind, name) spaces pos) - | ARRAYLEN_IDENT(kind, name, pos) -> pos, Parser.ARRAYLEN_IDENT(new_any M_special (kind, name) spaces pos) - | SUB_WITH_PROTO(proto, pos) -> pos, Parser.SUB_WITH_PROTO(new_any M_special proto spaces pos) - | 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) - | 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) - | EQ_OP_STR(s, pos) -> pos, Parser.EQ_OP_STR(new_any M_special s spaces pos) - | ASSIGN(s, pos) -> pos, Parser.ASSIGN(new_any M_special s spaces pos) - | FOR(s, pos) -> pos, Parser.FOR(new_any M_special s spaces pos) - - | DOTDOT(s, pos) -> pos, Parser.DOTDOT(new_any M_special s spaces pos) - | MULT(s, pos) -> pos, Parser.MULT(new_any M_special s spaces pos) - | BIT_SHIFT(s, pos) -> pos, Parser.BIT_SHIFT(new_any M_special s spaces pos) - | PLUS(s, pos) -> pos, Parser.PLUS(new_any M_special s spaces pos) - | ONE_SCALAR_PARA(s, pos) -> pos, Parser.ONE_SCALAR_PARA(new_any M_special s spaces pos) - | MY_OUR(s, pos) -> pos, Parser.MY_OUR(new_any M_special s spaces pos) - - | EOF (pos) -> pos, Parser.EOF (new_any M_special () spaces pos) - | IF (pos) -> pos, Parser.IF (new_any M_special () spaces pos) - | ELSIF (pos) -> pos, Parser.ELSIF (new_any M_special () spaces pos) - | ELSE (pos) -> pos, Parser.ELSE (new_any M_special () spaces pos) - | UNLESS (pos) -> pos, Parser.UNLESS (new_any M_special () spaces pos) - | DO (pos) -> pos, Parser.DO (new_any M_special () spaces pos) - | WHILE (pos) -> pos, Parser.WHILE (new_any M_special () spaces pos) - | UNTIL (pos) -> pos, Parser.UNTIL (new_any M_special () spaces pos) - | CONTINUE (pos) -> pos, Parser.CONTINUE (new_any M_special () spaces pos) - | SUB (pos) -> pos, Parser.SUB (new_any M_special () spaces pos) - | LOCAL (pos) -> pos, Parser.LOCAL (new_any M_special () spaces pos) - | USE (pos) -> pos, Parser.USE (new_any M_special () spaces pos) - | PACKAGE (pos) -> pos, Parser.PACKAGE (new_any M_special () spaces pos) - | BEGIN (pos) -> pos, Parser.BEGIN (new_any M_special () spaces pos) - | END (pos) -> pos, Parser.END (new_any M_special () spaces pos) - | AT (pos) -> pos, Parser.AT (new_any M_special () spaces pos) - | DOLLAR (pos) -> pos, Parser.DOLLAR (new_any M_special () spaces pos) - | PERCENT (pos) -> pos, Parser.PERCENT (new_any M_special () spaces pos) - | AMPERSAND (pos) -> pos, Parser.AMPERSAND (new_any M_special () spaces pos) - | STAR (pos) -> pos, Parser.STAR (new_any M_special () spaces pos) - | ARRAYLEN (pos) -> pos, Parser.ARRAYLEN (new_any M_special () spaces pos) - | SEMI_COLON (pos) -> pos, Parser.SEMI_COLON (new_any M_none () spaces pos) - | PKG_SCOPE (pos) -> pos, Parser.PKG_SCOPE (new_any M_special () spaces pos) - | PAREN (pos) -> pos, Parser.PAREN (new_any M_special () spaces pos) - | PAREN_END (pos) -> pos, Parser.PAREN_END (new_any M_special () spaces pos) - | BRACKET (pos) -> pos, Parser.BRACKET (new_any M_special () spaces pos) - | BRACKET_END (pos) -> pos, Parser.BRACKET_END (new_any M_special () spaces pos) - | BRACKET_HASHREF (pos) -> pos, Parser.BRACKET_HASHREF (new_any M_special () spaces pos) - | ARRAYREF (pos) -> pos, Parser.ARRAYREF (new_any M_special () spaces pos) - | ARRAYREF_END (pos) -> pos, Parser.ARRAYREF_END (new_any M_special () spaces pos) - | ARROW (pos) -> pos, Parser.ARROW (new_any M_special () spaces pos) - | INCR (pos) -> pos, Parser.INCR (new_any M_special () spaces pos) - | DECR (pos) -> pos, Parser.DECR (new_any M_special () spaces pos) - | POWER (pos) -> pos, Parser.POWER (new_any M_special () spaces pos) - | TIGHT_NOT (pos) -> pos, Parser.TIGHT_NOT (new_any M_special () spaces pos) - | BIT_NEG (pos) -> pos, Parser.BIT_NEG (new_any M_special () spaces pos) - | REF (pos) -> pos, Parser.REF (new_any M_special () spaces pos) - | PATTERN_MATCH (pos) -> pos, Parser.PATTERN_MATCH (new_any M_special () spaces pos) - | PATTERN_MATCH_NOT(pos) -> pos, Parser.PATTERN_MATCH_NOT(new_any M_special () spaces pos) - | LT (pos) -> pos, Parser.LT (new_any M_special () spaces pos) - | GT (pos) -> pos, Parser.GT (new_any M_special () spaces pos) - | BIT_AND (pos) -> pos, Parser.BIT_AND (new_any M_special () spaces pos) - | BIT_OR (pos) -> pos, Parser.BIT_OR (new_any M_special () spaces pos) - | BIT_XOR (pos) -> pos, Parser.BIT_XOR (new_any M_special () spaces pos) - | AND_TIGHT (pos) -> pos, Parser.AND_TIGHT (new_any M_special () spaces pos) - | OR_TIGHT (pos) -> pos, Parser.OR_TIGHT (new_any M_special () spaces pos) - | QUESTION_MARK (pos) -> pos, Parser.QUESTION_MARK (new_any M_special () spaces pos) - | COLON (pos) -> pos, Parser.COLON (new_any M_special () spaces pos) - | COMMA (pos) -> pos, Parser.COMMA (new_any M_special () spaces pos) - | CONCAT (pos) -> pos, Parser.CONCAT (new_any M_special () spaces pos) - | MULT_L_STR (pos) -> pos, Parser.MULT_L_STR (new_any M_special () spaces pos) - | RIGHT_ARROW (pos) -> pos, Parser.RIGHT_ARROW (new_any M_special () spaces pos) - | NOT (pos) -> pos, Parser.NOT (new_any M_special () spaces pos) - | AND (pos) -> pos, Parser.AND (new_any M_special () spaces pos) - | OR (pos) -> pos, Parser.OR (new_any M_special () spaces pos) - | XOR (pos) -> pos, Parser.XOR (new_any M_special () spaces pos) - - | SPACE _ | CR -> internal_error "raw_token_to_token" - -and raw_token_to_token spaces raw_token = - let _, token = raw_token_to_pos_and_token spaces raw_token in - token - -and raw_interpolated_string_to_tokens l = - List.map (fun (s, rtok) -> s, concat_spaces [] Space_0 rtok) l - -and concat_spaces ret spaces = function - | CR :: l -> concat_spaces ret Space_cr l - | SPACE n :: l -> - let spaces' = - match spaces with - | Space_cr -> Space_cr - | Space_0 -> if n = 1 then Space_1 else Space_n - | _ -> Space_n - in - concat_spaces ret spaces' l - | [] -> List.rev ret - | token :: l -> concat_spaces (raw_token_to_pos_and_token spaces token :: ret) Space_0 l - -let rec lexbuf2list accu t lexbuf = - match t lexbuf with - | EOF pos -> List.rev (EOF pos :: accu) - | e -> lexbuf2list (e :: accu) t lexbuf - -let get_token token lexbuf = - let tokens = lexbuf2list [] token lexbuf in - let tokens = concat_bareword_paren [] tokens in - let tokens = concat_spaces [] Space_0 tokens in - let tokens = bracket_bareword_is_hashref [] tokens in - tokens - -let next_rule = Stack.create() - - -let putback lexbuf nb = lexbuf.Lexing.lex_curr_pos <- lexbuf.Lexing.lex_curr_pos - nb - -let add_a_new_line raw_pos = - incr current_file_current_line ; - lpush current_file_lines_starts raw_pos - -let here_docs = Queue.create() -let raw_here_docs = Queue.create() -let current_here_doc_mark = ref "" - -let here_doc_next_line mark = - let here_doc_ref = ref([], bpos) in - Queue.push (mark, here_doc_ref) here_docs ; - here_doc_ref -let raw_here_doc_next_line mark = - let here_doc_ref = ref("", bpos) in - Queue.push (mark, here_doc_ref) raw_here_docs ; - here_doc_ref - -let delimit_char = ref '/' -let delimit_char_open = ref '(' -let delimit_char_close = ref ')' -type string_escape_kinds = Double_quote | Qq | Delimited | Here_doc -let string_escape_kind = ref Double_quote -let string_quote_escape = ref false -let string_escape_useful = ref (Left false) -let not_ok_for_match = ref (-1) -let string_nestness = ref 0 -let string_is_i18n = ref false - -let building_current_interpolated_string = Stack.create() -let building_current_string = Stack.create() -let current_string_start_pos = ref 0 -let current_string_start_line = ref 0 - -let die_in_string lexbuf err = failwith (pos2sfull_with !current_string_start_pos (lexeme_end lexbuf) ^ err) -let warn_escape_unneeded lexbuf c = - let s = String.make 1 c in warn [Warn_suggest_simpler] lexbuf ("you can replace \\" ^ s ^ " with " ^ s) -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 ins t lexbuf = - Stack.push (Queue.create()) building_current_interpolated_string ; - Stack.push (ref "") building_current_string; - current_string_start_pos := lexeme_start lexbuf; - 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 = - string_escape_useful := Left false ; - string_quote_escape := false ; - let s, pos = ins t lexbuf in - - if not !string_is_i18n then - (match !string_escape_useful, s with - | Right c, [ _, [] ] -> - let s = String.make 1 c in - warn_with_pos [Warn_suggest_simpler] pos ("you can replace \"xxx\\" ^ s ^ "xxx\" with 'xxx" ^ s ^ "xxx', that way you don't need to escape <" ^ s ^ ">") - | _ -> - if !string_quote_escape then - let full_s = String.concat "" (List.map fst s) in - let nb = string_fold_left (fun nb c -> - if nb < 0 then nb else - if c = '(' then nb + 1 else - if c = ')' then nb - 1 else nb - ) 0 full_s in - if nb = 0 then - warn_with_pos [Warn_suggest_simpler] pos "you can replace \"xxx\\\"xxx\" with qq(xxx\"xxx), that way you don't need to escape <\">" - ); - - not_ok_for_match := lexeme_end lexbuf; - string_is_i18n := false ; - STRING(s, pos) - -let next_s s t lexbuf = - let r = Stack.top building_current_string in r := !r ^ s ; - t lexbuf -let next t lexbuf = next_s (lexeme lexbuf) t lexbuf - -let ins_re re_delimited_string lexbuf = - let s, pos = ins re_delimited_string lexbuf in - List.iter (fun (s, _) -> - if str_contains s "[^\\s]" then warn [Warn_suggest_simpler] lexbuf "you can replace [^\\s] with \\S"; - if str_contains s "[^\\w]" then warn [Warn_suggest_simpler] lexbuf "you can replace [^\\w] with \\W" - ) s ; - s, pos - -let string_interpolate token pre lexbuf = - let s = lexeme lexbuf in - let local_lexbuf = Lexing.from_string (pre ^ s ^ " ") in (* add a space to help tokenizing "xxx$$" *) - local_lexbuf.lex_start_p <- lexbuf.lex_start_p ; - local_lexbuf.lex_curr_p <- lexbuf.lex_start_p ; - local_lexbuf.lex_abs_pos <- lexeme_start lexbuf ; - let l = lexbuf2list [] token local_lexbuf in - let l = concat_bareword_paren [] l in - next_interpolated l; - (Stack.pop next_rule) lexbuf - -let ident_type_from_char fq name lexbuf c = - not_ok_for_match := lexeme_end lexbuf; - match c with - | '$' -> SCALAR_IDENT(fq, name, pos lexbuf) - | '@' -> ARRAY_IDENT (fq, name, pos lexbuf) - | '%' -> HASH_IDENT (fq, name, pos lexbuf) - | '&' -> FUNC_IDENT (fq, name, pos lexbuf) - | '*' -> STAR_IDENT (fq, name, pos lexbuf) - | _ -> internal_error "ident_type_from_char" - -let split_at_two_colons s = - let i_fq = String.rindex s ':' in - String.sub s 0 (i_fq - 1), skip_n_char (i_fq + 1) s - -let ident_from_lexbuf lexbuf = - let fq, name = split_at_two_colons (lexeme lexbuf) in - RAW_IDENT(Some fq, name, pos lexbuf) - -let typed_ident_from_lexbuf lexbuf = - let s = lexeme lexbuf in - ident_type_from_char None (skip_n_char 1 s) lexbuf s.[0] - -let typed_fqident_from_lexbuf lexbuf = - let s = lexeme lexbuf in - let fq, name = split_at_two_colons (skip_n_char 1 s) in - ident_type_from_char (Some fq) name lexbuf s.[0] - -let arraylen_ident_from_lexbuf lexbuf = - not_ok_for_match := lexeme_end lexbuf; - let s = lexeme lexbuf in - ARRAYLEN_IDENT(None, skip_n_char 2 s, pos lexbuf) - -let arraylen_fqident_from_lexbuf lexbuf = - let s = lexeme lexbuf in - let fq, name = split_at_two_colons (skip_n_char 2 s) in - ARRAYLEN_IDENT(Some fq, name, pos lexbuf) - -let check_multi_line_delimited_string opts (start, end_) = - let check = - match opts with - | None -> true - | Some s -> not (String.contains s 'x') in - if check then - if !current_file_current_line <> !current_string_start_line then - failwith (pos2sfull_with start end_ ^ "multi-line patterns are not allowed (or use /x modifier)") - -let hex_in_string lexbuf next_rule s = - let i = - try int_of_string ("0x" ^ s) - with Failure("int_of_string") -> die_in_string lexbuf ("Bad_hex_in_string \"" ^ lexeme lexbuf ^ "\"") - in - let s = - if i < 256 then - String.make 1 (Char.chr i) - else - "\\x{" ^ s ^ "}" in - next_s s (Stack.pop next_rule) lexbuf - -let set_delimit_char lexbuf op = - let c = lexeme_char lexbuf (String.length op) in - delimit_char := c; - match c with - | '@' -> warn [Warn_complex_expressions] lexbuf ("don't use " ^ op ^ "@...@, replace @ with / ! , or |") - | ':' -> warn [Warn_complex_expressions] lexbuf ("don't use " ^ op ^ ":...:, replace : with / ! , or |") - | _ -> () - -let set_delimit_char_open lexbuf op = - let char_open = lexeme_char lexbuf (String.length op) in - let char_close = - match char_open with - | '(' -> ')' - | '{' -> '}' - | _ -> internal_error "set_delimit_char_open" - in - if op = "qx" then - warn [Warn_complex_expressions] lexbuf (Printf.sprintf "don't use qx%c...%c, use `...` instead" char_open char_close) - else if char_open = '{' then - warn [Warn_complex_expressions] lexbuf ("don't use " ^ op ^ "{...}, use " ^ op ^ "(...) instead"); - delimit_char_open := char_open; - delimit_char_close := char_close -} - -let stash = [ '$' '@' '%' '&' '*' ] -let ident_start = ['a'-'z' 'A'-'Z' '_'] -let ident = ident_start ['0'-'9' 'A'-'Z' 'a'-'z' '_'] * -let pattern_separator = [ '/' '!' ',' '|' '@' ':' ] -let pattern_open = [ '(' '{' ] -let pattern_close = [ ')' '}' ] - -let in_string_expr = (ident | (ident? ("::" ident)+)) "->"? (('{' [^ '{' '}' '\n']* '}') | ('[' [^ '[' ']' '\n']* ']'))* - -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=" { - add_a_new_line(lexeme_end lexbuf - 1); - let _ = ins pod_command lexbuf in token lexbuf - } - -| '\n' { - add_a_new_line(lexeme_end lexbuf); - (try - let (mark, r) = Queue.pop here_docs in - current_here_doc_mark := mark ; - r := ins here_doc lexbuf - with Queue.Empty -> - try - let (mark, r) = Queue.pop raw_here_docs in - current_here_doc_mark := mark ; - r := raw_ins raw_here_doc lexbuf - with Queue.Empty -> ()); - CR - } -| "->" { ARROW(pos lexbuf) } -| "++" { INCR(pos lexbuf) } -| "--" { DECR(pos lexbuf) } -| "**" { POWER(pos lexbuf) } -| "!" { TIGHT_NOT(pos lexbuf) } -| "~" { BIT_NEG(pos lexbuf) } -| "=~" { PATTERN_MATCH(pos lexbuf) } -| "!~" { PATTERN_MATCH_NOT(pos lexbuf) } -| "*" { MULT(lexeme lexbuf, pos lexbuf) } -| "%" { MULT(lexeme lexbuf, pos lexbuf) } -| "x" { MULT_L_STR(pos lexbuf) } -| "+" { PLUS(lexeme lexbuf, pos lexbuf) } -| "-" { PLUS(lexeme lexbuf, pos lexbuf) } -| "." { CONCAT(pos lexbuf) } -| "<<" { BIT_SHIFT(lexeme lexbuf, pos lexbuf) } -| ">>" { BIT_SHIFT(lexeme lexbuf, pos lexbuf) } -| "<" { LT(pos lexbuf) } -| ">" { GT(pos lexbuf) } -| "<=" | ">=" { COMPARE_OP(lexeme lexbuf, pos lexbuf) } -| "lt" | "gt" | "le" | "ge" { COMPARE_OP_STR(lexeme lexbuf, pos lexbuf) } -| "==" | "!=" | "<=>" { EQ_OP(lexeme lexbuf, pos lexbuf) } -| "eq" | "ne" | "cmp" { EQ_OP_STR(lexeme lexbuf, pos lexbuf) } -| "&" { BIT_AND(pos lexbuf) } -| "|" { BIT_OR(pos lexbuf) } -| "^" { BIT_XOR(pos lexbuf) } -| "&&" { AND_TIGHT(pos lexbuf) } -| "||" { OR_TIGHT(pos lexbuf) } -| ".." { DOTDOT(lexeme lexbuf, pos lexbuf) } -| "..." { DOTDOT(lexeme lexbuf, pos lexbuf) } -| "?" { QUESTION_MARK(pos lexbuf) } -| ":" { COLON(pos lexbuf) } -| "::" { PKG_SCOPE(pos lexbuf) } - -| "=" | "+=" | "-=" | "*=" | ".=" | "|=" | "&=" | "^=" | "||=" | "&&=" { ASSIGN(lexeme lexbuf, pos lexbuf) } - -| "<<=" | ">>=" | "**=" { - warn [Warn_complex_expressions] lexbuf (Printf.sprintf "don't use \"%s\", use the expanded version instead" (lexeme lexbuf)) ; - ASSIGN(lexeme lexbuf, pos lexbuf) - } - -| "," { COMMA(pos lexbuf) } -| "=>" { RIGHT_ARROW(pos lexbuf) } -| "not" { NOT(pos lexbuf) } -| "and" { AND(pos lexbuf) } -| "or" { OR(pos lexbuf) } -| "xor" { XOR(pos lexbuf) } - -| "if" { IF(pos lexbuf) } -| "else" { ELSE(pos lexbuf) } -| "elsif" { ELSIF(pos lexbuf) } -| "unless" { UNLESS(pos lexbuf) } -| "do" { DO(pos lexbuf) } -| "while" { WHILE(pos lexbuf) } -| "until" { UNTIL(pos lexbuf) } -| "foreach" { FOR(lexeme lexbuf, pos lexbuf) } -| "for" { FOR(lexeme lexbuf, pos lexbuf) } -| "my" { MY_OUR(lexeme lexbuf, pos lexbuf) } -| "our" { MY_OUR(lexeme lexbuf, pos lexbuf) } -| "local" { LOCAL(pos lexbuf) } -| "continue" { CONTINUE(pos lexbuf) } -| "sub" { SUB(pos lexbuf) } -| "package" { PACKAGE(pos lexbuf) } -| "use" { USE(pos lexbuf) } -| "BEGIN" { BEGIN(pos lexbuf) } -| "END" { END(pos lexbuf) } -| "print" { PRINT(lexeme lexbuf, pos lexbuf) } -| "printf" { PRINT(lexeme lexbuf, pos lexbuf) } -| "new" { NEW(pos lexbuf) } -| "format" { let pos = pos lexbuf in FORMAT(here_doc_next_line ".", pos) } -| "delete" -| "defined" -| "length" -| "keys" -| "exists" -| "shift" -| "pop" -| "eval" -| "ref" { ONE_SCALAR_PARA(lexeme lexbuf, pos lexbuf) } - -| "split" -| "grep" { (* ok_for_match! *) BAREWORD(lexeme lexbuf, pos lexbuf) } - -| "print " ['A'-'Z'] ['A'-'Z' '0'-'9']* ['\n' ' '] { - putback lexbuf 1; - PRINT_TO_STAR(("print", skip_n_char 6 (lexeme lexbuf)), pos lexbuf) - } -| "print $" ident ['\n' ' '] { - putback lexbuf 1; - PRINT_TO_SCALAR(("print", skip_n_char 7 (lexeme lexbuf)), pos lexbuf); - } -| "printf " ['A'-'Z'] ['A'-'Z' '0'-'9']* ['\n' ' '] { - putback lexbuf 1; - PRINT_TO_STAR(("printf", skip_n_char 7 (lexeme lexbuf)), pos lexbuf) - } -| "printf $" ident ['\n' ' '] { - putback lexbuf 1; - PRINT_TO_SCALAR(("printf", skip_n_char 8 (lexeme lexbuf)), pos lexbuf); - } - -| ident ' '* "=>" { (* needed so that (if => 1) works *) - let s = lexeme lexbuf in - let end_ = String.length s - 1 in - let ident_end = non_rindex_from s (end_ - 2) ' ' in - putback lexbuf (end_ - ident_end); - BAREWORD(String.sub s 0 (ident_end+1), pos lexbuf) - } - -| "{" ident "}" { (* needed so that $h{if} works *) - not_ok_for_match := lexeme_end lexbuf; - COMPACT_HASH_SUBSCRIPT(skip_n_char_ 1 1 (lexeme lexbuf), pos lexbuf) - } - -| '@' { AT(pos lexbuf) } -| '$' { DOLLAR(pos lexbuf) } -| '$' '#' { ARRAYLEN(pos lexbuf) } -| '%' ['$' '{'] { putback lexbuf 1; PERCENT(pos lexbuf) } -| '&' ['$' '{'] { putback lexbuf 1; AMPERSAND(pos lexbuf) } -| '*' ['$' '{'] { putback lexbuf 1; if lexeme_start lexbuf = !not_ok_for_match then MULT("*", pos lexbuf) else STAR(pos lexbuf) } - - -| ';' { SEMI_COLON(pos lexbuf) } -| '(' { PAREN(pos lexbuf) } -| '{' { BRACKET(pos lexbuf) } -| "+{"{ BRACKET_HASHREF(pos lexbuf) } -| '[' { ARRAYREF(pos lexbuf) } -| ')' { not_ok_for_match := lexeme_end lexbuf; PAREN_END(pos lexbuf) } -| '}' { not_ok_for_match := lexeme_end lexbuf; BRACKET_END(pos lexbuf) } -| ']' { not_ok_for_match := lexeme_end lexbuf; ARRAYREF_END(pos lexbuf) } - -| "/" { - if lexeme_start lexbuf = !not_ok_for_match then MULT("/", pos lexbuf) - else ( - delimit_char := '/' ; - current_string_start_line := !current_file_current_line; - let s, pos = ins_re re_delimited_string lexbuf in - let opts, _ = raw_ins pattern_options lexbuf in - check_multi_line_delimited_string (Some opts) pos ; - PATTERN(s, opts, pos) - ) - } - -| "/=" { - if lexeme_start lexbuf = !not_ok_for_match then ASSIGN(lexeme lexbuf, pos lexbuf) - else ( - putback lexbuf 1 ; - delimit_char := '/' ; - let s, pos = ins_re re_delimited_string lexbuf in - let opts, _ = raw_ins pattern_options lexbuf in - PATTERN(s, opts, pos) - ) - } - -| "m" pattern_separator { - set_delimit_char lexbuf "m" ; - current_string_start_line := !current_file_current_line; - let s, pos = ins_re re_delimited_string lexbuf in - let opts, _ = raw_ins pattern_options lexbuf in - check_multi_line_delimited_string (Some opts) pos ; - PATTERN(s, opts, pos) -} - -| "qr" pattern_separator { - set_delimit_char lexbuf "qr" ; - current_string_start_line := !current_file_current_line; - let s, pos = ins_re re_delimited_string lexbuf in - let opts, _ = raw_ins pattern_options lexbuf in - check_multi_line_delimited_string (Some opts) pos ; - QR_PATTERN(s, opts, pos) -} - -| "qw" pattern_separator { - set_delimit_char lexbuf "qw" ; - current_string_start_line := !current_file_current_line; - let s, pos = raw_ins delimited_string lexbuf in - warn_with_pos [Warn_complex_expressions] pos (Printf.sprintf "don't use qw%c...%c, use qw(...) instead" !delimit_char !delimit_char) ; - QUOTEWORDS(s, pos) -} - -| "s" pattern_separator { - set_delimit_char lexbuf "s" ; - current_string_start_line := !current_file_current_line; - let s1, (start, _) = ins_re re_delimited_string lexbuf in - let s2, (_, end_) = ins delimited_string lexbuf in - let opts, _ = raw_ins pattern_options lexbuf in - let pos = start, end_ in - if String.contains opts 'e' && sum (List.map (fun (s, _) -> count_chars_in_string s '"') s2) > 2 then - die lexbuf ("do not write so complicated things in the eval part of s///,\n" ^ - "i generate wrong warnings for things like s/xxx/die \"yyy \\\"zzz\\\" \"/") ; - check_multi_line_delimited_string (Some opts) pos ; - PATTERN_SUBST(s1, s2, opts, pos) -} - -| "tr" pattern_separator { - set_delimit_char lexbuf "tr" ; - current_string_start_line := !current_file_current_line; - let s1, (start, _) = ins delimited_string lexbuf in - let s2, (_, end_) = ins delimited_string lexbuf in - let opts, _ = raw_ins pattern_options lexbuf in - let pos = start, end_ in - check_multi_line_delimited_string None pos ; - PATTERN_SUBST(s1, s2, opts, pos) -} - -| "<<" ident { - not_ok_for_match := lexeme_end lexbuf; - HERE_DOC(here_doc_next_line (skip_n_char 2 (lexeme lexbuf)), pos lexbuf) - } -| "<<\"" ident "\"" { - warn_with_pos [Warn_suggest_simpler] (lexeme_start lexbuf + 2, lexeme_end lexbuf) "Don't use <<\"MARK\", use <<MARK instead" ; - not_ok_for_match := lexeme_end lexbuf; - HERE_DOC(here_doc_next_line (skip_n_char_ 3 1 (lexeme lexbuf)), pos lexbuf) - } -| "<<'" ident "'" { - not_ok_for_match := lexeme_end lexbuf; - RAW_HERE_DOC(raw_here_doc_next_line (skip_n_char_ 3 1 (lexeme lexbuf)), pos lexbuf) - } -| "<<" ' '+ "'" -| "<<" ' '+ ident -| "<<" ' '* '"' { - failwith (pos2sfull_with (lexeme_start lexbuf + 2) (lexeme_end lexbuf) ^ "No space allowed between \"<<\" and the marker") - } - -| "\\"+ stash -| "\\" ['0'-'9' 'A'-'Z' 'a'-'z'] -| "\\" ' '* '(' - { lexbuf.lex_curr_pos <- lexbuf.lex_start_pos + 1; REF(pos lexbuf) } - -| "sub(" [ '$' '@' '\\' '&' ';' '%' ]* ')' { - SUB_WITH_PROTO(skip_n_char_ 4 1 (lexeme lexbuf), pos lexbuf) - } - -| "sub" ' '+ ident ' '* '(' [ '$' '@' '\\' '&' ';' '%' ]* ')' { - (* bloody prototypes, must be caught especially otherwise "($)" is badly tokenized *) - (* and alas "($@)" is both valid as an expression and a prototype *) - let s = lexeme lexbuf in - let ident_start = non_index_from s 3 ' ' in - - let proto_start = String.index_from s ident_start '(' in - let ident_end = non_rindex_from s (proto_start-1) ' ' in - let ident = String.sub s ident_start (ident_end - ident_start + 1) in - let prototype = skip_n_char_ (proto_start + 1) 1 s in - - FUNC_DECL_WITH_PROTO(None, ident, prototype, pos lexbuf) - } - -| "sub" ' '+ ident ("::" ident)+ ' '* '(' [ '$' '@' '\\' '&' ';' '%' ]* ')' { - (* bloody prototypes, must be caught especially otherwise "($)" is badly tokenized *) - (* and alas "($@)" is both valid as an expression and a prototype *) - let s = lexeme lexbuf in - let ident_start = non_index_from s 3 ' ' in - - let proto_start = String.index_from s ident_start '(' in - let ident_end = non_rindex_from s (proto_start-1) ' ' in - let ident = String.sub s ident_start (ident_end - ident_start + 1) in - let prototype = skip_n_char_ (proto_start + 1) 1 s in - - let fq, name = split_at_two_colons ident in - FUNC_DECL_WITH_PROTO(Some fq, name, prototype, pos lexbuf) - } - -| "$#" ident? ("::" ident)+ { arraylen_fqident_from_lexbuf lexbuf } -| "$#" ident { arraylen_ident_from_lexbuf lexbuf } - -| stash ident? ("::" ident)+ { typed_fqident_from_lexbuf lexbuf } -| stash ident -| '$' [^ '{' ' ' '\n' '$'] -| "$^" [^ '{' ' ' '\n'] { typed_ident_from_lexbuf lexbuf } - -| "$$" [^ 'a'-'z' 'A'-'Z' '_' '{'] { putback lexbuf 1; SCALAR_IDENT(None, "$", pos lexbuf) } - -| stash "::" { putback lexbuf 2; ident_type_from_char None "main" lexbuf (lexeme_char lexbuf 0) } - -| ident? ("::" ident)+ { ident_from_lexbuf lexbuf } -| ident { not_ok_for_match := lexeme_end lexbuf; - let word = lexeme lexbuf in - if word = "qx" then die lexbuf "don't use qx{...}, use `...` instead" else - BAREWORD(word, pos lexbuf) } - -| ident ":" { LABEL(lexeme lexbuf, pos lexbuf) } - -| '-' [ 'a'-'z' 'A'-'Z' ] [ ' ' '(' ';' ] { putback lexbuf 1; ONE_SCALAR_PARA(lexeme lexbuf, pos lexbuf) } - -| ['0'-'9'] ['0'-'9' '_']* '.' ['0'-'9'] ['0'-'9' '_']* ('.' ['0'-'9'] ['0'-'9' '_']*)+ -| 'v' ['0'-'9'] ['0'-'9' '_']* ('.' ['0'-'9'] ['0'-'9' '_']*)* - { - not_ok_for_match := lexeme_end lexbuf; - REVISION(lexeme lexbuf, pos lexbuf) - } - -| ['0'-'9']* '.' ['0'-'9']+ (['e' 'E']['-' '+']?['0'-'9']+)? { - not_ok_for_match := lexeme_end lexbuf; - FLOAT(lexeme lexbuf, pos lexbuf) - } -| ['0'-'9'] ['0'-'9' '_']* (['e' 'E']['-' '+']?['0'-'9']+)? -| "0x" ['0'-'9' 'a'-'f' 'A'-'F']+ { - not_ok_for_match := lexeme_end lexbuf; - INT(lexeme lexbuf, pos lexbuf) - } - -| 'N' '_'? "(\"" { string_is_i18n := true ; putback lexbuf 2 ; BAREWORD(lexeme lexbuf, pos lexbuf) } - -| '"' { ins_to_string string 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" pattern_open { set_delimit_char_open lexbuf "q"; raw_ins_to_string qstring lexbuf } -| "qq" pattern_open { set_delimit_char_open lexbuf "qq"; ins_to_string qqstring lexbuf } -| "qx" pattern_open { set_delimit_char_open lexbuf "qx"; ins_to_string qqstring lexbuf } -| "qw" pattern_open { set_delimit_char_open lexbuf "qw"; let s, pos = raw_ins qstring lexbuf in QUOTEWORDS(s, pos) } - -| "\n__END__" [^ '0'-'9' 'A'-'Z' 'a'-'z' '_'] -| "\n__DATA__" [^ '0'-'9' 'A'-'Z' 'a'-'z' '_'] -| eof { EOF(pos lexbuf) } -| _ { failwith (Printf.sprintf "%serror tokenizing <<%s>>" (pos2sfull lexbuf) (lexeme lexbuf)) } - -and string = parse -| '"' { () } -| '\\' { Stack.push string next_rule ; string_escape_kind := Double_quote; string_escape lexbuf } -| '$' { Stack.push string next_rule ; string_interpolate_scalar lexbuf } -| '@' { Stack.push string next_rule ; string_interpolate_array lexbuf } -| '\n' { - add_a_new_line(lexeme_end lexbuf); - next string lexbuf - } -| "'" { string_escape_useful := Left true ; next string lexbuf } -| [^ '\n' '\\' '"' '$' '@']+ { next string lexbuf } -| eof { die_in_string lexbuf "Unterminated_string" } - -and delimited_string = parse -| '\\' { Stack.push delimited_string next_rule ; string_escape_kind := Delimited; string_escape lexbuf } -| '$' { Stack.push delimited_string next_rule ; delimited_string_interpolate_scalar lexbuf } -| '@' { Stack.push delimited_string next_rule ; delimited_string_interpolate_array lexbuf } -| '\n' { - add_a_new_line(lexeme_end lexbuf); - next delimited_string lexbuf - } -| eof { die_in_string lexbuf "Unterminated_delimited_string" } -| [ ^ '\n' '\\' '$' '@'] { if lexeme_char lexbuf 0 <> !delimit_char then next delimited_string lexbuf } - -and re_delimited_string = parse -| '\\' { Stack.push re_delimited_string next_rule ; re_string_escape lexbuf } -| '$' { Stack.push re_delimited_string next_rule ; delimited_string_interpolate_scalar lexbuf } -| '@' { if lexeme_char lexbuf 0 <> !delimit_char then - (Stack.push re_delimited_string next_rule ; delimited_string_interpolate_array lexbuf) } -| '\n' { - add_a_new_line(lexeme_end lexbuf); - next re_delimited_string lexbuf - } -| eof { die_in_string lexbuf "Unterminated_delimited_string" } -| [ ^ '\n' '\\' '$' '@'] { if lexeme_char lexbuf 0 <> !delimit_char then next re_delimited_string lexbuf } - -and rawstring = parse -| ''' { () } -| '\n' { - add_a_new_line(lexeme_end lexbuf); - next rawstring lexbuf - } -| '\\' { next rawstring lexbuf } -| "\\'" { next_s "'" rawstring lexbuf } -| [^ '\n' ''' '\\']+ { next rawstring lexbuf } -| eof { die_in_string lexbuf "Unterminated_rawstring" } - -and qqstring = parse -| pattern_close { - if lexeme_char lexbuf 0 = !delimit_char_close then - if !string_nestness <> 0 then (decr string_nestness; next qqstring lexbuf) - else () - else next qstring lexbuf - } -| pattern_open { - if lexeme_char lexbuf 0 = !delimit_char_open then incr string_nestness; - next qqstring lexbuf - } -| '\\' { Stack.push qqstring next_rule ; string_escape_kind := Qq; string_escape lexbuf } -| '$' { Stack.push qqstring next_rule ; string_interpolate_scalar lexbuf } -| '@' { Stack.push qqstring next_rule ; string_interpolate_array lexbuf } -| '\n' { - add_a_new_line(lexeme_end lexbuf); - next qqstring lexbuf - } -| [^ '\n' '(' ')' '{' '}' '\\' '$' '@']+ { next qqstring lexbuf } -| eof { die_in_string lexbuf "Unterminated_qqstring" } - -and qstring = parse -| pattern_close { - if lexeme_char lexbuf 0 = !delimit_char_close then - if !string_nestness <> 0 then (decr string_nestness ; next qstring lexbuf) - else () - else next qstring lexbuf - } -| pattern_open { - if lexeme_char lexbuf 0 = !delimit_char_open then incr string_nestness; - next qstring lexbuf - } -| '\n' { - add_a_new_line(lexeme_end lexbuf); - next qstring lexbuf - } -| [^ '\n' '(' ')' '{' '}']+ { next qstring lexbuf } -| eof { die_in_string lexbuf "Unterminated_qstring" } - -and here_doc = parse -| '\\' { Stack.push here_doc next_rule ; string_escape_kind := Here_doc; string_escape lexbuf } -| '$' { Stack.push here_doc next_rule ; string_interpolate_scalar lexbuf } -| '@' { Stack.push here_doc next_rule ; string_interpolate_array lexbuf } -| [ ^ '\n' '\\' '$' '@' ]* { - let s = lexeme lexbuf in - if chomps s <> !current_here_doc_mark - then next_s s here_doc lexbuf - else if s <> !current_here_doc_mark then warn_with_pos [Warn_traps] (pos lexbuf) "Trailing spaces after HERE-document mark" - } -| '\n' { - add_a_new_line(lexeme_end lexbuf); - next here_doc lexbuf - } -| eof { die_in_string lexbuf "Unterminated_here_doc" } - -and raw_here_doc = parse -| [ ^ '\n' ]* { - let s = lexeme lexbuf in - if chomps s <> !current_here_doc_mark - then next_s s raw_here_doc lexbuf - else if s <> !current_here_doc_mark then warn_with_pos [Warn_traps] (pos lexbuf) "Trailing spaces after HERE-document mark" - } -| '\n' { - add_a_new_line(lexeme_end lexbuf); - next raw_here_doc lexbuf - } -| eof { die_in_string lexbuf "Unterminated_raw_here_doc" } - - -and string_escape = parse -| ['0'-'9'] { string_escape_useful := Left true; next_s (String.make 1 (Char.chr (int_of_string (lexeme lexbuf)))) (Stack.pop next_rule) lexbuf } -| 'n' { string_escape_useful := Left true; next_s "\n" (Stack.pop next_rule) lexbuf } -| 't' { string_escape_useful := Left true; next_s "\t" (Stack.pop next_rule) lexbuf } -| "x{" [^ '}']* '}' { string_escape_useful := Left true; hex_in_string lexbuf next_rule (skip_n_char_ 2 1 (lexeme lexbuf)) } -| 'x' [^ '{'] _ { string_escape_useful := Left true; hex_in_string lexbuf next_rule (skip_n_char 1 (lexeme lexbuf)) } -| '\n' { die lexbuf "do not use \"\\\" before end-of-line, it's useless and generally bad" } -| '\\'{ next_s "\\" (Stack.pop next_rule) lexbuf } -| 'Q' { - warn [Warn_complex_expressions] lexbuf ("don't use \\Q, use quotemeta instead"); - string_escape_useful := Left true; next_s ("\\" ^ lexeme lexbuf) (Stack.pop next_rule) lexbuf } -| ['b' 'f' 'a' 'r'] { string_escape_useful := Left true; next_s ("\\" ^ lexeme lexbuf) (Stack.pop next_rule) lexbuf } -| ['$' '@' '%' '{' '[' ':'] { - if !string_escape_useful = Left false then string_escape_useful := Right (lexeme_char lexbuf 0) ; - next_s (lexeme lexbuf) (Stack.pop next_rule) lexbuf - } -| _ { - let c = lexeme_char lexbuf 0 in - (match !string_escape_kind with - | Double_quote -> - if c <> '"' then - warn_escape_unneeded lexbuf c - else ( - if !string_escape_useful = Left false then string_escape_useful := Right c ; - string_quote_escape := true - ) - | Qq -> if c <> !delimit_char_open && c <> !delimit_char_close then warn_escape_unneeded lexbuf c - | Here_doc -> warn_escape_unneeded lexbuf c - | Delimited -> if c = !delimit_char then - warn [Warn_suggest_simpler] lexbuf ("change the delimit character " ^ String.make 1 !delimit_char ^ " to get rid of this escape") - else warn_escape_unneeded lexbuf c); - let s = if c = '"' then String.make 1 c else "\\" ^ String.make 1 c in - next_s s (Stack.pop next_rule) lexbuf - } - -and re_string_escape = parse -| ['0'-'9'] { next_s (String.make 1 (Char.chr (int_of_string (lexeme lexbuf)))) (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{" [^ '}']* '}' { hex_in_string lexbuf next_rule (skip_n_char_ 2 1 (lexeme lexbuf)) } -| 'x' [^ '{'] _ { hex_in_string lexbuf next_rule (skip_n_char 1 (lexeme lexbuf)) } -| '\n' { die lexbuf "do not use \"\\\" before end-of-line, it's useless and generally bad" } -| ['r' 'b' 'f' '$' '@' '%' 's' 'S' 'd' 'D' 'w' 'W' 'Q' 'E' 'b' 'Z' 'z' '^' '.' '*' '+' '?' '[' ']' '(' ')' '|' '{' '}' '-' ':'] { - next_s ("\\" ^ lexeme lexbuf) (Stack.pop next_rule) lexbuf - } -| _ { - let c = lexeme_char lexbuf 0 in - if c = !delimit_char then - warn [Warn_suggest_simpler] lexbuf ("change the delimit character " ^ String.make 1 !delimit_char ^ " to get rid of this escape") - else warn_escape_unneeded lexbuf c ; - next_s ("\\" ^ lexeme lexbuf) (Stack.pop next_rule) lexbuf - } - -and string_interpolate_scalar = parse -| '$' ident -| ['0'-'9'] -| '{' [^ '{' '}']* '}' -| in_string_expr -| [^ '{' '}' ' ' '\n' '"'] { (* eg: $! $$ *) - string_interpolate token "$" lexbuf - } - -| "{" -| ident "->"? '{' -| '"' { putback lexbuf 1; next_s "$" (Stack.pop next_rule) lexbuf } -| eof { next_s "$" (Stack.pop next_rule) lexbuf } -| _ { warn [Warn_strange] 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... *) -| '$' ident -| ['0'-'9'] -| '{' [^ '{' '}']* '}' -| (ident | (ident? ("::" ident)+)) "->"? ('{' [^ '{' '}' '\n']* '}')* -| (ident | (ident? ("::" ident)+)) "->"? (('{' [^ '{' '}' '\n']* '}') | ('[' ('$' ident | ['0'-'9']+) ']'))* - { - string_interpolate token "$" lexbuf - } - -| (ident | (ident? ("::" ident)+)) "->"? (('{' [^ '{' '}' '\n']* '}') | ('[' ['$' '0'-'9'] [^ '[' ']' '\n']* ']'))* - { - die lexbuf (Printf.sprintf "I really can't handle this, [xxx] can be indexing or not based on stellar position :-(") - } - -| "{" -| ident "->"? '{' -| eof { next_s "$" (Stack.pop next_rule) lexbuf } -| _ { - let c = lexeme_char lexbuf 0 in - if c <> !delimit_char && c <> '|' && c<>')' && c<>'/' && c<>' ' then warn [Warn_strange] lexbuf (Printf.sprintf "weird \"%s\" in string" (lexeme lexbuf)); - putback lexbuf 1; - next_s "$" (Stack.pop next_rule) lexbuf - } - -and string_interpolate_array = parse -| '$' ident -| '{' [^ '{' '}']* '}' -| in_string_expr { string_interpolate token "@" 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 [Warn_strange] 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 -| '{' [^ '{' '}']* '}' -| in_string_expr - { string_interpolate token "@" lexbuf } - -| [ '@' '*' '<' '>' ']' '.' '(' ' ' ] { next_s ("@" ^ lexeme lexbuf) (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 [Warn_strange] lexbuf (Printf.sprintf "weird \"%s\" in string" (lexeme lexbuf)); - putback lexbuf 1; - next_s "@" (Stack.pop next_rule) lexbuf - } - -and pattern_options = parse -| [ 'g' 'i' 'm' 'o' 's' 'x' 'e' 'd' ] { next pattern_options lexbuf } -| _ { putback lexbuf 1; () } - -and pod_command = parse -| [^ '\n' ]+ { - let s = lexeme lexbuf in - let command = String.sub s 0 (try String.index s ' ' with Not_found -> String.length s) in - match command with - | "cut" -> - if !(Stack.top building_current_string) = "" then - failwith(pos2sfull lexbuf ^ "found POD command \"=cut\" but it is not a POD block") - | "head1" | "head2" | "head3" | "head4" | "over" | "item" | "back" | "pod" | "begin" | "end" | "for" -> - next pod lexbuf - | s -> failwith(pos2sfull lexbuf ^ "unknown POD command \"" ^ s ^ "\"") - } -| _ { failwith(pos2sfull lexbuf ^ "POD command expected") } - -and pod = parse -| "\n=" { - add_a_new_line(lexeme_end lexbuf - 1); - next pod_command lexbuf - } -| "\n" [^ '=' '\n'] [^ '\n']* -| "\n" { - add_a_new_line(lexeme_end lexbuf); - next pod lexbuf - } -| eof -| _ { failwith(pos2sfull_with !current_string_start_pos (lexeme_end lexbuf) ^ "POD block still open") } |