xgettext: In language Tcl, avoid a crash at surrogate character escapes.

* gettext-tools/src/x-tcl.c (accumulate_word): Warn when seeing a surrogate
character, instead of aborting.
* gettext-tools/tests/xgettext-tcl-5: New file.
* gettext-tools/tests/Makefile.am (TESTS): Add it.

diff --git a/gettext-tools/src/x-tcl.c b/gettext-tools/src/x-tcl.c
index e3df627792472df815036d52a1c225bcf66ddfa9..5fcfe4f851c5c123cd7e0dbf463b3eb668da64c9 100644 (file)
--- a/gettext-tools/src/x-tcl.c
+++ b/gettext-tools/src/x-tcl.c
@@ -707,13 +707,23 @@ accumulate_word (struct word *wp, enum terminator looking_for,
           uc = do_getc_escaped ();
           assert (uc < 0x10000);
           count = u8_uctomb (utf8buf, uc, 6);
-          assert (count > 0);
-          if (wp->type == t_string)
-            for (i = 0; i < count; i++)
-              {
-                grow_token (wp->token);
-                wp->token->chars[wp->token->charcount++] = utf8buf[i];
-              }
+          if (count < 0)
+            {
+              error_with_progname = false;
+              error (0, 0, _("%s:%d: warning: invalid Unicode character"),
+                     logical_file_name, line_number);
+              error_with_progname = true;
+            }
+          else
+            {
+              assert (count > 0);
+              if (wp->type == t_string)
+                for (i = 0; i < count; i++)
+                  {
+                    grow_token (wp->token);
+                    wp->token->chars[wp->token->charcount++] = utf8buf[i];
+                  }
+            }
         }
       else
         {

diff --git a/gettext-tools/tests/Makefile.am b/gettext-tools/tests/Makefile.am
index 10d9756b38255355cfb36d15bc9303893bf19fa4..95638e9ec8adb1416cd1bef7f7c22c151301b471 100644 (file)
--- a/gettext-tools/tests/Makefile.am
+++ b/gettext-tools/tests/Makefile.am
@@ -156,6 +156,7 @@ TESTS = gettext-1 gettext-2 \
        xgettext-smalltalk-1 xgettext-smalltalk-2 \
        xgettext-stringtable-1 \
        xgettext-tcl-1 xgettext-tcl-2 xgettext-tcl-3 xgettext-tcl-4 \
+       xgettext-tcl-5 \
        xgettext-tcl-stackovfl-1 xgettext-tcl-stackovfl-2 \
        xgettext-tcl-stackovfl-3 xgettext-tcl-stackovfl-4 \
        xgettext-vala-1 xgettext-vala-2 xgettext-vala-3 xgettext-vala-4 \

diff --git a/gettext-tools/tests/xgettext-tcl-5 b/gettext-tools/tests/xgettext-tcl-5
new file mode 100755 (executable)
index 0000000..1c0ee9f
--- /dev/null
+++ b/gettext-tools/tests/xgettext-tcl-5
@@ -0,0 +1,26 @@
+#!/bin/sh
+. "${srcdir=.}/init.sh"; path_prepend_ . ../src
+
+# Test of Tcl support: escape sequences with unpaired surrogates.
+
+cat <<\EOF > xg-t-5a.tcl
+puts [_ "\uD83D"]
+EOF
+
+cat <<\EOF > xg-t-5b.tcl
+puts [_ "\udc1c"]
+EOF
+
+: ${XGETTEXT=xgettext}
+LANGUAGE= LC_ALL=C ${XGETTEXT} --no-location -k_ -d xg-t-5.tmp xg-t-5a.tcl 2>xg-t-5.err
+result=$?
+cat xg-t-5.err
+test $result = 0 || Exit 1
+
+: ${XGETTEXT=xgettext}
+LANGUAGE= LC_ALL=C ${XGETTEXT} --no-location -k_ -d xg-t-5.tmp xg-t-5b.tcl 2>xg-t-5.err
+result=$?
+cat xg-t-5.err
+test $result = 0 || Exit 1
+
+exit 0