/* xgettext Perl backend. Copyright (C) 2002-2010, 2015-2016 Free Software Foundation, Inc. This file was written by Guido Flohr , 2002-2010. This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . */ #ifdef HAVE_CONFIG_H # include "config.h" #endif /* Specification. */ #include "x-perl.h" #include #include #include #include #include #include "message.h" #include "xgettext.h" #include "error.h" #include "error-progname.h" #include "xalloc.h" #include "po-charset.h" #include "unistr.h" #include "uniname.h" #include "gettext.h" #define _(s) gettext(s) /* The Perl syntax is defined in perlsyn.pod. Try the command "man perlsyn" or "perldoc perlsyn". Also, the syntax after the 'sub' keyword is specified in perlsub.pod. Try the command "man perlsub" or "perldoc perlsub". Perl 5.10 has new operators '//' and '//=', see . */ #define DEBUG_PERL 0 /* ====================== Keyword set customization. ====================== */ /* If true extract all strings. */ static bool extract_all = false; static hash_table keywords; static bool default_keywords = true; void x_perl_extract_all () { extract_all = true; } void x_perl_keyword (const char *name) { if (name == NULL) default_keywords = false; else { const char *end; struct callshape shape; const char *colon; if (keywords.table == NULL) hash_init (&keywords, 100); split_keywordspec (name, &end, &shape); /* The characters between name and end should form a valid C identifier. A colon means an invalid parse in split_keywordspec(). */ colon = strchr (name, ':'); if (colon == NULL || colon >= end) insert_keyword_callshape (&keywords, name, end - name, &shape); } } /* Finish initializing the keywords hash table. Called after argument processing, before each file is processed. */ static void init_keywords () { if (default_keywords) { /* When adding new keywords here, also update the documentation in xgettext.texi! */ x_perl_keyword ("gettext"); x_perl_keyword ("%gettext"); x_perl_keyword ("$gettext"); x_perl_keyword ("dgettext:2"); x_perl_keyword ("dcgettext:2"); x_perl_keyword ("ngettext:1,2"); x_perl_keyword ("dngettext:2,3"); x_perl_keyword ("dcngettext:2,3"); x_perl_keyword ("gettext_noop"); #if 0 x_perl_keyword ("__"); x_perl_keyword ("$__"); x_perl_keyword ("%__"); x_perl_keyword ("__x"); x_perl_keyword ("__n:1,2"); x_perl_keyword ("__nx:1,2"); x_perl_keyword ("__xn:1,2"); x_perl_keyword ("N__"); #endif default_keywords = false; } } void init_flag_table_perl () { xgettext_record_flag ("gettext:1:pass-perl-format"); xgettext_record_flag ("gettext:1:pass-perl-brace-format"); xgettext_record_flag ("%gettext:1:pass-perl-format"); xgettext_record_flag ("%gettext:1:pass-perl-brace-format"); xgettext_record_flag ("$gettext:1:pass-perl-format"); xgettext_record_flag ("$gettext:1:pass-perl-brace-format"); xgettext_record_flag ("dgettext:2:pass-perl-format"); xgettext_record_flag ("dgettext:2:pass-perl-brace-format"); xgettext_record_flag ("dcgettext:2:pass-perl-format"); xgettext_record_flag ("dcgettext:2:pass-perl-brace-format"); xgettext_record_flag ("ngettext:1:pass-perl-format"); xgettext_record_flag ("ngettext:2:pass-perl-format"); xgettext_record_flag ("ngettext:1:pass-perl-brace-format"); xgettext_record_flag ("ngettext:2:pass-perl-brace-format"); xgettext_record_flag ("dngettext:2:pass-perl-format"); xgettext_record_flag ("dngettext:3:pass-perl-format"); xgettext_record_flag ("dngettext:2:pass-perl-brace-format"); xgettext_record_flag ("dngettext:3:pass-perl-brace-format"); xgettext_record_flag ("dcngettext:2:pass-perl-format"); xgettext_record_flag ("dcngettext:3:pass-perl-format"); xgettext_record_flag ("dcngettext:2:pass-perl-brace-format"); xgettext_record_flag ("dcngettext:3:pass-perl-brace-format"); xgettext_record_flag ("gettext_noop:1:pass-perl-format"); xgettext_record_flag ("gettext_noop:1:pass-perl-brace-format"); xgettext_record_flag ("printf:1:perl-format"); /* argument 1 or 2 ?? */ xgettext_record_flag ("sprintf:1:perl-format"); #if 0 xgettext_record_flag ("__:1:pass-perl-format"); xgettext_record_flag ("__:1:pass-perl-brace-format"); xgettext_record_flag ("%__:1:pass-perl-format"); xgettext_record_flag ("%__:1:pass-perl-brace-format"); xgettext_record_flag ("$__:1:pass-perl-format"); xgettext_record_flag ("$__:1:pass-perl-brace-format"); xgettext_record_flag ("__x:1:perl-brace-format"); xgettext_record_flag ("__n:1:pass-perl-format"); xgettext_record_flag ("__n:2:pass-perl-format"); xgettext_record_flag ("__n:1:pass-perl-brace-format"); xgettext_record_flag ("__n:2:pass-perl-brace-format"); xgettext_record_flag ("__nx:1:perl-brace-format"); xgettext_record_flag ("__nx:2:perl-brace-format"); xgettext_record_flag ("__xn:1:perl-brace-format"); xgettext_record_flag ("__xn:2:perl-brace-format"); xgettext_record_flag ("N__:1:pass-perl-format"); xgettext_record_flag ("N__:1:pass-perl-brace-format"); #endif } /* ======================== Reading of characters. ======================== */ /* Real filename, used in error messages about the input file. */ static const char *real_file_name; /* Logical filename and line number, used to label the extracted messages. */ static char *logical_file_name; static int line_number; /* The input file stream. */ static FILE *fp; /* The current line buffer. */ static char *linebuf; /* The size of the current line. */ static int linesize; /* The position in the current line. */ static int linepos; /* The size of the input buffer. */ static size_t linebuf_size; /* Number of lines eaten for here documents. */ static int eaten_here; /* Paranoia: EOF marker for __END__ or __DATA__. */ static bool end_of_file; /* 1. line_number handling. */ /* Returns the next character from the input stream or EOF. */ static int phase1_getc () { line_number += eaten_here; eaten_here = 0; if (end_of_file) return EOF; if (linepos >= linesize) { linesize = getline (&linebuf, &linebuf_size, fp); if (linesize < 0) { if (ferror (fp)) error (EXIT_FAILURE, errno, _("error while reading \"%s\""), real_file_name); end_of_file = true; return EOF; } linepos = 0; ++line_number; /* Undosify. This is important for catching the end of <= 2 && linebuf[linesize - 1] == '\n' && linebuf[linesize - 2] == '\r') { linebuf[linesize - 2] = '\n'; linebuf[linesize - 1] = '\0'; --linesize; } } return linebuf[linepos++]; } /* Supports only one pushback character. */ static void phase1_ungetc (int c) { if (c != EOF) { if (linepos == 0) /* Attempt to ungetc across line boundary. Shouldn't happen. No two phase1_ungetc calls are permitted in a row. */ abort (); --linepos; } } /* Read a here document and return its contents. The delimiter is an UTF-8 encoded string; the resulting string is UTF-8 encoded as well. */ static char * get_here_document (const char *delimiter) { /* Accumulator for the entire here document, including a NUL byte at the end. */ static char *buffer; static size_t bufmax = 0; size_t bufpos = 0; /* Current line being appended. */ static char *my_linebuf = NULL; static size_t my_linebuf_size = 0; /* Allocate the initial buffer. Later on, bufmax > 0. */ if (bufmax == 0) { buffer = XNMALLOC (1, char); buffer[0] = '\0'; bufmax = 1; } for (;;) { int read_bytes = getline (&my_linebuf, &my_linebuf_size, fp); char *my_line_utf8; bool chomp; if (read_bytes < 0) { if (ferror (fp)) { error (EXIT_FAILURE, errno, _("error while reading \"%s\""), real_file_name); } else { error_with_progname = false; error (EXIT_SUCCESS, 0, _("\ %s:%d: can't find string terminator \"%s\" anywhere before EOF"), real_file_name, line_number, delimiter); error_with_progname = true; break; } } ++eaten_here; /* Convert to UTF-8. */ my_line_utf8 = from_current_source_encoding (my_linebuf, lc_string, logical_file_name, line_number + eaten_here); if (my_line_utf8 != my_linebuf) { if (strlen (my_line_utf8) >= my_linebuf_size) { my_linebuf_size = strlen (my_line_utf8) + 1; my_linebuf = xrealloc (my_linebuf, my_linebuf_size); } strcpy (my_linebuf, my_line_utf8); free (my_line_utf8); } /* Undosify. This is important for catching the end of <= 2 && my_linebuf[read_bytes - 1] == '\n' && my_linebuf[read_bytes - 2] == '\r') { my_linebuf[read_bytes - 2] = '\n'; my_linebuf[read_bytes - 1] = '\0'; --read_bytes; } /* Temporarily remove the trailing newline from my_linebuf. */ chomp = false; if (read_bytes >= 1 && my_linebuf[read_bytes - 1] == '\n') { chomp = true; my_linebuf[read_bytes - 1] = '\0'; } /* See whether this line terminates the here document. */ if (strcmp (my_linebuf, delimiter) == 0) break; /* Add back the trailing newline to my_linebuf. */ if (chomp) my_linebuf[read_bytes - 1] = '\n'; /* Ensure room for read_bytes + 1 bytes. */ if (bufpos + read_bytes >= bufmax) { do bufmax = 2 * bufmax + 10; while (bufpos + read_bytes >= bufmax); buffer = xrealloc (buffer, bufmax); } /* Append this line to the accumulator. */ strcpy (buffer + bufpos, my_linebuf); bufpos += read_bytes; } /* Done accumulating the here document. */ return xstrdup (buffer); } /* Skips pod sections. */ static void skip_pod () { line_number += eaten_here; eaten_here = 0; linepos = 0; for (;;) { linesize = getline (&linebuf, &linebuf_size, fp); if (linesize < 0) { if (ferror (fp)) error (EXIT_FAILURE, errno, _("error while reading \"%s\""), real_file_name); return; } ++line_number; if (strncmp ("=cut", linebuf, 4) == 0) { /* Force reading of a new line on next call to phase1_getc(). */ linepos = linesize; return; } } } /* These are for tracking whether comments count as immediately before keyword. */ static int last_comment_line; static int last_non_comment_line; /* 2. Replace each comment that is not inside a string literal or regular expression with a newline character. We need to remember the comment for later, because it may be attached to a keyword string. */ static int phase2_getc () { static char *buffer; static size_t bufmax; size_t buflen; int lineno; int c; char *utf8_string; c = phase1_getc (); if (c == '#') { buflen = 0; lineno = line_number; /* Skip leading whitespace. */ for (;;) { c = phase1_getc (); if (c == EOF) break; if (c != ' ' && c != '\t' && c != '\r' && c != '\f') { phase1_ungetc (c); break; } } /* Accumulate the comment. */ for (;;) { c = phase1_getc (); if (c == '\n' || c == EOF) break; if (buflen >= bufmax) { bufmax = 2 * bufmax + 10; buffer = xrealloc (buffer, bufmax); } buffer[buflen++] = c; } if (buflen >= bufmax) { bufmax = 2 * bufmax + 10; buffer = xrealloc (buffer, bufmax); } buffer[buflen] = '\0'; /* Convert it to UTF-8. */ utf8_string = from_current_source_encoding (buffer, lc_comment, logical_file_name, lineno); /* Save it until we encounter the corresponding string. */ savable_comment_add (utf8_string); last_comment_line = lineno; } return c; } /* Supports only one pushback character. */ static void phase2_ungetc (int c) { if (c != EOF) phase1_ungetc (c); } /* Whitespace recognition. */ #define case_whitespace \ case ' ': case '\t': case '\r': case '\n': case '\f' static inline bool is_whitespace (int c) { return (c == ' ' || c == '\t' || c == '\r' || c == '\n' || c == '\f'); } /* ========================== Reading of tokens. ========================== */ enum token_type_ty { token_type_eof, token_type_lparen, /* ( */ token_type_rparen, /* ) */ token_type_comma, /* , */ token_type_fat_comma, /* => */ token_type_dereference, /* -> */ token_type_semicolon, /* ; */ token_type_lbrace, /* { */ token_type_rbrace, /* } */ token_type_lbracket, /* [ */ token_type_rbracket, /* ] */ token_type_string, /* quote-like */ token_type_number, /* starting with a digit o dot */ token_type_named_op, /* if, unless, while, ... */ token_type_variable, /* $... */ token_type_object, /* A dereferenced variable, maybe a blessed object. */ token_type_symbol, /* symbol, number */ token_type_regex_op, /* s, tr, y, m. */ token_type_dot, /* . */ token_type_other, /* regexp, misc. operator */ /* The following are not really token types, but variants used by the parser. */ token_type_keyword_symbol /* keyword symbol */ }; typedef enum token_type_ty token_type_ty; /* Subtypes for strings, important for interpolation. */ enum string_type_ty { string_type_verbatim, /* "<<'EOF'", "m'...'", "s'...''...'", "tr/.../.../", "y/.../.../". */ string_type_q, /* "'..'", "q/.../". */ string_type_qq, /* '"..."', "`...`", "qq/.../", "qx/.../", "". */ string_type_qr /* Not supported. */ }; /* Subtypes for symbols, important for dollar interpretation. */ enum symbol_type_ty { symbol_type_none, /* Nothing special. */ symbol_type_sub, /* 'sub'. */ symbol_type_function /* Function name after 'sub'. */ }; typedef struct token_ty token_ty; struct token_ty { token_type_ty type; token_type_ty last_type; int sub_type; /* for token_type_string, token_type_symbol */ char *string; /* for: in encoding: token_type_named_op ASCII token_type_string UTF-8 token_type_symbol ASCII token_type_variable global_source_encoding token_type_object global_source_encoding */ refcounted_string_list_ty *comment; /* for token_type_string */ int line_number; }; #if DEBUG_PERL static const char * token2string (const token_ty *token) { switch (token->type) { case token_type_eof: return "token_type_eof"; case token_type_lparen: return "token_type_lparen"; case token_type_rparen: return "token_type_rparen"; case token_type_comma: return "token_type_comma"; case token_type_fat_comma: return "token_type_fat_comma"; case token_type_dereference: return "token_type_dereference"; case token_type_semicolon: return "token_type_semicolon"; case token_type_lbrace: return "token_type_lbrace"; case token_type_rbrace: return "token_type_rbrace"; case token_type_lbracket: return "token_type_lbracket"; case token_type_rbracket: return "token_type_rbracket"; case token_type_string: return "token_type_string"; case token_type_number: return "token type number"; case token_type_named_op: return "token_type_named_op"; case token_type_variable: return "token_type_variable"; case token_type_object: return "token_type_object"; case token_type_symbol: return "token_type_symbol"; case token_type_regex_op: return "token_type_regex_op"; case token_type_dot: return "token_type_dot"; case token_type_other: return "token_type_other"; default: return "unknown"; } } #endif /* Free the memory pointed to by a 'struct token_ty'. */ static inline void free_token (token_ty *tp) { switch (tp->type) { case token_type_named_op: case token_type_string: case token_type_symbol: case token_type_variable: case token_type_object: free (tp->string); break; default: break; } if (tp->type == token_type_string) drop_reference (tp->comment); free (tp); } /* Pass 1 of extracting quotes: Find the end of the string, regardless of the semantics of the construct. Return the complete string, including the starting and the trailing delimiter, with backslashes removed where appropriate. */ static char * extract_quotelike_pass1 (int delim) { /* This function is called recursively. No way to allocate stuff statically. Also alloca() is inappropriate due to limited stack size on some platforms. So we use malloc(). */ int bufmax = 10; char *buffer = XNMALLOC (bufmax, char); int bufpos = 0; bool nested = true; int counter_delim; buffer[bufpos++] = delim; /* Find the closing delimiter. */ switch (delim) { case '(': counter_delim = ')'; break; case '{': counter_delim = '}'; break; case '[': counter_delim = ']'; break; case '<': counter_delim = '>'; break; default: /* "..." or '...' or |...| etc. */ nested = false; counter_delim = delim; break; } for (;;) { int c = phase1_getc (); /* This round can produce 1 or 2 bytes. Ensure room for 2 bytes. */ if (bufpos + 2 > bufmax) { bufmax = 2 * bufmax + 10; buffer = xrealloc (buffer, bufmax); } if (c == counter_delim || c == EOF) { buffer[bufpos++] = counter_delim; /* will be stripped off later */ buffer[bufpos++] = '\0'; #if DEBUG_PERL fprintf (stderr, "PASS1: %s\n", buffer); #endif return buffer; } if (nested && c == delim) { char *inner = extract_quotelike_pass1 (delim); size_t len = strlen (inner); /* Ensure room for len + 1 bytes. */ if (bufpos + len >= bufmax) { do bufmax = 2 * bufmax + 10; while (bufpos + len >= bufmax); buffer = xrealloc (buffer, bufmax); } strcpy (buffer + bufpos, inner); free (inner); bufpos += len; } else if (c == '\\') { c = phase1_getc (); if (c == '\\') { buffer[bufpos++] = '\\'; buffer[bufpos++] = '\\'; } else if (c == delim || c == counter_delim) { /* This is pass2 in Perl. */ buffer[bufpos++] = c; } else { buffer[bufpos++] = '\\'; phase1_ungetc (c); } } else { buffer[bufpos++] = c; } } } /* Like extract_quotelike_pass1, but return the complete string in UTF-8 encoding. */ static char * extract_quotelike_pass1_utf8 (int delim) { char *string = extract_quotelike_pass1 (delim); char *utf8_string = from_current_source_encoding (string, lc_string, logical_file_name, line_number); if (utf8_string != string) free (string); return utf8_string; } /* ========= Reading of tokens and commands. Extracting strings. ========= */ /* Context lookup table. */ static flag_context_list_table_ty *flag_context_list_table; /* Forward declaration of local functions. */ static void interpolate_keywords (message_list_ty *mlp, const char *string, int lineno); static token_ty *x_perl_lex (message_list_ty *mlp); static void x_perl_unlex (token_ty *tp); static bool extract_balanced (message_list_ty *mlp, token_type_ty delim, bool eat_delim, bool comma_delim, flag_context_ty outer_context, flag_context_list_iterator_ty context_iter, int arg, struct arglist_parser *argparser); /* Extract an unsigned hexadecimal number from STRING, considering at most LEN bytes and place the result in *RESULT. Returns a pointer to the first character past the hexadecimal number. */ static const char * extract_hex (const char *string, size_t len, unsigned int *result) { size_t i; *result = 0; for (i = 0; i < len; i++) { char c = string[i]; int number; if (c >= 'A' && c <= 'F') number = c - 'A' + 10; else if (c >= 'a' && c <= 'f') number = c - 'a' + 10; else if (c >= '0' && c <= '9') number = c - '0'; else break; *result <<= 4; *result |= number; } return string + i; } /* Extract an unsigned octal number from STRING, considering at most LEN bytes and place the result in *RESULT. Returns a pointer to the first character past the octal number. */ static const char * extract_oct (const char *string, size_t len, unsigned int *result) { size_t i; *result = 0; for (i = 0; i < len; i++) { char c = string[i]; int number; if (c >= '0' && c <= '7') number = c - '0'; else break; *result <<= 3; *result |= number; } return string + i; } /* Extract the various quotelike constructs except for <type == token_type_string. */ static void extract_quotelike (token_ty *tp, int delim) { char *string = extract_quotelike_pass1_utf8 (delim); size_t len = strlen (string); tp->type = token_type_string; /* Take the string without the delimiters at the start and at the end. */ if (!(len >= 2)) abort (); string[len - 1] = '\0'; tp->string = xstrdup (string + 1); free (string); tp->comment = add_reference (savable_comment); } /* Extract the quotelike constructs with double delimiters, like s/[SEARCH]/[REPLACE]/. This function does not eat up trailing modifiers (left to the caller). Return the resulting token in *tp; tp->type == token_type_regex_op. */ static void extract_triple_quotelike (message_list_ty *mlp, token_ty *tp, int delim, bool interpolate) { char *string; tp->type = token_type_regex_op; string = extract_quotelike_pass1_utf8 (delim); if (interpolate) interpolate_keywords (mlp, string, line_number); free (string); if (delim == '(' || delim == '<' || delim == '{' || delim == '[') { /* The delimiter for the second string can be different, e.g. s{SEARCH}{REPLACE} or s{SEARCH}/REPLACE/. See "man perlrequick". */ delim = phase1_getc (); while (is_whitespace (delim)) { /* The hash-sign is not a valid delimiter after whitespace, ergo use phase2_getc() and not phase1_getc() now. */ delim = phase2_getc (); } } string = extract_quotelike_pass1_utf8 (delim); if (interpolate) interpolate_keywords (mlp, string, line_number); free (string); } /* Perform pass 3 of quotelike extraction (interpolation). *tp is a token of type token_type_string. This function replaces tp->string. This function does not access tp->comment. */ /* FIXME: Currently may writes null-bytes into the string. */ static void extract_quotelike_pass3 (token_ty *tp, int error_level) { static char *buffer; static int bufmax = 0; int bufpos = 0; const char *crs; bool uppercase; bool lowercase; bool quotemeta; #if DEBUG_PERL switch (tp->sub_type) { case string_type_verbatim: fprintf (stderr, "Interpolating string_type_verbatim:\n"); break; case string_type_q: fprintf (stderr, "Interpolating string_type_q:\n"); break; case string_type_qq: fprintf (stderr, "Interpolating string_type_qq:\n"); break; case string_type_qr: fprintf (stderr, "Interpolating string_type_qr:\n"); break; } fprintf (stderr, "%s\n", tp->string); if (tp->sub_type == string_type_verbatim) fprintf (stderr, "---> %s\n", tp->string); #endif if (tp->sub_type == string_type_verbatim) return; /* Loop over tp->string, accumulating the expansion in buffer. */ crs = tp->string; uppercase = false; lowercase = false; quotemeta = false; while (*crs) { bool backslashed; /* Ensure room for 7 bytes, 6 (multi-)bytes plus a leading backslash if \Q modifier is present. */ if (bufpos + 7 > bufmax) { bufmax = 2 * bufmax + 10; buffer = xrealloc (buffer, bufmax); } if (tp->sub_type == string_type_q) { switch (*crs) { case '\\': if (crs[1] == '\\') { crs += 2; buffer[bufpos++] = '\\'; break; } /* FALLTHROUGH */ default: buffer[bufpos++] = *crs++; break; } continue; } /* We only get here for double-quoted strings or regular expressions. Unescape escape sequences. */ if (*crs == '\\') { switch (crs[1]) { case 't': crs += 2; buffer[bufpos++] = '\t'; continue; case 'n': crs += 2; buffer[bufpos++] = '\n'; continue; case 'r': crs += 2; buffer[bufpos++] = '\r'; continue; case 'f': crs += 2; buffer[bufpos++] = '\f'; continue; case 'b': crs += 2; buffer[bufpos++] = '\b'; continue; case 'a': crs += 2; buffer[bufpos++] = '\a'; continue; case 'e': crs += 2; buffer[bufpos++] = 0x1b; continue; case '0': case '1': case '2': case '3': case '4': case '5': case '6': case '7': { unsigned int oct_number; int length; crs = extract_oct (crs + 1, 3, &oct_number); /* FIXME: If one of the variables UPPERCASE or LOWERCASE is true, the character should be converted to its uppercase resp. lowercase equivalent. I don't know if the necessary facilities are already included in gettext. For US-Ascii the conversion can be already be done, however. */ if (uppercase && oct_number >= 'a' && oct_number <= 'z') { oct_number = oct_number - 'a' + 'A'; } else if (lowercase && oct_number >= 'A' && oct_number <= 'Z') { oct_number = oct_number - 'A' + 'a'; } /* Yes, octal escape sequences in the range 0x100..0x1ff are valid. */ length = u8_uctomb ((unsigned char *) (buffer + bufpos), oct_number, 2); if (length > 0) bufpos += length; } continue; case 'x': { unsigned int hex_number = 0; int length; crs += 2; if (*crs == '{') { const char *end = strchr (crs, '}'); if (end == NULL) { error_with_progname = false; error (error_level, 0, _("\ %s:%d: missing right brace on \\x{HEXNUMBER}"), real_file_name, line_number); error_with_progname = true; ++crs; continue; } else { ++crs; (void) extract_hex (crs, end - crs, &hex_number); crs = end + 1; } } else { crs = extract_hex (crs, 2, &hex_number); } /* FIXME: If one of the variables UPPERCASE or LOWERCASE is true, the character should be converted to its uppercase resp. lowercase equivalent. I don't know if the necessary facilities are already included in gettext. For US-Ascii the conversion can be already be done, however. */ if (uppercase && hex_number >= 'a' && hex_number <= 'z') { hex_number = hex_number - 'a' + 'A'; } else if (lowercase && hex_number >= 'A' && hex_number <= 'Z') { hex_number = hex_number - 'A' + 'a'; } length = u8_uctomb ((unsigned char *) (buffer + bufpos), hex_number, 6); if (length > 0) bufpos += length; } continue; case 'c': /* Perl's notion of control characters. */ crs += 2; if (*crs) { int the_char = (unsigned char) *crs; if (the_char >= 'a' && the_char <= 'z') the_char = the_char - 'a' + 'A'; buffer[bufpos++] = the_char ^ 0x40; } continue; case 'N': crs += 2; if (*crs == '{') { const char *end = strchr (crs + 1, '}'); if (end != NULL) { char *name; unsigned int unicode; name = XNMALLOC (end - (crs + 1) + 1, char); memcpy (name, crs + 1, end - (crs + 1)); name[end - (crs + 1)] = '\0'; unicode = unicode_name_character (name); if (unicode != UNINAME_INVALID) { /* FIXME: Convert to upper/lowercase if the corresponding flag is set to true. */ int length = u8_uctomb ((unsigned char *) (buffer + bufpos), unicode, 6); if (length > 0) bufpos += length; } free (name); crs = end + 1; } } continue; } } /* No escape sequence, go on. */ if (*crs == '\\') { ++crs; switch (*crs) { case 'E': uppercase = false; lowercase = false; quotemeta = false; ++crs; continue; case 'L': uppercase = false; lowercase = true; ++crs; continue; case 'U': uppercase = true; lowercase = false; ++crs; continue; case 'Q': quotemeta = true; ++crs; continue; case 'l': ++crs; if (*crs >= 'A' && *crs <= 'Z') { buffer[bufpos++] = *crs - 'A' + 'a'; } else if ((unsigned char) *crs >= 0x80) { error_with_progname = false; error (error_level, 0, _("\ %s:%d: invalid interpolation (\"\\l\") of 8bit character \"%c\""), real_file_name, line_number, *crs); error_with_progname = true; } else { buffer[bufpos++] = *crs; } ++crs; continue; case 'u': ++crs; if (*crs >= 'a' && *crs <= 'z') { buffer[bufpos++] = *crs - 'a' + 'A'; } else if ((unsigned char) *crs >= 0x80) { error_with_progname = false; error (error_level, 0, _("\ %s:%d: invalid interpolation (\"\\u\") of 8bit character \"%c\""), real_file_name, line_number, *crs); error_with_progname = true; } else { buffer[bufpos++] = *crs; } ++crs; continue; case '\\': buffer[bufpos++] = *crs; ++crs; continue; default: backslashed = true; break; } } else backslashed = false; if (quotemeta && !((*crs >= 'A' && *crs <= 'Z') || (*crs >= 'A' && *crs <= 'z') || (*crs >= '0' && *crs <= '9') || *crs == '_')) { buffer[bufpos++] = '\\'; backslashed = true; } if (!backslashed && !extract_all && (*crs == '$' || *crs == '@')) { error_with_progname = false; error (error_level, 0, _("\ %s:%d: invalid variable interpolation at \"%c\""), real_file_name, line_number, *crs); error_with_progname = true; ++crs; } else if (lowercase) { if (*crs >= 'A' && *crs <= 'Z') buffer[bufpos++] = *crs - 'A' + 'a'; else if ((unsigned char) *crs >= 0x80) { error_with_progname = false; error (error_level, 0, _("\ %s:%d: invalid interpolation (\"\\L\") of 8bit character \"%c\""), real_file_name, line_number, *crs); error_with_progname = true; buffer[bufpos++] = *crs; } else buffer[bufpos++] = *crs; ++crs; } else if (uppercase) { if (*crs >= 'a' && *crs <= 'z') buffer[bufpos++] = *crs - 'a' + 'A'; else if ((unsigned char) *crs >= 0x80) { error_with_progname = false; error (error_level, 0, _("\ %s:%d: invalid interpolation (\"\\U\") of 8bit character \"%c\""), real_file_name, line_number, *crs); error_with_progname = true; buffer[bufpos++] = *crs; } else buffer[bufpos++] = *crs; ++crs; } else { buffer[bufpos++] = *crs++; } } /* Ensure room for 1 more byte. */ if (bufpos >= bufmax) { bufmax = 2 * bufmax + 10; buffer = xrealloc (buffer, bufmax); } buffer[bufpos++] = '\0'; #if DEBUG_PERL fprintf (stderr, "---> %s\n", buffer); #endif /* Replace tp->string. */ free (tp->string); tp->string = xstrdup (buffer); } /* Parse a variable. This is done in several steps: 1) Consume all leading occurencies of '$', '@', '%', and '*'. 2) Determine the name of the variable from the following input. 3) Parse possible following hash keys or array indexes. */ static void extract_variable (message_list_ty *mlp, token_ty *tp, int first) { static char *buffer; static int bufmax = 0; int bufpos = 0; int c = first; size_t varbody_length = 0; bool maybe_hash_deref = false; bool maybe_hash_value = false; tp->type = token_type_variable; #if DEBUG_PERL fprintf (stderr, "%s:%d: extracting variable type '%c'\n", real_file_name, line_number, first); #endif /* * 1) Consume dollars and so on (not euros ...). Unconditionally * accepting the hash sign (#) will maybe lead to inaccurate * results. FIXME! */ while (c == '$' || c == '*' || c == '#' || c == '@' || c == '%') { if (bufpos >= bufmax) { bufmax = 2 * bufmax + 10; buffer = xrealloc (buffer, bufmax); } buffer[bufpos++] = c; c = phase1_getc (); } if (c == EOF) { tp->type = token_type_eof; return; } /* Hash references are treated in a special way, when looking for our keywords. */ if (buffer[0] == '$') { if (bufpos == 1) maybe_hash_value = true; else if (bufpos == 2 && buffer[1] == '$') { if (!(c == '{' || (c >= 'A' && c <= 'Z') || (c >= 'a' && c <= 'z') || (c >= '0' && c <= '9') || c == '_' || c == ':' || c == '\'' || c >= 0x80)) { /* Special variable $$ for pid. */ if (bufpos >= bufmax) { bufmax = 2 * bufmax + 10; buffer = xrealloc (buffer, bufmax); } buffer[bufpos++] = '\0'; tp->string = xstrdup (buffer); #if DEBUG_PERL fprintf (stderr, "%s:%d: is PID ($$)\n", real_file_name, line_number); #endif phase1_ungetc (c); return; } maybe_hash_deref = true; bufpos = 1; } } /* * 2) Get the name of the variable. The first character is practically * arbitrary. Punctuation and numbers automagically put a variable * in the global namespace but that subtle difference is not interesting * for us. */ if (bufpos >= bufmax) { bufmax = 2 * bufmax + 10; buffer = xrealloc (buffer, bufmax); } if (c == '{') { /* Yuck, we cannot accept ${gettext} as a keyword... Except for * debugging purposes it is also harmless, that we suppress the * real name of the variable. */ #if DEBUG_PERL fprintf (stderr, "%s:%d: braced {variable_name}\n", real_file_name, line_number); #endif if (extract_balanced (mlp, token_type_rbrace, true, false, null_context, null_context_list_iterator, 1, arglist_parser_alloc (mlp, NULL))) { tp->type = token_type_eof; return; } buffer[bufpos++] = c; } else { while ((c >= 'A' && c <= 'Z') || (c >= 'a' && c <= 'z') || (c >= '0' && c <= '9') || c == '_' || c == ':' || c == '\'' || c >= 0x80) { ++varbody_length; if (bufpos >= bufmax) { bufmax = 2 * bufmax + 10; buffer = xrealloc (buffer, bufmax); } buffer[bufpos++] = c; c = phase1_getc (); } phase1_ungetc (c); } /* Probably some strange Perl variable like $`. */ if (varbody_length == 0) { c = phase1_getc (); if (c == EOF || is_whitespace (c)) phase1_ungetc (c); /* Loser. */ else { if (bufpos >= bufmax) { bufmax = 2 * bufmax + 10; buffer = xrealloc (buffer, bufmax); } buffer[bufpos++] = c; } } if (bufpos >= bufmax) { bufmax = 2 * bufmax + 10; buffer = xrealloc (buffer, bufmax); } buffer[bufpos++] = '\0'; tp->string = xstrdup (buffer); #if DEBUG_PERL fprintf (stderr, "%s:%d: complete variable name: %s\n", real_file_name, line_number, tp->string); #endif /* * 3) If the following looks strange to you, this is valid Perl syntax: * * $var = $$hashref # We can place a * # comment here and then ... * {key_into_hashref}; * * POD sections are not allowed but we leave complaints about * that to the compiler/interpreter. */ /* We only extract strings from the first hash key (if present). */ if (maybe_hash_deref || maybe_hash_value) { bool is_dereference = false; int c; do c = phase2_getc (); while (is_whitespace (c)); if (c == '-') { int c2 = phase1_getc (); if (c2 == '>') { is_dereference = true; do c = phase2_getc (); while (is_whitespace (c)); } else if (c2 != '\n') { /* Discarding the newline is harmless here. The only special character recognized after a minus is greater-than for dereference. However, the sequence "-\n>" that we treat incorrectly here, is a syntax error. */ phase1_ungetc (c2); } } if (maybe_hash_value && is_dereference) { tp->type = token_type_object; #if DEBUG_PERL fprintf (stderr, "%s:%d: first keys preceded by \"->\"\n", real_file_name, line_number); #endif } else if (maybe_hash_value) { /* Fake it into a hash. */ tp->string[0] = '%'; } /* Do NOT change that into else if (see above). */ if ((maybe_hash_value || maybe_hash_deref) && c == '{') { void *keyword_value; #if DEBUG_PERL fprintf (stderr, "%s:%d: first keys preceded by '{'\n", real_file_name, line_number); #endif if (hash_find_entry (&keywords, tp->string, strlen (tp->string), &keyword_value) == 0) { /* TODO: Shouldn't we use the shapes of the keyword, instead of hardwiring argnum1 = 1 ? const struct callshapes *shapes = (const struct callshapes *) keyword_value; */ struct callshapes shapes; shapes.keyword = tp->string; /* XXX storage duration? */ shapes.keyword_len = strlen (tp->string); shapes.nshapes = 1; shapes.shapes[0].argnum1 = 1; shapes.shapes[0].argnum2 = 0; shapes.shapes[0].argnumc = 0; shapes.shapes[0].argnum1_glib_context = false; shapes.shapes[0].argnum2_glib_context = false; shapes.shapes[0].argtotal = 0; string_list_init (&shapes.shapes[0].xcomments); { /* Extract a possible string from the key. Before proceeding we check whether the open curly is followed by a symbol and then by a right curly. */ flag_context_list_iterator_ty context_iter = flag_context_list_iterator ( flag_context_list_table_lookup ( flag_context_list_table, tp->string, strlen (tp->string))); token_ty *t1 = x_perl_lex (mlp); #if DEBUG_PERL fprintf (stderr, "%s:%d: extracting string key\n", real_file_name, line_number); #endif if (t1->type == token_type_symbol || t1->type == token_type_named_op) { token_ty *t2 = x_perl_lex (mlp); if (t2->type == token_type_rbrace) { flag_context_ty context; lex_pos_ty pos; context = inherited_context (null_context, flag_context_list_iterator_advance ( &context_iter)); pos.line_number = line_number; pos.file_name = logical_file_name; xgettext_current_source_encoding = po_charset_utf8; remember_a_message (mlp, NULL, xstrdup (t1->string), context, &pos, NULL, savable_comment); xgettext_current_source_encoding = xgettext_global_source_encoding; free_token (t2); free_token (t1); } else { x_perl_unlex (t2); } } else { x_perl_unlex (t1); if (extract_balanced (mlp, token_type_rbrace, true, false, null_context, context_iter, 1, arglist_parser_alloc (mlp, &shapes))) return; } } } else { phase2_ungetc (c); } } else { phase2_ungetc (c); } } /* Now consume "->", "[...]", and "{...}". */ for (;;) { int c = phase2_getc (); int c2; switch (c) { case '{': #if DEBUG_PERL fprintf (stderr, "%s:%d: extracting balanced '{' after varname\n", real_file_name, line_number); #endif extract_balanced (mlp, token_type_rbrace, true, false, null_context, null_context_list_iterator, 1, arglist_parser_alloc (mlp, NULL)); break; case '[': #if DEBUG_PERL fprintf (stderr, "%s:%d: extracting balanced '[' after varname\n", real_file_name, line_number); #endif extract_balanced (mlp, token_type_rbracket, true, false, null_context, null_context_list_iterator, 1, arglist_parser_alloc (mlp, NULL)); break; case '-': c2 = phase1_getc (); if (c2 == '>') { #if DEBUG_PERL fprintf (stderr, "%s:%d: another \"->\" after varname\n", real_file_name, line_number); #endif break; } else if (c2 != '\n') { /* Discarding the newline is harmless here. The only special character recognized after a minus is greater-than for dereference. However, the sequence "-\n>" that we treat incorrectly here, is a syntax error. */ phase1_ungetc (c2); } /* FALLTHROUGH */ default: #if DEBUG_PERL fprintf (stderr, "%s:%d: variable finished\n", real_file_name, line_number); #endif phase2_ungetc (c); return; } } } /* Actually a simplified version of extract_variable(). It searches for variables inside a double-quoted string that may interpolate to some keyword hash (reference). The string is UTF-8 encoded. */ static void interpolate_keywords (message_list_ty *mlp, const char *string, int lineno) { static char *buffer; static int bufmax = 0; int bufpos = 0; flag_context_ty context; int c; bool maybe_hash_deref = false; enum parser_state { initial, one_dollar, two_dollars, identifier, minus, wait_lbrace, wait_quote, dquote, squote, barekey, wait_rbrace } state; token_ty token; lex_pos_ty pos; /* States are: * * initial: initial * one_dollar: dollar sign seen in state INITIAL * two_dollars: another dollar-sign has been seen in state ONE_DOLLAR * identifier: a valid identifier character has been seen in state * ONE_DOLLAR or TWO_DOLLARS * minus: a minus-sign has been seen in state IDENTIFIER * wait_lbrace: a greater-than has been seen in state MINUS * wait_quote: a left brace has been seen in state IDENTIFIER or in * state WAIT_LBRACE * dquote: a double-quote has been seen in state WAIT_QUOTE * squote: a single-quote has been seen in state WAIT_QUOTE * barekey: an bareword character has been seen in state WAIT_QUOTE * wait_rbrace: closing quote has been seen in state DQUOTE or SQUOTE * * In the states initial...identifier the context is null_context; in the * states minus...wait_rbrace the context is the one suitable for the first * argument of the last seen identifier. */ state = initial; context = null_context; token.type = token_type_string; token.sub_type = string_type_qq; token.line_number = line_number; /* No need for token.comment = add_reference (savable_comment); here. We can let token.comment uninitialized here, and use savable_comment directly, because this function only parses the given string and does not call phase2_getc. */ pos.file_name = logical_file_name; pos.line_number = lineno; while ((c = (unsigned char) *string++) != '\0') { void *keyword_value; if (state == initial) bufpos = 0; if (c == '\n') lineno++; if (bufpos + 1 >= bufmax) { bufmax = 2 * bufmax + 10; buffer = xrealloc (buffer, bufmax); } switch (state) { case initial: switch (c) { case '\\': c = (unsigned char) *string++; if (c == '\0') return; break; case '$': buffer[bufpos++] = '$'; maybe_hash_deref = false; state = one_dollar; break; default: break; } break; case one_dollar: switch (c) { case '$': /* * This is enough to make us believe later that we dereference * a hash reference. */ maybe_hash_deref = true; state = two_dollars; break; default: if (c == '_' || c == ':' || c == '\'' || c >= 0x80 || (c >= 'A' && c <= 'Z') || (c >= 'a' && c <= 'z') || (c >= '0' && c <= '9')) { buffer[bufpos++] = c; state = identifier; } else state = initial; break; } break; case two_dollars: if (c == '_' || c == ':' || c == '\'' || c >= 0x80 || (c >= 'A' && c <= 'Z') || (c >= 'a' && c <= 'z') || (c >= '0' && c <= '9')) { buffer[bufpos++] = c; state = identifier; } else state = initial; break; case identifier: switch (c) { case '-': if (hash_find_entry (&keywords, buffer, bufpos, &keyword_value) == 0) { flag_context_list_iterator_ty context_iter = flag_context_list_iterator ( flag_context_list_table_lookup ( flag_context_list_table, buffer, bufpos)); context = inherited_context (null_context, flag_context_list_iterator_advance ( &context_iter)); state = minus; } else state = initial; break; case '{': if (!maybe_hash_deref) buffer[0] = '%'; if (hash_find_entry (&keywords, buffer, bufpos, &keyword_value) == 0) { flag_context_list_iterator_ty context_iter = flag_context_list_iterator ( flag_context_list_table_lookup ( flag_context_list_table, buffer, bufpos)); context = inherited_context (null_context, flag_context_list_iterator_advance ( &context_iter)); state = wait_quote; } else state = initial; break; default: if (c == '_' || c == ':' || c == '\'' || c >= 0x80 || (c >= 'A' && c <= 'Z') || (c >= 'a' && c <= 'z') || (c >= '0' && c <= '9')) { buffer[bufpos++] = c; } else state = initial; break; } break; case minus: switch (c) { case '>': state = wait_lbrace; break; default: context = null_context; state = initial; break; } break; case wait_lbrace: switch (c) { case '{': state = wait_quote; break; default: context = null_context; state = initial; break; } break; case wait_quote: switch (c) { case_whitespace: break; case '\'': pos.line_number = lineno; bufpos = 0; state = squote; break; case '"': pos.line_number = lineno; bufpos = 0; state = dquote; break; default: if (c == '_' || (c >= '0' && c <= '9') || c >= 0x80 || (c >= 'A' && c <= 'Z') || (c >= 'a' && c <= 'z')) { pos.line_number = lineno; bufpos = 0; buffer[bufpos++] = c; state = barekey; } else { context = null_context; state = initial; } break; } break; case dquote: switch (c) { case '"': /* The resulting string has to be interpolated twice. */ buffer[bufpos] = '\0'; token.string = xstrdup (buffer); extract_quotelike_pass3 (&token, EXIT_FAILURE); /* The string can only shrink with interpolation (because we ignore \Q). */ if (!(strlen (token.string) <= bufpos)) abort (); strcpy (buffer, token.string); free (token.string); state = wait_rbrace; break; case '\\': if (string[0] == '\"') { buffer[bufpos++] = string++[0]; } else if (string[0]) { buffer[bufpos++] = '\\'; buffer[bufpos++] = string++[0]; } else { context = null_context; state = initial; } break; default: buffer[bufpos++] = c; break; } break; case squote: switch (c) { case '\'': state = wait_rbrace; break; case '\\': if (string[0] == '\'') { buffer[bufpos++] = string++[0]; } else if (string[0]) { buffer[bufpos++] = '\\'; buffer[bufpos++] = string++[0]; } else { context = null_context; state = initial; } break; default: buffer[bufpos++] = c; break; } break; case barekey: if (c == '_' || (c >= '0' && c <= '9') || c >= 0x80 || (c >= 'A' && c <= 'Z') || (c >= 'a' && c <= 'z')) { buffer[bufpos++] = c; break; } else if (is_whitespace (c)) { state = wait_rbrace; break; } else if (c != '}') { context = null_context; state = initial; break; } /* Must be right brace. */ /* FALLTHROUGH */ case wait_rbrace: switch (c) { case_whitespace: break; case '}': buffer[bufpos] = '\0'; token.string = xstrdup (buffer); extract_quotelike_pass3 (&token, EXIT_FAILURE); xgettext_current_source_encoding = po_charset_utf8; remember_a_message (mlp, NULL, token.string, context, &pos, NULL, savable_comment); xgettext_current_source_encoding = xgettext_global_source_encoding; /* FALLTHROUGH */ default: context = null_context; state = initial; break; } break; } } } /* There is an ambiguity about '/' and '?': They can start an operator (division operator '/' or '/=' or the conditional operator '?'), or they can start a regular expression. The distinction is important because inside regular expressions, '#' loses its special meaning. This function helps making the decision (a heuristic). See the documentation for details. */ static bool prefer_regexp_over_division (token_type_ty type) { bool retval = true; switch (type) { case token_type_eof: retval = true; break; case token_type_lparen: retval = true; break; case token_type_rparen: retval = false; break; case token_type_comma: retval = true; break; case token_type_fat_comma: retval = true; break; case token_type_dereference: retval = true; break; case token_type_semicolon: retval = true; break; case token_type_lbrace: retval = true; break; case token_type_rbrace: retval = false; break; case token_type_lbracket: retval = true; break; case token_type_rbracket: retval = false; break; case token_type_string: retval = false; break; case token_type_number: retval = false; break; case token_type_named_op: retval = true; break; case token_type_variable: retval = false; break; case token_type_object: retval = false; break; case token_type_symbol: case token_type_keyword_symbol: retval = true; break; case token_type_regex_op: retval = false; break; case token_type_dot: retval = true; break; case token_type_other: retval = true; break; } #if DEBUG_PERL token_ty ty; ty.type = type; fprintf (stderr, "Prefer regexp over division after %s: %s\n", token2string (&ty), retval ? "true" : "false"); #endif return retval; } /* Last token type seen in the stream. Important for the interpretation of slash and question mark. */ static token_type_ty last_token_type; /* Combine characters into tokens. Discard whitespace. */ static void x_perl_prelex (message_list_ty *mlp, token_ty *tp) { static char *buffer; static int bufmax; int bufpos; int c; for (;;) { c = phase2_getc (); tp->line_number = line_number; tp->last_type = last_token_type; switch (c) { case EOF: tp->type = token_type_eof; return; case '\n': if (last_non_comment_line > last_comment_line) savable_comment_reset (); /* FALLTHROUGH */ case '\t': case ' ': /* Ignore whitespace. */ continue; case '%': case '@': case '*': case '$': if (!extract_all) { extract_variable (mlp, tp, c); return; } break; } last_non_comment_line = tp->line_number; switch (c) { case '.': { int c2 = phase1_getc (); phase1_ungetc (c2); if (c2 == '.') { tp->type = token_type_other; return; } else if (!(c2 >= '0' && c2 <= '9')) { tp->type = token_type_dot; return; } } /* FALLTHROUGH */ case 'A': case 'B': case 'C': case 'D': case 'E': case 'F': case 'G': case 'H': case 'I': case 'J': case 'K': case 'L': case 'M': case 'N': case 'O': case 'P': case 'Q': case 'R': case 'S': case 'T': case 'U': case 'V': case 'W': case 'X': case 'Y': case 'Z': case '_': case 'a': case 'b': case 'c': case 'd': case 'e': case 'f': case 'g': case 'h': case 'i': case 'j': case 'k': case 'l': case 'm': case 'n': case 'o': case 'p': case 'q': case 'r': case 's': case 't': case 'u': case 'v': case 'w': case 'x': case 'y': case 'z': case '0': case '1': case '2': case '3': case '4': case '5': case '6': case '7': case '8': case '9': /* Symbol, or part of a number. */ bufpos = 0; for (;;) { if (bufpos >= bufmax) { bufmax = 2 * bufmax + 10; buffer = xrealloc (buffer, bufmax); } buffer[bufpos++] = c; c = phase1_getc (); switch (c) { case 'A': case 'B': case 'C': case 'D': case 'E': case 'F': case 'G': case 'H': case 'I': case 'J': case 'K': case 'L': case 'M': case 'N': case 'O': case 'P': case 'Q': case 'R': case 'S': case 'T': case 'U': case 'V': case 'W': case 'X': case 'Y': case 'Z': case '_': case 'a': case 'b': case 'c': case 'd': case 'e': case 'f': case 'g': case 'h': case 'i': case 'j': case 'k': case 'l': case 'm': case 'n': case 'o': case 'p': case 'q': case 'r': case 's': case 't': case 'u': case 'v': case 'w': case 'x': case 'y': case 'z': case '0': case '1': case '2': case '3': case '4': case '5': case '6': case '7': case '8': case '9': continue; default: phase1_ungetc (c); break; } break; } if (bufpos >= bufmax) { bufmax = 2 * bufmax + 10; buffer = xrealloc (buffer, bufmax); } buffer[bufpos] = '\0'; if (strcmp (buffer, "__END__") == 0 || strcmp (buffer, "__DATA__") == 0) { end_of_file = true; tp->type = token_type_eof; return; } else if (strcmp (buffer, "and") == 0 || strcmp (buffer, "cmp") == 0 || strcmp (buffer, "eq") == 0 || strcmp (buffer, "if") == 0 || strcmp (buffer, "ge") == 0 || strcmp (buffer, "gt") == 0 || strcmp (buffer, "le") == 0 || strcmp (buffer, "lt") == 0 || strcmp (buffer, "ne") == 0 || strcmp (buffer, "not") == 0 || strcmp (buffer, "or") == 0 || strcmp (buffer, "unless") == 0 || strcmp (buffer, "while") == 0 || strcmp (buffer, "xor") == 0) { tp->type = token_type_named_op; tp->string = xstrdup (buffer); return; } else if (strcmp (buffer, "s") == 0 || strcmp (buffer, "y") == 0 || strcmp (buffer, "tr") == 0) { int delim = phase1_getc (); while (is_whitespace (delim)) delim = phase2_getc (); if (delim == EOF) { tp->type = token_type_eof; return; } if ((delim >= '0' && delim <= '9') || (delim >= 'A' && delim <= 'Z') || (delim >= 'a' && delim <= 'z')) { /* False positive. */ phase2_ungetc (delim); tp->type = token_type_symbol; tp->sub_type = symbol_type_none; tp->string = xstrdup (buffer); return; } extract_triple_quotelike (mlp, tp, delim, buffer[0] == 's' && delim != '\''); /* Eat the following modifiers. */ do c = phase1_getc (); while (c >= 'a' && c <= 'z'); phase1_ungetc (c); return; } else if (strcmp (buffer, "m") == 0) { int delim = phase1_getc (); while (is_whitespace (delim)) delim = phase2_getc (); if (delim == EOF) { tp->type = token_type_eof; return; } if ((delim >= '0' && delim <= '9') || (delim >= 'A' && delim <= 'Z') || (delim >= 'a' && delim <= 'z')) { /* False positive. */ phase2_ungetc (delim); tp->type = token_type_symbol; tp->sub_type = symbol_type_none; tp->string = xstrdup (buffer); return; } extract_quotelike (tp, delim); if (delim != '\'') interpolate_keywords (mlp, tp->string, line_number); free (tp->string); drop_reference (tp->comment); tp->type = token_type_regex_op; /* Eat the following modifiers. */ do c = phase1_getc (); while (c >= 'a' && c <= 'z'); phase1_ungetc (c); return; } else if (strcmp (buffer, "qq") == 0 || strcmp (buffer, "q") == 0 || strcmp (buffer, "qx") == 0 || strcmp (buffer, "qw") == 0 || strcmp (buffer, "qr") == 0) { /* The qw (...) construct is not really a string but we can treat in the same manner and then pretend it is a symbol. Rationale: Saying "qw (foo bar)" is the same as "my @list = ('foo', 'bar'); @list;". */ int delim = phase1_getc (); while (is_whitespace (delim)) delim = phase2_getc (); if (delim == EOF) { tp->type = token_type_eof; return; } if ((delim >= '0' && delim <= '9') || (delim >= 'A' && delim <= 'Z') || (delim >= 'a' && delim <= 'z')) { /* False positive. */ phase2_ungetc (delim); tp->type = token_type_symbol; tp->sub_type = symbol_type_none; tp->string = xstrdup (buffer); return; } extract_quotelike (tp, delim); switch (buffer[1]) { case 'q': case 'x': tp->type = token_type_string; tp->sub_type = string_type_qq; interpolate_keywords (mlp, tp->string, line_number); break; case 'r': drop_reference (tp->comment); tp->type = token_type_regex_op; break; case 'w': drop_reference (tp->comment); tp->type = token_type_symbol; tp->sub_type = symbol_type_none; break; case '\0': tp->type = token_type_string; tp->sub_type = string_type_q; break; default: abort (); } return; } else if ((buffer[0] >= '0' && buffer[0] <= '9') || buffer[0] == '.') { tp->type = token_type_number; return; } tp->type = token_type_symbol; tp->sub_type = (strcmp (buffer, "sub") == 0 ? symbol_type_sub : symbol_type_none); tp->string = xstrdup (buffer); return; case '"': extract_quotelike (tp, c); tp->sub_type = string_type_qq; interpolate_keywords (mlp, tp->string, line_number); return; case '`': extract_quotelike (tp, c); tp->sub_type = string_type_qq; interpolate_keywords (mlp, tp->string, line_number); return; case '\'': extract_quotelike (tp, c); tp->sub_type = string_type_q; return; case '(': c = phase2_getc (); if (c == ')') /* Ignore empty list. */ continue; else phase2_ungetc (c); tp->type = token_type_lparen; return; case ')': tp->type = token_type_rparen; return; case '{': tp->type = token_type_lbrace; return; case '}': tp->type = token_type_rbrace; return; case '[': tp->type = token_type_lbracket; return; case ']': tp->type = token_type_rbracket; return; case ';': tp->type = token_type_semicolon; return; case ',': tp->type = token_type_comma; return; case '=': /* Check for fat comma. */ c = phase1_getc (); if (c == '>') { tp->type = token_type_fat_comma; return; } else if (linepos == 2 && (last_token_type == token_type_semicolon || last_token_type == token_type_rbrace) && ((c >= 'A' && c <='Z') || (c >= 'a' && c <= 'z'))) { #if DEBUG_PERL fprintf (stderr, "%s:%d: start pod section\n", real_file_name, line_number); #endif skip_pod (); #if DEBUG_PERL fprintf (stderr, "%s:%d: end pod section\n", real_file_name, line_number); #endif continue; } phase1_ungetc (c); tp->type = token_type_other; return; case '<': /* Check for <string); free (tp->string); tp->string = string; tp->type = token_type_string; tp->sub_type = string_type_verbatim; tp->line_number = line_number + 1; return; } else if (c == '"') { char *string; extract_quotelike (tp, c); string = get_here_document (tp->string); free (tp->string); tp->string = string; tp->type = token_type_string; tp->sub_type = string_type_qq; tp->line_number = line_number + 1; interpolate_keywords (mlp, tp->string, tp->line_number); return; } else if ((c >= 'A' && c <= 'Z') || (c >= 'a' && c <= 'z') || c == '_') { bufpos = 0; while ((c >= 'A' && c <= 'Z') || (c >= 'a' && c <= 'z') || (c >= '0' && c <= '9') || c == '_' || c >= 0x80) { if (bufpos >= bufmax) { bufmax = 2 * bufmax + 10; buffer = xrealloc (buffer, bufmax); } buffer[bufpos++] = c; c = phase1_getc (); } if (c == EOF) { tp->type = token_type_eof; return; } else { char *string; phase1_ungetc (c); if (bufpos >= bufmax) { bufmax = 2 * bufmax + 10; buffer = xrealloc (buffer, bufmax); } buffer[bufpos++] = '\0'; string = get_here_document (buffer); tp->string = string; tp->type = token_type_string; tp->sub_type = string_type_qq; tp->comment = add_reference (savable_comment); tp->line_number = line_number + 1; interpolate_keywords (mlp, tp->string, tp->line_number); return; } } else { tp->type = token_type_other; return; } } else { phase1_ungetc (c); tp->type = token_type_other; } return; /* End of case '>'. */ case '-': /* Check for dereferencing operator. */ c = phase1_getc (); if (c == '>') { tp->type = token_type_dereference; return; } else if ((c >= 'A' && c <= 'Z') || (c >= 'a' && c <= 'z')) { /* One of the -X (filetest) functions. We play safe and accept all alphabetical characters here. */ tp->type = token_type_other; return; } phase1_ungetc (c); tp->type = token_type_other; return; case '/': case '?': if (prefer_regexp_over_division (tp->last_type)) { extract_quotelike (tp, c); interpolate_keywords (mlp, tp->string, line_number); free (tp->string); drop_reference (tp->comment); tp->type = token_type_regex_op; /* Eat the following modifiers. */ do c = phase1_getc (); while (c >= 'a' && c <= 'z'); phase1_ungetc (c); return; } /* Recognize operator '//'. */ if (c == '/') { c = phase1_getc (); if (c != '/') phase1_ungetc (c); } /* FALLTHROUGH */ default: /* We could carefully recognize each of the 2 and 3 character operators, but it is not necessary, except for the '//' operator, as we only need to recognize gettext invocations. Don't bother. */ tp->type = token_type_other; return; } } } /* A token stack used as a lookahead buffer. */ typedef struct token_stack_ty token_stack_ty; struct token_stack_ty { token_ty **items; size_t nitems; size_t nitems_max; }; static struct token_stack_ty token_stack; #if DEBUG_PERL /* Dumps all resources allocated by stack STACK. */ static int token_stack_dump (token_stack_ty *stack) { size_t i; fprintf (stderr, "BEGIN STACK DUMP\n"); for (i = 0; i < stack->nitems; i++) { token_ty *token = stack->items[i]; fprintf (stderr, " [%s]\n", token2string (token)); switch (token->type) { case token_type_named_op: case token_type_string: case token_type_symbol: case token_type_variable: fprintf (stderr, " string: %s\n", token->string); break; case token_type_object: fprintf (stderr, " string: %s->\n", token->string); default: break; } } fprintf (stderr, "END STACK DUMP\n"); return 0; } #endif /* Pushes the token TOKEN onto the stack STACK. */ static inline void token_stack_push (token_stack_ty *stack, token_ty *token) { if (stack->nitems >= stack->nitems_max) { size_t nbytes; stack->nitems_max = 2 * stack->nitems_max + 4; nbytes = stack->nitems_max * sizeof (token_ty *); stack->items = xrealloc (stack->items, nbytes); } stack->items[stack->nitems++] = token; } /* Pops the most recently pushed token from the stack STACK and returns it. Returns NULL if the stack is empty. */ static inline token_ty * token_stack_pop (token_stack_ty *stack) { if (stack->nitems > 0) return stack->items[--(stack->nitems)]; else return NULL; } /* Return the top of the stack without removing it from the stack, or NULL if the stack is empty. */ static inline token_ty * token_stack_peek (const token_stack_ty *stack) { if (stack->nitems > 0) return stack->items[stack->nitems - 1]; else return NULL; } /* Frees all resources allocated by stack STACK. */ static inline void token_stack_free (token_stack_ty *stack) { size_t i; for (i = 0; i < stack->nitems; i++) free_token (stack->items[i]); free (stack->items); } static token_ty * x_perl_lex (message_list_ty *mlp) { #if DEBUG_PERL int dummy = token_stack_dump (&token_stack); #endif token_ty *tp = token_stack_pop (&token_stack); if (!tp) { tp = XMALLOC (token_ty); x_perl_prelex (mlp, tp); tp->last_type = last_token_type; last_token_type = tp->type; #if DEBUG_PERL fprintf (stderr, "%s:%d: x_perl_prelex returned %s\n", real_file_name, line_number, token2string (tp)); #endif /* The interpretation of a slash or question mark after a function call depends on the prototype of that function. If the function expects at least one argument, a regular expression is preferred, otherwise an operator. With our limited means, we can only guess here. If the function is a builtin that takes no arguments, we prefer an operator by silently turning the last symbol into a variable instead of a symbol. Method calls without parentheses are not ambiguous. After them, an operator must follow. Due to some ideosyncrasies in this parser they are treated in two different manners. If the call is chained ($foo->bar->baz) the token left of the symbol is a dereference operator. If it is not chained ($foo->bar) the dereference operator is consumed with the extracted variable. The latter case is handled below. */ if (tp->type == token_type_symbol) { if (tp->last_type == token_type_dereference) { /* Class method call or chained method call (with at least two arrow operators). */ last_token_type = token_type_variable; } else if (tp->last_type == token_type_object) { /* Instance method, not chained. */ last_token_type = token_type_variable; } else if (strcmp (tp->string, "wantarray") == 0 || strcmp (tp->string, "fork") == 0 || strcmp (tp->string, "getlogin") == 0 || strcmp (tp->string, "getppid") == 0 || strcmp (tp->string, "getpwent") == 0 || strcmp (tp->string, "getgrent") == 0 || strcmp (tp->string, "gethostent") == 0 || strcmp (tp->string, "getnetent") == 0 || strcmp (tp->string, "getprotoent") == 0 || strcmp (tp->string, "getservent") == 0 || strcmp (tp->string, "setpwent") == 0 || strcmp (tp->string, "setgrent") == 0 || strcmp (tp->string, "endpwent") == 0 || strcmp (tp->string, "endgrent") == 0 || strcmp (tp->string, "endhostent") == 0 || strcmp (tp->string, "endnetent") == 0 || strcmp (tp->string, "endprotoent") == 0 || strcmp (tp->string, "endservent") == 0 || strcmp (tp->string, "time") == 0 || strcmp (tp->string, "times") == 0 || strcmp (tp->string, "wait") == 0 || strcmp (tp->string, "wantarray") == 0) { /* A Perl built-in function that does not accept arguments. */ last_token_type = token_type_variable; } } } #if DEBUG_PERL else { fprintf (stderr, "%s:%d: %s recycled from stack\n", real_file_name, line_number, token2string (tp)); } #endif /* A symbol followed by a fat comma is really a single-quoted string. Function definitions or forward declarations also need a special handling because the dollars and at signs inside the parentheses must not be interpreted as the beginning of a variable ')'. */ if (tp->type == token_type_symbol || tp->type == token_type_named_op) { token_ty *next = token_stack_peek (&token_stack); if (!next) { #if DEBUG_PERL fprintf (stderr, "%s:%d: pre-fetching next token\n", real_file_name, line_number); #endif next = x_perl_lex (mlp); x_perl_unlex (next); #if DEBUG_PERL fprintf (stderr, "%s:%d: unshifted next token\n", real_file_name, line_number); #endif } #if DEBUG_PERL fprintf (stderr, "%s:%d: next token is %s\n", real_file_name, line_number, token2string (next)); #endif if (next->type == token_type_fat_comma) { tp->type = token_type_string; tp->sub_type = string_type_q; tp->comment = add_reference (savable_comment); #if DEBUG_PERL fprintf (stderr, "%s:%d: token %s mutated to token_type_string\n", real_file_name, line_number, token2string (tp)); #endif } else if (tp->type == token_type_symbol && tp->sub_type == symbol_type_sub && next->type == token_type_symbol) { /* Start of a function declaration or definition. Mark this symbol as a function name, so that we can later eat up possible prototype information. */ #if DEBUG_PERL fprintf (stderr, "%s:%d: subroutine declaration/definition '%s'\n", real_file_name, line_number, next->string); #endif next->sub_type = symbol_type_function; } else if (tp->type == token_type_symbol && (tp->sub_type == symbol_type_sub || tp->sub_type == symbol_type_function) && next->type == token_type_lparen) { /* For simplicity we simply consume everything up to the closing parenthesis. Actually only a limited set of characters is allowed inside parentheses but we leave complaints to the interpreter and are prepared for future extensions to the Perl syntax. */ int c; #if DEBUG_PERL fprintf (stderr, "%s:%d: consuming prototype information\n", real_file_name, line_number); #endif do { c = phase1_getc (); #if DEBUG_PERL fprintf (stderr, " consuming character '%c'\n", c); #endif } while (c != EOF && c != ')'); phase1_ungetc (c); } } return tp; } static void x_perl_unlex (token_ty *tp) { token_stack_push (&token_stack, tp); } /* ========================= Extracting strings. ========================== */ /* Assuming TP is a string token, this function accumulates all subsequent . string2 . string3 ... to the string. (String concatenation.) */ static char * collect_message (message_list_ty *mlp, token_ty *tp, int error_level) { char *string; size_t len; extract_quotelike_pass3 (tp, error_level); string = xstrdup (tp->string); len = strlen (tp->string) + 1; for (;;) { int c; do c = phase2_getc (); while (is_whitespace (c)); if (c != '.') { phase2_ungetc (c); return string; } do c = phase2_getc (); while (is_whitespace (c)); phase2_ungetc (c); if (c == '"' || c == '\'' || c == '`' || ((c == '/' || c == '?') && prefer_regexp_over_division (tp->last_type)) || c == 'q') { token_ty *qstring = x_perl_lex (mlp); if (qstring->type != token_type_string) { /* assert (qstring->type == token_type_symbol) */ x_perl_unlex (qstring); return string; } extract_quotelike_pass3 (qstring, error_level); len += strlen (qstring->string); string = xrealloc (string, len); strcat (string, qstring->string); free_token (qstring); } } } /* The file is broken into tokens. Scan the token stream, looking for a keyword, followed by a left paren, followed by a string. When we see this sequence, we have something to remember. We assume we are looking at a valid Perl program, and leave the complaints about the grammar to the compiler. Normal handling: Look for keyword ( ... msgid ... ) Plural handling: Look for keyword ( ... msgid ... msgid_plural ... ) We use recursion because the arguments before msgid or between msgid and msgid_plural can contain subexpressions of the same form. In Perl, parentheses around function arguments can be omitted. The general rules are: 1) Functions declared with a prototype take exactly the specified number of arguments. sub one_arg ($) { ... } sub two_args ($$) { ... } 2) When a function name is immediately followed by an opening parenthesis, the argument list ends at the corresponding closing parenthesis. If rule 1 and rule 2 are contradictory, i.e. when the program calls a function with an explicit argument list and the wrong number of arguments, the program is invalid: sub two_args ($$) { ... } foo two_args (x), y - invalid due to rules 1 and 2 Ambiguities are resolved as follows: 3) Some built-ins, such as 'abs', 'sqrt', 'sin', 'cos', ..., and functions declared with a prototype of exactly one argument take exactly one argument: foo sin x, y ==> foo (sin (x), y) sub one_arg ($) { ... } foo one_arg x, y, z ==> foo (one_arg (x), y, z) 4) Other identifiers, if not immediately followed by an opening parenthesis, consume the entire remaining argument list: foo bar x, y ==> foo (bar (x, y)) sub two_args ($$) { ... } foo two_args x, y ==> foo (two_args (x, y)) Other series of comma separated expressions without a function name at the beginning are comma expressions: sub two_args ($$) { ... } foo two_args x, (y, z) ==> foo (two_args (x, (y, z))) Note that the evaluation of comma expressions returns a list of values when in list context (e.g. inside the argument list of a function without prototype) but only one value when inside the argument list of a function with a prototype: sub print3 ($$$) { print @_ } print3 5, (6, 7), 8 ==> 578 print 5, (6, 7), 8 ==> 5678 Where rule 3 or 4 contradict rule 1 or 2, the program is invalid: sin (x, y) - invalid due to rules 2 and 3 sub one_arg ($) { ... } one_arg (x, y) - invalid due to rules 2 and 3 sub two_args ($$) { ... } foo two_args x, y, z - invalid due to rules 1 and 4 */ /* Extract messages until the next balanced closing parenthesis. Extracted messages are added to MLP. DELIM can be either token_type_rbrace, token_type_rbracket, token_type_rparen. Additionally, if COMMA_DELIM is true, parsing stops at the next comma outside parentheses. ARG is the current argument list position, starts with 1. ARGPARSER is the corresponding argument list parser. Returns true for EOF, false otherwise. */ static bool extract_balanced (message_list_ty *mlp, token_type_ty delim, bool eat_delim, bool comma_delim, flag_context_ty outer_context, flag_context_list_iterator_ty context_iter, int arg, struct arglist_parser *argparser) { /* Whether to implicitly assume the next tokens are arguments even without a '('. */ bool next_is_argument = false; /* Parameters of the keyword just seen. Defined only when next_is_argument is true. */ const struct callshapes *next_shapes = NULL; struct arglist_parser *next_argparser = NULL; /* Whether to not consider strings until the next comma. */ bool skip_until_comma = false; /* Context iterator that will be used if the next token is a '('. */ flag_context_list_iterator_ty next_context_iter = passthrough_context_list_iterator; /* Current context. */ flag_context_ty inner_context = inherited_context (outer_context, flag_context_list_iterator_advance (&context_iter)); #if DEBUG_PERL static int nesting_level = 0; ++nesting_level; #endif for (;;) { /* The current token. */ token_ty *tp; tp = x_perl_lex (mlp); if (delim == tp->type) { xgettext_current_source_encoding = po_charset_utf8; arglist_parser_done (argparser, arg); xgettext_current_source_encoding = xgettext_global_source_encoding; if (next_argparser != NULL) free (next_argparser); #if DEBUG_PERL fprintf (stderr, "%s:%d: extract_balanced finished (%d)\n", logical_file_name, tp->line_number, --nesting_level); #endif if (eat_delim) free_token (tp); else /* Preserve the delimiter for the caller. */ x_perl_unlex (tp); return false; } if (comma_delim && tp->type == token_type_comma) { xgettext_current_source_encoding = po_charset_utf8; arglist_parser_done (argparser, arg); xgettext_current_source_encoding = xgettext_global_source_encoding; if (next_argparser != NULL) free (next_argparser); #if DEBUG_PERL fprintf (stderr, "%s:%d: extract_balanced finished at comma (%d)\n", logical_file_name, tp->line_number, --nesting_level); #endif x_perl_unlex (tp); return false; } if (next_is_argument && tp->type != token_type_lparen) { /* An argument list starts, even though there is no '('. */ bool next_comma_delim; x_perl_unlex (tp); if (next_shapes != NULL) /* We know something about the function being called. Assume that it consumes only one argument if no argument number or total > 1 is specified. */ { size_t i; next_comma_delim = true; for (i = 0; i < next_shapes->nshapes; i++) { const struct callshape *shape = &next_shapes->shapes[i]; if (shape->argnum1 > 1 || shape->argnum2 > 1 || shape->argnumc > 1 || shape->argtotal > 1) next_comma_delim = false; } } else /* We know nothing about the function being called. It could be a function prototyped to take only one argument, or on the other hand it could be prototyped to take more than one argument or an arbitrary argument list or it could be unprototyped. Due to the way the parser works, assuming the first case gives the best results. */ next_comma_delim = true; if (extract_balanced (mlp, delim, false, next_comma_delim, inner_context, next_context_iter, 1, next_argparser)) { xgettext_current_source_encoding = po_charset_utf8; arglist_parser_done (argparser, arg); xgettext_current_source_encoding = xgettext_global_source_encoding; return true; } next_is_argument = false; next_argparser = NULL; next_context_iter = null_context_list_iterator; continue; } switch (tp->type) { case token_type_symbol: case token_type_keyword_symbol: #if DEBUG_PERL fprintf (stderr, "%s:%d: type symbol (%d) \"%s\"\n", logical_file_name, tp->line_number, nesting_level, tp->string); #endif { void *keyword_value; if (hash_find_entry (&keywords, tp->string, strlen (tp->string), &keyword_value) == 0) { const struct callshapes *shapes = (const struct callshapes *) keyword_value; next_shapes = shapes; next_argparser = arglist_parser_alloc (mlp, shapes); } else { next_shapes = NULL; next_argparser = arglist_parser_alloc (mlp, NULL); } } next_is_argument = true; next_context_iter = flag_context_list_iterator ( flag_context_list_table_lookup ( flag_context_list_table, tp->string, strlen (tp->string))); break; case token_type_variable: #if DEBUG_PERL fprintf (stderr, "%s:%d: type variable (%d) \"%s\"\n", logical_file_name, tp->line_number, nesting_level, tp->string); #endif next_is_argument = false; if (next_argparser != NULL) free (next_argparser); next_argparser = NULL; next_context_iter = null_context_list_iterator; break; case token_type_object: #if DEBUG_PERL fprintf (stderr, "%s:%d: type object (%d) \"%s->\"\n", logical_file_name, tp->line_number, nesting_level, tp->string); #endif next_is_argument = false; if (next_argparser != NULL) free (next_argparser); next_argparser = NULL; next_context_iter = null_context_list_iterator; break; case token_type_lparen: #if DEBUG_PERL fprintf (stderr, "%s:%d: type left parenthesis (%d)\n", logical_file_name, tp->line_number, nesting_level); #endif if (next_is_argument) { /* Parse the argument list of a function call. */ if (extract_balanced (mlp, token_type_rparen, true, false, inner_context, next_context_iter, 1, next_argparser)) { xgettext_current_source_encoding = po_charset_utf8; arglist_parser_done (argparser, arg); xgettext_current_source_encoding = xgettext_global_source_encoding; return true; } next_is_argument = false; next_argparser = NULL; } else { /* Parse a parenthesized expression or comma expression. */ if (extract_balanced (mlp, token_type_rparen, true, false, inner_context, next_context_iter, arg, arglist_parser_clone (argparser))) { xgettext_current_source_encoding = po_charset_utf8; arglist_parser_done (argparser, arg); xgettext_current_source_encoding = xgettext_global_source_encoding; if (next_argparser != NULL) free (next_argparser); free_token (tp); return true; } next_is_argument = false; if (next_argparser != NULL) free (next_argparser); next_argparser = NULL; } skip_until_comma = true; next_context_iter = null_context_list_iterator; break; case token_type_rparen: #if DEBUG_PERL fprintf (stderr, "%s:%d: type right parenthesis (%d)\n", logical_file_name, tp->line_number, nesting_level); #endif next_is_argument = false; if (next_argparser != NULL) free (next_argparser); next_argparser = NULL; skip_until_comma = true; next_context_iter = null_context_list_iterator; break; case token_type_comma: case token_type_fat_comma: #if DEBUG_PERL fprintf (stderr, "%s:%d: type comma (%d)\n", logical_file_name, tp->line_number, nesting_level); #endif if (arglist_parser_decidedp (argparser, arg)) { /* We have missed the argument. */ xgettext_current_source_encoding = po_charset_utf8; arglist_parser_done (argparser, arg); xgettext_current_source_encoding = xgettext_global_source_encoding; argparser = arglist_parser_alloc (mlp, NULL); arg = 0; } arg++; #if DEBUG_PERL fprintf (stderr, "%s:%d: arg: %d\n", real_file_name, tp->line_number, arg); #endif inner_context = inherited_context (outer_context, flag_context_list_iterator_advance ( &context_iter)); next_is_argument = false; if (next_argparser != NULL) free (next_argparser); next_argparser = NULL; skip_until_comma = false; next_context_iter = passthrough_context_list_iterator; break; case token_type_string: #if DEBUG_PERL fprintf (stderr, "%s:%d: type string (%d): \"%s\"\n", logical_file_name, tp->line_number, nesting_level, tp->string); #endif if (extract_all) { char *string = collect_message (mlp, tp, EXIT_SUCCESS); lex_pos_ty pos; pos.file_name = logical_file_name; pos.line_number = tp->line_number; xgettext_current_source_encoding = po_charset_utf8; remember_a_message (mlp, NULL, string, inner_context, &pos, NULL, tp->comment); xgettext_current_source_encoding = xgettext_global_source_encoding; } else if (!skip_until_comma) { /* Need to collect the complete string, with error checking, only if the argument ARG is used in ARGPARSER. */ bool must_collect = false; { size_t nalternatives = argparser->nalternatives; size_t i; for (i = 0; i < nalternatives; i++) { struct partial_call *cp = &argparser->alternative[i]; if (arg == cp->argnumc || arg == cp->argnum1 || arg == cp->argnum2) must_collect = true; } } if (must_collect) { char *string = collect_message (mlp, tp, EXIT_FAILURE); xgettext_current_source_encoding = po_charset_utf8; arglist_parser_remember (argparser, arg, string, inner_context, logical_file_name, tp->line_number, tp->comment); xgettext_current_source_encoding = xgettext_global_source_encoding; } } if (arglist_parser_decidedp (argparser, arg)) { xgettext_current_source_encoding = po_charset_utf8; arglist_parser_done (argparser, arg); xgettext_current_source_encoding = xgettext_global_source_encoding; argparser = arglist_parser_alloc (mlp, NULL); } next_is_argument = false; if (next_argparser != NULL) free (next_argparser); next_argparser = NULL; next_context_iter = null_context_list_iterator; break; case token_type_number: #if DEBUG_PERL fprintf (stderr, "%s:%d: type number (%d)\n", logical_file_name, tp->line_number, nesting_level); #endif next_is_argument = false; if (next_argparser != NULL) free (next_argparser); next_argparser = NULL; next_context_iter = null_context_list_iterator; break; case token_type_eof: #if DEBUG_PERL fprintf (stderr, "%s:%d: type EOF (%d)\n", logical_file_name, tp->line_number, nesting_level); #endif xgettext_current_source_encoding = po_charset_utf8; arglist_parser_done (argparser, arg); xgettext_current_source_encoding = xgettext_global_source_encoding; if (next_argparser != NULL) free (next_argparser); next_argparser = NULL; free_token (tp); return true; case token_type_lbrace: #if DEBUG_PERL fprintf (stderr, "%s:%d: type lbrace (%d)\n", logical_file_name, tp->line_number, nesting_level); #endif if (extract_balanced (mlp, token_type_rbrace, true, false, null_context, null_context_list_iterator, 1, arglist_parser_alloc (mlp, NULL))) { xgettext_current_source_encoding = po_charset_utf8; arglist_parser_done (argparser, arg); xgettext_current_source_encoding = xgettext_global_source_encoding; if (next_argparser != NULL) free (next_argparser); free_token (tp); return true; } next_is_argument = false; if (next_argparser != NULL) free (next_argparser); next_argparser = NULL; next_context_iter = null_context_list_iterator; break; case token_type_rbrace: #if DEBUG_PERL fprintf (stderr, "%s:%d: type rbrace (%d)\n", logical_file_name, tp->line_number, nesting_level); #endif next_is_argument = false; if (next_argparser != NULL) free (next_argparser); next_argparser = NULL; next_context_iter = null_context_list_iterator; break; case token_type_lbracket: #if DEBUG_PERL fprintf (stderr, "%s:%d: type lbracket (%d)\n", logical_file_name, tp->line_number, nesting_level); #endif if (extract_balanced (mlp, token_type_rbracket, true, false, null_context, null_context_list_iterator, 1, arglist_parser_alloc (mlp, NULL))) { xgettext_current_source_encoding = po_charset_utf8; arglist_parser_done (argparser, arg); xgettext_current_source_encoding = xgettext_global_source_encoding; if (next_argparser != NULL) free (next_argparser); free_token (tp); return true; } next_is_argument = false; if (next_argparser != NULL) free (next_argparser); next_argparser = NULL; next_context_iter = null_context_list_iterator; break; case token_type_rbracket: #if DEBUG_PERL fprintf (stderr, "%s:%d: type rbracket (%d)\n", logical_file_name, tp->line_number, nesting_level); #endif next_is_argument = false; if (next_argparser != NULL) free (next_argparser); next_argparser = NULL; next_context_iter = null_context_list_iterator; break; case token_type_semicolon: #if DEBUG_PERL fprintf (stderr, "%s:%d: type semicolon (%d)\n", logical_file_name, tp->line_number, nesting_level); #endif /* The ultimate sign. */ xgettext_current_source_encoding = po_charset_utf8; arglist_parser_done (argparser, arg); xgettext_current_source_encoding = xgettext_global_source_encoding; argparser = arglist_parser_alloc (mlp, NULL); /* FIXME: Instead of resetting outer_context here, it may be better to recurse in the next_is_argument handling above, waiting for the next semicolon or other statement terminator. */ outer_context = null_context; context_iter = null_context_list_iterator; next_is_argument = false; if (next_argparser != NULL) free (next_argparser); next_argparser = NULL; next_context_iter = passthrough_context_list_iterator; inner_context = inherited_context (outer_context, flag_context_list_iterator_advance ( &context_iter)); break; case token_type_dereference: #if DEBUG_PERL fprintf (stderr, "%s:%d: type dereference (%d)\n", logical_file_name, tp->line_number, nesting_level); #endif next_is_argument = false; if (next_argparser != NULL) free (next_argparser); next_argparser = NULL; next_context_iter = null_context_list_iterator; break; case token_type_dot: #if DEBUG_PERL fprintf (stderr, "%s:%d: type dot (%d)\n", logical_file_name, tp->line_number, nesting_level); #endif next_is_argument = false; if (next_argparser != NULL) free (next_argparser); next_argparser = NULL; next_context_iter = null_context_list_iterator; break; case token_type_named_op: #if DEBUG_PERL fprintf (stderr, "%s:%d: type named operator (%d): %s\n", logical_file_name, tp->line_number, nesting_level, tp->string); #endif next_is_argument = false; if (next_argparser != NULL) free (next_argparser); next_argparser = NULL; next_context_iter = null_context_list_iterator; break; case token_type_regex_op: #if DEBUG_PERL fprintf (stderr, "%s:%d: type regex operator (%d)\n", logical_file_name, tp->line_number, nesting_level); #endif next_is_argument = false; if (next_argparser != NULL) free (next_argparser); next_argparser = NULL; next_context_iter = null_context_list_iterator; break; case token_type_other: #if DEBUG_PERL fprintf (stderr, "%s:%d: type other (%d)\n", logical_file_name, tp->line_number, nesting_level); #endif next_is_argument = false; if (next_argparser != NULL) free (next_argparser); next_argparser = NULL; next_context_iter = null_context_list_iterator; break; default: fprintf (stderr, "%s:%d: unknown token type %d\n", real_file_name, tp->line_number, tp->type); abort (); } free_token (tp); } } void extract_perl (FILE *f, const char *real_filename, const char *logical_filename, flag_context_list_table_ty *flag_table, msgdomain_list_ty *mdlp) { message_list_ty *mlp = mdlp->item[0]->messages; fp = f; real_file_name = real_filename; logical_file_name = xstrdup (logical_filename); line_number = 0; last_comment_line = -1; last_non_comment_line = -1; flag_context_list_table = flag_table; init_keywords (); token_stack.items = NULL; token_stack.nitems = 0; token_stack.nitems_max = 0; linesize = 0; linepos = 0; eaten_here = 0; end_of_file = false; /* Safe assumption. */ last_token_type = token_type_semicolon; /* Eat tokens until eof is seen. When extract_balanced returns due to an unbalanced closing brace, just restart it. */ while (!extract_balanced (mlp, token_type_rbrace, true, false, null_context, null_context_list_iterator, 1, arglist_parser_alloc (mlp, NULL))) ; fp = NULL; real_file_name = NULL; free (logical_file_name); logical_file_name = NULL; line_number = 0; last_token_type = token_type_semicolon; token_stack_free (&token_stack); eaten_here = 0; end_of_file = true; }