Improve and future-proof OTF fonts support in w32uniscribe.c

* src/w32uniscribe.c (uniscribe_otf_capability): Add commentary
about the expected results and why the new Uniscribe APIs are not
used in this function.
(ScriptGetFontScriptTags_Proc, ScriptGetFontLanguageTags_Proc)
(ScriptGetFontFeatureTags_Proc): New function typedefs.
(uniscribe_new_apis): New static variable.
(uniscribe_check_features): New function, implements OTF features
verification while correctly accounting for features in the list
after the nil member, if any.
(uniscribe_check_otf_1): New function, retrieves the features
supported by the font for the requested script and language using
the Uniscribe APIs available from Windows Vista onwards.
(uniscribe_check_otf): If the new Uniscribe APIs are available,
use them in preference to reading the font data directly.  Call
uniscribe_check_features to verify that the requested features are
supported, replacing the original incomplete code.
(syms_of_w32uniscribe): Initialize function pointers for the new
Uniscribe APIs.  (Bug#21260)
(otf_features): Scan the script, langsys, and feature arrays back
to front, so that the result we return has them in alphabetical
order, like ftfont.c does.
* src/w32fns.c (syms_of_w32fns) <w32-disable-new-uniscribe-apis>:
New variable for debugging w32uniscribe.c code.

2 files changed, 253 insertions, 41 deletions

diff --git a/src/w32fns.c b/src/w32fns.c
index 189a27c62f1..e91097ba20e 100644
--- a/src/w32fns.c
+++ b/src/w32fns.c
@@ -9242,6 +9242,16 @@ Default is nil.
 This variable has effect only on NT family of systems, not on Windows 9X.  */);
   w32_use_fallback_wm_chars_method = 0;
 
+  DEFVAR_BOOL ("w32-disable-new-uniscribe-apis",
+               w32_disable_new_uniscribe_apis,
+               doc: /* Non-nil means don't use new Uniscribe APIs.
+The new APIs are used to access OTF features supported by fonts.
+This is intended only for debugging of the new Uniscribe-related code.
+Default is nil.
+
+This variable has effect only on Windows Vista and later.  */);
+  w32_disable_new_uniscribe_apis = 0;
+
 #if 0 /* TODO: Port to W32 */
   defsubr (&Sx_change_window_property);
   defsubr (&Sx_delete_window_property);
