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.

3 files changed, 44 insertions, 7 deletions

diff --git a/gettext-tools/src/x-tcl.c b/gettext-tools/src/x-tcl.c
index e3df62779..5fcfe4f85 100644
--- 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 10d9756b3..95638e9ec 100644
--- 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
index 000000000..1c0ee9fdd
--- /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