diff --git a/src/w32uniscribe.c b/src/w32uniscribe.c
index 73c0410c7b7..b1056bc104e 100644
--- a/src/w32uniscribe.c
+++ b/src/w32uniscribe.c
@@ -141,7 +141,26 @@ uniscribe_close (struct font *font)
 }
 
 /* Return a list describing which scripts/languages FONT supports by
-   which GSUB/GPOS features of OpenType tables.  */
+   which GSUB/GPOS features of OpenType tables.
+
+   Implementation note: otf_features called by this function uses
+   GetFontData to access the font tables directly, instead of using
+   ScriptGetFontScriptTags etc. APIs even if those are available.  The
+   reason is that font-get, which uses the result of this function,
+   expects a cons cell (GSUB . GPOS) where the features are reported
+   separately for these 2 OTF tables, while the Uniscribe APIs report
+   the features as a single list.  There doesn't seem to be a reason
+   for returning the features in 2 separate parts, except for
+   compatibility with libotf; the features are disjoint (each can
+   appear only in one of the 2 slots), and no client of this data
+   discerns between the two slots: the few that request this data all
+   look in both slots.  If use of the Uniscribe APIs ever becomes
+   necessary here, and the 2 separate slots are still required, it
+   should be possible to split the feature list the APIs return into 2
+   because each sub-list is alphabetically sorted, so the place where
+   the sorting order breaks is where the GSUB features end and GPOS
+   features begin.  But for now, this is not necessary, so we leave
+   the original code in place.  */
 static Lisp_Object
 uniscribe_otf_capability (struct font *font)
 {
@@ -643,7 +662,7 @@ add_opentype_font_name_to_list (ENUMLOGFONTEX *logical_font,
 
 /* :otf property handling.
    Since the necessary Uniscribe APIs for getting font tag information
-   are only available in Vista, we need to parse the font data directly
+   are only available in Vista, we may need to parse the font data directly
    according to the OpenType Specification.  */
 
 /* Push into DWORD backwards to cope with endianness.  */
@@ -674,7 +693,171 @@ add_opentype_font_name_to_list (ENUMLOGFONTEX *logical_font,
     STR[4] = '\0';                                           \
   } while (0)
 
-#define SNAME(VAL) SDATA (SYMBOL_NAME (VAL))
+#define SNAME(VAL) SSDATA (SYMBOL_NAME (VAL))
+
+/* Uniscribe APIs available only since Windows Vista.  */
+typedef HRESULT (WINAPI *ScriptGetFontScriptTags_Proc)
+  (HDC, SCRIPT_CACHE *, SCRIPT_ANALYSIS *, int, OPENTYPE_TAG *, int *);
+
+typedef HRESULT (WINAPI *ScriptGetFontLanguageTags_Proc)
+  (HDC, SCRIPT_CACHE *, SCRIPT_ANALYSIS *, OPENTYPE_TAG, int, OPENTYPE_TAG *, int *);
+
+typedef HRESULT (WINAPI *ScriptGetFontFeatureTags_Proc)
+  (HDC, SCRIPT_CACHE *, SCRIPT_ANALYSIS *, OPENTYPE_TAG, OPENTYPE_TAG, int, OPENTYPE_TAG *, int *);
+
+ScriptGetFontScriptTags_Proc script_get_font_scripts_fn;
+ScriptGetFontLanguageTags_Proc script_get_font_languages_fn;
+ScriptGetFontFeatureTags_Proc script_get_font_features_fn;
+
+static bool uniscribe_new_apis;
+
+/* Verify that all the required features in FEATURES, each of whose
+   elements is a list or nil, can be found among the N feature tags in
+   FTAGS.  Return 'true' if the required features are supported,
+   'false' if not.  Each list in FEATURES can include an element of
+   nil, which means all the elements after it must not be in FTAGS.  */
+static bool
+uniscribe_check_features (Lisp_Object features[2], OPENTYPE_TAG *ftags, int n)
+{
+  int j;
+
+  for (j = 0; j < 2; j++)
+    {
+      bool negative = false;
+      Lisp_Object rest;
+
+      for (rest = features[j]; CONSP (rest); rest = XCDR (rest))
+        {
+          Lisp_Object feature = XCAR (rest);
+
+          /* The font must NOT have any of the features after nil.
+             See the doc string of 'font-spec', under ':otf'.  */
+          if (NILP (feature))
+            negative = true;
+          else
+            {
+              OPENTYPE_TAG feature_tag = OTF_TAG (SNAME (feature));
+              int i;
+
+              for (i = 0; i < n; i++)
+                {
+                  if (ftags[i] == feature_tag)
+                    {
+                      /* Test fails if we find a feature that the font
+                         must NOT have.  */
+                      if (negative)
+                        return false;
+                      break;
+                    }
+                }
+
+              /* Test fails if we do NOT find a feature that the font
+                 should have.  */
+              if (i >= n && !negative)
+                return false;
+            }
+        }
+    }
+
+  return true;
+}
+
+/* Check if font supports the required OTF script/language/features
+   using the Unsicribe APIs available since Windows Vista.  We prefer
+   these APIs as a kind of future-proofing Emacs: they seem to
+   retrieve script tags that the old code (and also libotf) doesn't
+   seem to be able to get, e.g., some fonts that claim support for
+   "dev2" script don't show "deva", but the new APIs do report it.  */
+static int
+uniscribe_check_otf_1 (HDC context, Lisp_Object script, Lisp_Object lang,
+                       Lisp_Object features[2], int *retval)
+{
+  SCRIPT_CACHE cache = NULL;
+  OPENTYPE_TAG tags[32], script_tag, lang_tag;
+  int max_tags = ARRAYELTS (tags);
+  int ntags, i, ret = 0;
+  HRESULT rslt;
+  Lisp_Object rest;
+
+  *retval = 0;
+
+  rslt = script_get_font_scripts_fn (context, &cache, NULL, max_tags,
+                                     tags, &ntags);
+  if (FAILED (rslt))
+    {
+      DebPrint (("ScriptGetFontScriptTags failed with 0x%x\n", rslt));
+      ret = -1;
+      goto no_support;
+    }
+  if (NILP (script))
+    script_tag = OTF_TAG ("DFLT");
+  else
+    script_tag = OTF_TAG (SNAME (script));
+  for (i = 0; i < ntags; i++)
+    if (tags[i] == script_tag)
+      break;
+
+  if (i >= ntags)
+    goto no_support;
+
+  if (NILP (lang))
+    lang_tag = OTF_TAG ("dflt");
+  else
+    {
+      rslt = script_get_font_languages_fn (context, &cache, NULL, script_tag,
+                                           max_tags, tags, &ntags);
+      if (FAILED (rslt))
+        {
+          DebPrint (("ScriptGetFontLanguageTags failed with 0x%x\n", rslt));
+          ret = -1;
+          goto no_support;
+        }
+      if (ntags == 0)
+        lang_tag = OTF_TAG ("dflt");
+      else
+        {
+          lang_tag = OTF_TAG (SNAME (lang));
+          for (i = 0; i < ntags; i++)
+            if (tags[i] == lang_tag)
+              break;
+
+          if (i >= ntags)
+            goto no_support;
+        }
+    }
+
+  if (!NILP (features[0]))
+    {
+      /* Are the 2 feature lists valid?  */
+      if (!CONSP (features[0])
+          || (!NILP (features[1]) && !CONSP (features[1])))
+        goto no_support;
+      rslt = script_get_font_features_fn (context, &cache, NULL,
+                                          script_tag, lang_tag,
+                                          max_tags, tags, &ntags);
+      if (FAILED (rslt))
+        {
+          DebPrint (("ScriptGetFontFeatureTags failed with 0x%x\n", rslt));
+          ret = -1;
+          goto no_support;
+        }
+
+      /* ScriptGetFontFeatureTags doesn't let us query features
+         separately for GSUB and GPOS, so we check them all together.
+         It doesn't really matter, since the features in GSUB and GPOS
+         are disjoint, i.e. no feature can appear in both tables.  */
+      if (!uniscribe_check_features (features, tags, ntags))
+        goto no_support;
+    }
+
+  ret = 1;
+  *retval = 1;
+
+ no_support:
+  if (cache)
+    ScriptFreeCache (&cache);
+  return ret;
+}
 
 /* Check if font supports the otf script/language/features specified.
    OTF_SPEC is in the format
@@ -710,6 +893,18 @@ uniscribe_check_otf (LOGFONT *font, Lisp_Object otf_spec)
   else
     features[1] = XCAR (rest);
 
+  /* Set up graphics context so we can use the font.  */
+  f = XFRAME (selected_frame);
+  context = get_frame_dc (f);
+  check_font = CreateFontIndirect (font);
+  old_font = SelectObject (context, check_font);
+
+  /* If we are on Vista or later, use the new APIs.  */
+  if (uniscribe_new_apis
+      && !w32_disable_new_uniscribe_apis
+      && uniscribe_check_otf_1 (context, script, lang, features, &retval) != -1)
+    goto done;
+
   /* Set up tags we will use in the search.  */
   feature_tables[0] = OTF_TAG ("GSUB");
   feature_tables[1] = OTF_TAG ("GPOS");
@@ -721,12 +916,6 @@ uniscribe_check_otf (LOGFONT *font, Lisp_Object otf_spec)
   if (!NILP (lang))
     lang_tag = OTF_TAG (SNAME (lang));
 
-  /* Set up graphics context so we can use the font.  */
-  f = XFRAME (selected_frame);
-  context = get_frame_dc (f);
-  check_font = CreateFontIndirect (font);
-  old_font = SelectObject (context, check_font);
-
   /* Everything else is contained within otf_spec so should get
      marked along with it.  */
   GCPRO1 (otf_spec);
@@ -739,6 +928,8 @@ uniscribe_check_otf (LOGFONT *font, Lisp_Object otf_spec)
       unsigned short script_table, langsys_table, n_langs;
       unsigned short feature_index, n_features;
       DWORD tbl = feature_tables[i];
+      DWORD feature_id, *ftags;
+      Lisp_Object farray[2];
 
       /* Skip if no features requested from this table.  */
       if (NILP (features[i]))
@@ -805,51 +996,49 @@ uniscribe_check_otf (LOGFONT *font, Lisp_Object otf_spec)
       /* Offset is from beginning of script table.  */
       langsys_table += script_table;
 
-      /* Check the features.  Features may contain nil according to
-         documentation in font_prop_validate_otf, so count them.  */
-      n_match_features = 0;
-      for (rest = features[i]; CONSP (rest); rest = XCDR (rest))
-        {
-          Lisp_Object feature = XCAR (rest);
-          if (!NILP (feature))
-            n_match_features++;
-        }
-
       /* If there are no features to check, skip checking.  */
-      if (!n_match_features)
+      if (NILP (features[i]))
         continue;
+      if (!CONSP (features[i]))
+        goto no_support;
+
+      n_match_features = 0;
 
-      /* First check required feature (if any).  */
+      /* First get required feature (if any).  */
       OTF_INT16_VAL (tbl, langsys_table + 2, &feature_index);
       if (feature_index != 0xFFFF)
+        n_match_features = 1;
+      OTF_INT16_VAL (tbl, langsys_table + 4, &n_features);
+      n_match_features += n_features;
+      USE_SAFE_ALLOCA;
+      SAFE_NALLOCA (ftags, 1, n_match_features);
+      int k = 0;
+      if (feature_index != 0xFFFF)
         {
-          char feature_id[5];
-          OTF_TAG_VAL (tbl, feature_table + 2 + feature_index * 6, feature_id);
-          OTF_TAG_VAL (tbl, feature_table + 2 + feature_index * 6, feature_id);
-          /* Assume no duplicates in the font table. This allows us to mark
-             the features off by simply decrementing a counter.  */
-          if (!NILP (Fmemq (intern (feature_id), features[i])))
-            n_match_features--;
+          OTF_DWORDTAG_VAL (tbl, feature_table + 2 + feature_index * 6,
+                            &feature_id);
+          ftags[k++] = feature_id;
         }
-      /* Now check all the other features.  */
-      OTF_INT16_VAL (tbl, langsys_table + 4, &n_features);
+      /* Now get all the other features.  */
       for (j = 0; j < n_features; j++)
         {
-          char feature_id[5];
           OTF_INT16_VAL (tbl, langsys_table + 6 + j * 2, &feature_index);
-          OTF_TAG_VAL (tbl, feature_table + 2 + feature_index * 6, feature_id);
-          /* Assume no duplicates in the font table. This allows us to mark
-             the features off by simply decrementing a counter.  */
-          if (!NILP (Fmemq (intern (feature_id), features[i])))
-            n_match_features--;
+          OTF_DWORDTAG_VAL (tbl, feature_table + 2 + feature_index * 6,
+                            &feature_id);
+          ftags[k++] = feature_id;
         }
 
-      if (n_match_features > 0)
+      /* Check the features for this table.  */
+      farray[0] = features[i];
+      farray[1] = Qnil;
+      if (!uniscribe_check_features (farray, ftags, n_match_features))
         goto no_support;
+      SAFE_FREE ();
     }
 
   retval = 1;
 
+ done:
  no_support:
  font_table_error:
   /* restore graphics context.  */
@@ -873,7 +1062,7 @@ otf_features (HDC context, char *table)
   OTF_INT16_VAL (tbl, 6, &feature_table);
   OTF_INT16_VAL (tbl, scriptlist_table, &n_scripts);
 
-  for (i = 0; i < n_scripts; i++)
+  for (i = n_scripts - 1; i >= 0; i--)
     {
       char script[5], lang[5];
       unsigned short script_table, lang_count, langsys_table, feature_count;
@@ -898,7 +1087,7 @@ otf_features (HDC context, char *table)
           langsys_tag = Qnil;
           feature_list = Qnil;
           OTF_INT16_VAL (tbl, langsys_table + 4, &feature_count);
-          for (k = 0; k < feature_count; k++)
+          for (k = feature_count - 1; k >= 0; k--)
             {
               char feature[5];
               unsigned short index;
@@ -913,7 +1102,7 @@ otf_features (HDC context, char *table)
       /* List of supported languages.  */
       OTF_INT16_VAL (tbl, script_table + 2, &lang_count);
 
-      for (j = 0; j < lang_count; j++)
+      for (j = lang_count - 1; j >= 0; j--)
         {
           record_offset = script_table + 4 + j * 6;
           OTF_TAG_VAL (tbl, record_offset, lang);
@@ -925,7 +1114,7 @@ otf_features (HDC context, char *table)
           langsys_tag = intern (lang);
           feature_list = Qnil;
           OTF_INT16_VAL (tbl, langsys_table + 4, &feature_count);
-          for (k = 0; k < feature_count; k++)
+          for (k = feature_count - 1; k >= 0; k--)
             {
               char feature[5];
               unsigned short index;
@@ -1003,4 +1192,17 @@ syms_of_w32uniscribe (void)
   uniscribe_available = 1;
 
   register_font_driver (&uniscribe_font_driver, NULL);
+
+  script_get_font_scripts_fn = (ScriptGetFontScriptTags_Proc)
+    GetProcAddress (uniscribe, "ScriptGetFontScriptTags");
+  script_get_font_languages_fn = (ScriptGetFontLanguageTags_Proc)
+    GetProcAddress (uniscribe, "ScriptGetFontLanguageTags");
+  script_get_font_features_fn = (ScriptGetFontFeatureTags_Proc)
+    GetProcAddress (uniscribe, "ScriptGetFontFeatureTags");
+  if (script_get_font_scripts_fn
+      && script_get_font_languages_fn
+      && script_get_font_features_fn)
+    uniscribe_new_apis = true;
+  else
+    uniscribe_new_apis = false;
 }