root/src/w32uniscribe.c

/* [<][>][^][v][top][bottom][index][help] */

DEFINITIONS

This source file includes following definitions.
  1. memq_no_quit
  2. uniscribe_list
  3. uniscribe_match
  4. uniscribe_list_family
  5. uniscribe_open
  6. uniscribe_close
  7. uniscribe_otf_capability
  8. uniscribe_shape
  9. uniscribe_encode_char
  10. add_opentype_font_name_to_list
  11. uniscribe_check_features
  12. uniscribe_check_otf_1
  13. uniscribe_check_otf
  14. otf_features
  15. w32hb_list
  16. w32hb_match
  17. free_cb
  18. w32hb_get_font_table
  19. w32hb_get_font
  20. w32hb_encode_char
  21. w32hb_begin_font
  22. w32hb_get_variation_glyphs
  23. syms_of_w32uniscribe
  24. load_harfbuzz_funcs
  25. syms_of_w32uniscribe_for_pdumper
     1 /* Font backend for the Microsoft W32 Uniscribe API.
     2    Windows-specific parts of the HarfBuzz font backend.
     3    Copyright (C) 2008-2023 Free Software Foundation, Inc.
     4 
     5 This file is part of GNU Emacs.
     6 
     7 GNU Emacs is free software: you can redistribute it and/or modify
     8 it under the terms of the GNU General Public License as published by
     9 the Free Software Foundation, either version 3 of the License, or (at
    10 your option) any later version.
    11 
    12 GNU Emacs is distributed in the hope that it will be useful,
    13 but WITHOUT ANY WARRANTY; without even the implied warranty of
    14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    15 GNU General Public License for more details.
    16 
    17 You should have received a copy of the GNU General Public License
    18 along with GNU Emacs.  If not, see <https://www.gnu.org/licenses/>.  */
    19 
    20 
    21 #include <config.h>
    22 /* Override API version - Uniscribe is only available as standard
    23    since Windows 2000, though most users of older systems will have it
    24    since it installs with Internet Explorer 5.0 and other software.
    25    Also, MinGW64 w32api headers by default define OPENTYPE_TAG typedef
    26    only if _WIN32_WINNT >= 0x0600.  We only use the affected APIs if
    27    they are available, so there is no chance of calling non-existent
    28    functions.  */
    29 #undef _WIN32_WINNT
    30 #define _WIN32_WINNT 0x0600
    31 #include <windows.h>
    32 #include <usp10.h>
    33 #ifdef HAVE_HARFBUZZ
    34 # include <hb.h>
    35 # include <hb-ot.h>     /* for hb_ot_font_set_funcs */
    36 # if GNUC_PREREQ (4, 3, 0)
    37 #  define bswap_32(v)  __builtin_bswap32(v)
    38 # else
    39 #  include <byteswap.h>
    40 # endif
    41 #endif
    42 
    43 #include "lisp.h"
    44 #include "w32term.h"
    45 #include "frame.h"
    46 #include "composite.h"
    47 #include "font.h"
    48 #include "w32font.h"
    49 #include "pdumper.h"
    50 #include "w32common.h"
    51 
    52 /* Extension of w32font_info used by Uniscribe and HarfBuzz backends.  */
    53 struct uniscribe_font_info
    54 {
    55   struct w32font_info w32_font;
    56   /* This is used by the Uniscribe backend as a pointer to the script
    57      cache, and by the HarfBuzz backend as a pointer to a hb_font_t
    58      object.  */
    59   void *cache;
    60   /* This is used by the HarfBuzz backend to store the font scale.  */
    61   double scale;
    62 };
    63 
    64 int uniscribe_available = 0;
    65 
    66 /* EnumFontFamiliesEx callback.  */
    67 static int CALLBACK ALIGN_STACK add_opentype_font_name_to_list (ENUMLOGFONTEX *,
    68                                                                 NEWTEXTMETRICEX *,
    69                                                                 DWORD, LPARAM);
    70 #ifdef HAVE_HARFBUZZ
    71 
    72 struct font_driver harfbuzz_font_driver;
    73 int harfbuzz_available = 0;
    74 
    75 /* Typedefs for HarfBuzz functions which we call through function
    76    pointers initialized after we load the HarfBuzz DLL.  */
    77 DEF_DLL_FN (hb_blob_t *, hb_blob_create,
    78             (const char *, unsigned int, hb_memory_mode_t, void *,
    79              hb_destroy_func_t));
    80 DEF_DLL_FN (hb_face_t *, hb_face_create_for_tables,
    81             (hb_reference_table_func_t, void *, hb_destroy_func_t));
    82 DEF_DLL_FN (unsigned, hb_face_get_glyph_count, (const hb_face_t *));
    83 DEF_DLL_FN (hb_font_t *, hb_font_create, (hb_face_t *));
    84 DEF_DLL_FN (void, hb_font_destroy, (hb_font_t *));
    85 DEF_DLL_FN (void, hb_face_destroy, (hb_face_t *));
    86 DEF_DLL_FN (unsigned int, hb_face_get_upem, (hb_face_t *));
    87 DEF_DLL_FN (hb_bool_t, hb_font_get_nominal_glyph,
    88             (hb_font_t *, hb_codepoint_t, hb_codepoint_t *));
    89 DEF_DLL_FN (hb_bool_t, hb_font_get_variation_glyph,
    90             (hb_font_t *, hb_codepoint_t, hb_codepoint_t, hb_codepoint_t *));
    91 DEF_DLL_FN (void, hb_ot_font_set_funcs, (hb_font_t *));
    92 
    93 #define hb_blob_create fn_hb_blob_create
    94 #define hb_face_create_for_tables fn_hb_face_create_for_tables
    95 #define hb_face_get_glyph_count fn_hb_face_get_glyph_count
    96 #define hb_font_create fn_hb_font_create
    97 #define hb_font_destroy fn_hb_font_destroy
    98 #define hb_face_destroy fn_hb_face_destroy
    99 #define hb_face_get_upem fn_hb_face_get_upem
   100 #define hb_font_get_nominal_glyph fn_hb_font_get_nominal_glyph
   101 #define hb_font_get_variation_glyph fn_hb_font_get_variation_glyph
   102 #define hb_ot_font_set_funcs fn_hb_ot_font_set_funcs
   103 #endif
   104 
   105 /* Used by uniscribe_otf_capability.  */
   106 static Lisp_Object otf_features (HDC context, const char *table);
   107 
   108 static int
   109 memq_no_quit (Lisp_Object elt, Lisp_Object list)
   110 {
   111   while (CONSP (list) && ! EQ (XCAR (list), elt))
   112     list = XCDR (list);
   113   return (CONSP (list));
   114 }
   115 
   116 
   117 /* Font backend interface implementation.  */
   118 static Lisp_Object
   119 uniscribe_list (struct frame *f, Lisp_Object font_spec)
   120 {
   121   Lisp_Object fonts = w32font_list_internal (f, font_spec, true);
   122   FONT_ADD_LOG ("uniscribe-list", font_spec, fonts);
   123   return fonts;
   124 }
   125 
   126 static Lisp_Object
   127 uniscribe_match (struct frame *f, Lisp_Object font_spec)
   128 {
   129   Lisp_Object entity = w32font_match_internal (f, font_spec, true);
   130   FONT_ADD_LOG ("uniscribe-match", font_spec, entity);
   131   return entity;
   132 }
   133 
   134 static Lisp_Object
   135 uniscribe_list_family (struct frame *f)
   136 {
   137   Lisp_Object list = Qnil;
   138   LOGFONT font_match_pattern;
   139   HDC dc;
   140 
   141   memset (&font_match_pattern, 0, sizeof (font_match_pattern));
   142   /* Limit enumerated fonts to outline fonts to save time.  */
   143   font_match_pattern.lfOutPrecision = OUT_OUTLINE_PRECIS;
   144 
   145   /* Prevent quitting while EnumFontFamiliesEx runs and conses the
   146      list it will return.  That's because get_frame_dc acquires the
   147      critical section, so we cannot quit before we release it in
   148      release_frame_dc.  */
   149   Lisp_Object prev_quit = Vinhibit_quit;
   150   Vinhibit_quit = Qt;
   151   dc = get_frame_dc (f);
   152 
   153   EnumFontFamiliesEx (dc, &font_match_pattern,
   154                       (FONTENUMPROC) add_opentype_font_name_to_list,
   155                       (LPARAM) &list, 0);
   156   release_frame_dc (f, dc);
   157   Vinhibit_quit = prev_quit;
   158 
   159   return list;
   160 }
   161 
   162 static Lisp_Object
   163 uniscribe_open (struct frame *f, Lisp_Object font_entity, int pixel_size)
   164 {
   165   Lisp_Object font_object
   166     = font_make_object (VECSIZE (struct uniscribe_font_info),
   167                         font_entity, pixel_size);
   168   struct uniscribe_font_info *uniscribe_font
   169     = (struct uniscribe_font_info *) XFONT_OBJECT (font_object);
   170 
   171   if (!NILP (AREF (font_entity, FONT_TYPE_INDEX)))
   172     ASET (font_object, FONT_TYPE_INDEX, AREF (font_entity, FONT_TYPE_INDEX));
   173   else  /* paranoia: this should never happen */
   174     ASET (font_object, FONT_TYPE_INDEX, Quniscribe);
   175 
   176   if (!w32font_open_internal (f, font_entity, pixel_size, font_object))
   177     {
   178       return Qnil;
   179     }
   180 
   181   /* Initialize the cache for this font.  */
   182   uniscribe_font->cache = NULL;
   183 
   184   /* Uniscribe and HarfBuzz backends use glyph indices.  */
   185   uniscribe_font->w32_font.glyph_idx = ETO_GLYPH_INDEX;
   186 
   187 #ifdef HAVE_HARFBUZZ
   188   if (EQ (AREF (font_object, FONT_TYPE_INDEX), Qharfbuzz))
   189     uniscribe_font->w32_font.font.driver = &harfbuzz_font_driver;
   190   else
   191 #endif  /* HAVE_HARFBUZZ */
   192     uniscribe_font->w32_font.font.driver = &uniscribe_font_driver;
   193 
   194   return font_object;
   195 }
   196 
   197 static void
   198 uniscribe_close (struct font *font)
   199 {
   200   struct uniscribe_font_info *uniscribe_font
   201     = (struct uniscribe_font_info *) font;
   202 
   203 #ifdef HAVE_HARFBUZZ
   204   if (uniscribe_font->w32_font.font.driver == &harfbuzz_font_driver
   205       && uniscribe_font->cache)
   206     hb_font_destroy ((hb_font_t *) uniscribe_font->cache);
   207   else
   208 #endif
   209   if (uniscribe_font->cache)
   210     ScriptFreeCache ((SCRIPT_CACHE) &(uniscribe_font->cache));
   211 
   212   uniscribe_font->cache = NULL;
   213 
   214   w32font_close (font);
   215 }
   216 
   217 /* Return a list describing which scripts/languages FONT supports by
   218    which GSUB/GPOS features of OpenType tables.
   219 
   220    Implementation note: otf_features called by this function uses
   221    GetFontData to access the font tables directly, instead of using
   222    ScriptGetFontScriptTags etc. APIs even if those are available.  The
   223    reason is that font-get, which uses the result of this function,
   224    expects a cons cell (GSUB . GPOS) where the features are reported
   225    separately for these 2 OTF tables, while the Uniscribe APIs report
   226    the features as a single list.  There doesn't seem to be a reason
   227    for returning the features in 2 separate parts, except for
   228    compatibility with libotf; the features are disjoint (each can
   229    appear only in one of the 2 slots), and no client of this data
   230    discerns between the two slots: the few that request this data all
   231    look in both slots.  If use of the Uniscribe APIs ever becomes
   232    necessary here, and the 2 separate slots are still required, it
   233    should be possible to split the feature list the APIs return into 2
   234    because each sub-list is alphabetically sorted, so the place where
   235    the sorting order breaks is where the GSUB features end and GPOS
   236    features begin.  But for now, this is not necessary, so we leave
   237    the original code in place.  */
   238 static Lisp_Object
   239 uniscribe_otf_capability (struct font *font)
   240 {
   241   HDC context;
   242   HFONT old_font;
   243   struct frame *f;
   244   Lisp_Object capability = Fcons (Qnil, Qnil);
   245   Lisp_Object features;
   246 
   247   f = XFRAME (selected_frame);
   248   /* Prevent quitting while we cons the lists in otf_features.
   249      That's because get_frame_dc acquires the critical section, so we
   250      cannot quit before we release it in release_frame_dc.  */
   251   Lisp_Object prev_quit = Vinhibit_quit;
   252   Vinhibit_quit = Qt;
   253   context = get_frame_dc (f);
   254   old_font = SelectObject (context, FONT_HANDLE (font));
   255 
   256   features = otf_features (context, "GSUB");
   257   XSETCAR (capability, features);
   258   features = otf_features (context, "GPOS");
   259   XSETCDR (capability, features);
   260 
   261   SelectObject (context, old_font);
   262   release_frame_dc (f, context);
   263   Vinhibit_quit = prev_quit;
   264 
   265   return capability;
   266 }
   267 
   268 /* Uniscribe implementation of shape for font backend.
   269 
   270    Shape text in LGSTRING.  See the docstring of
   271    `composition-get-gstring' for the format of LGSTRING.  If the
   272    (N+1)th element of LGSTRING is nil, input of shaping is from the
   273    1st to (N)th elements.  In each input glyph, FROM, TO, CHAR, and
   274    CODE are already set.
   275    DIRECTION is either L2R or R2L, or nil if unknown.  During
   276    redisplay, this comes from applying the UBA, is passed from
   277    composition_reseat_it, and is used by the HarfBuzz shaper.
   278 
   279    This function updates all fields of the input glyphs.  If the
   280    output glyphs (M) are more than the input glyphs (N), (N+1)th
   281    through (M)th elements of LGSTRING are updated possibly by making
   282    a new glyph object and storing it in LGSTRING.  If (M) is greater
   283    than the length of LGSTRING, nil should be returned.  In that case,
   284    this function is called again with a larger LGSTRING.  */
   285 static Lisp_Object
   286 uniscribe_shape (Lisp_Object lgstring, Lisp_Object direction)
   287 {
   288   struct font *font = CHECK_FONT_GET_OBJECT (LGSTRING_FONT (lgstring));
   289   struct uniscribe_font_info *uniscribe_font
   290     = (struct uniscribe_font_info *) font;
   291   EMACS_UINT nchars;
   292   int nitems, max_items, i, max_glyphs, done_glyphs;
   293   wchar_t *chars;
   294   WORD *glyphs, *clusters;
   295   SCRIPT_ITEM *items;
   296   SCRIPT_VISATTR *attributes;
   297   int *advances;
   298   GOFFSET *offsets;
   299   ABC overall_metrics;
   300   HRESULT result;
   301   struct frame * f = NULL;
   302   HDC context = NULL;
   303   HFONT old_font = NULL;
   304 
   305   /* Get the chars from lgstring in a form we can use with uniscribe.  */
   306   max_glyphs = nchars = LGSTRING_GLYPH_LEN (lgstring);
   307   done_glyphs = 0;
   308   chars = (wchar_t *) alloca (nchars * sizeof (wchar_t));
   309   /* FIXME: This loop assumes that characters in the input LGSTRING
   310      are all inside the BMP.  Need to encode characters beyond the BMP
   311      as UTF-16.  */
   312   for (i = 0; i < nchars; i++)
   313     {
   314       /* lgstring can be bigger than the number of characters in it, in
   315          the case where more glyphs are required to display those characters.
   316          If that is the case, note the real number of characters.  */
   317       if (NILP (LGSTRING_GLYPH (lgstring, i)))
   318         nchars = i;
   319       else
   320         chars[i] = LGLYPH_CHAR (LGSTRING_GLYPH (lgstring, i));
   321     }
   322 
   323   /* First we need to break up the glyph string into runs of glyphs that
   324      can be treated together.  First try a single run.  */
   325   max_items = 2;
   326   items = xmalloc (sizeof (SCRIPT_ITEM) * max_items + 1);
   327 
   328   while ((result = ScriptItemize (chars, nchars, max_items, NULL, NULL,
   329                                   items, &nitems)) == E_OUTOFMEMORY)
   330     {
   331       /* If that wasn't enough, keep trying with one more run.  */
   332       max_items++;
   333       items = (SCRIPT_ITEM *) xrealloc (items,
   334                                         sizeof (SCRIPT_ITEM) * max_items + 1);
   335     }
   336 
   337   if (FAILED (result))
   338     {
   339       xfree (items);
   340       return Qnil;
   341     }
   342 
   343   glyphs = alloca (max_glyphs * sizeof (WORD));
   344   clusters = alloca (nchars * sizeof (WORD));
   345   attributes = alloca (max_glyphs * sizeof (SCRIPT_VISATTR));
   346   advances = alloca (max_glyphs * sizeof (int));
   347   offsets = alloca (max_glyphs * sizeof (GOFFSET));
   348 
   349   for (i = 0; i < nitems; i++)
   350     {
   351       int nglyphs, nchars_in_run;
   352       nchars_in_run = items[i+1].iCharPos - items[i].iCharPos;
   353       /* Force ScriptShape to generate glyphs in the same order as
   354          they are in the input LGSTRING, which is in the logical
   355          order.  */
   356       items[i].a.fLogicalOrder = 1;
   357 
   358       /* Context may be NULL here, in which case the cache should be
   359          used without needing to select the font.  */
   360       result = ScriptShape (context, (SCRIPT_CACHE) &(uniscribe_font->cache),
   361                             chars + items[i].iCharPos, nchars_in_run,
   362                             max_glyphs - done_glyphs, &(items[i].a),
   363                             glyphs, clusters, attributes, &nglyphs);
   364 
   365       if (result == E_PENDING && !context)
   366         {
   367           /* This assumes the selected frame is on the same display as the
   368              one we are drawing.  It would be better for the frame to be
   369              passed in.  */
   370           f = XFRAME (selected_frame);
   371           context = get_frame_dc (f);
   372           old_font = SelectObject (context, FONT_HANDLE (font));
   373 
   374           result = ScriptShape (context, (SCRIPT_CACHE) &(uniscribe_font->cache),
   375                                 chars + items[i].iCharPos, nchars_in_run,
   376                                 max_glyphs - done_glyphs, &(items[i].a),
   377                                 glyphs, clusters, attributes, &nglyphs);
   378         }
   379 
   380       if (result == E_OUTOFMEMORY)
   381         {
   382           /* Need a bigger lgstring.  */
   383           lgstring = Qnil;
   384           break;
   385         }
   386       else if (FAILED (result))
   387         {
   388           /* Can't shape this run - return results so far if any.  */
   389           break;
   390         }
   391       else if (items[i].a.fNoGlyphIndex)
   392         {
   393           /* Glyph indices not supported by this font (or OS), means we
   394              can't really do any meaningful shaping.  */
   395           break;
   396         }
   397       else
   398         {
   399           result = ScriptPlace (context, (SCRIPT_CACHE) &(uniscribe_font->cache),
   400                                 glyphs, nglyphs, attributes, &(items[i].a),
   401                                 advances, offsets, &overall_metrics);
   402           if (result == E_PENDING && !context)
   403             {
   404               /* Cache not complete...  */
   405               f = XFRAME (selected_frame);
   406               context = get_frame_dc (f);
   407               old_font = SelectObject (context, FONT_HANDLE (font));
   408 
   409               result = ScriptPlace (context,
   410                                     (SCRIPT_CACHE) &(uniscribe_font->cache),
   411                                     glyphs, nglyphs, attributes, &(items[i].a),
   412                                     advances, offsets, &overall_metrics);
   413             }
   414           if (SUCCEEDED (result))
   415             {
   416               int j, from, to, adj_offset = 0;
   417               int cluster_offset = 0;
   418 
   419               from = 0;
   420               to = from;
   421 
   422               for (j = 0; j < nglyphs; j++)
   423                 {
   424                   int lglyph_index = j + done_glyphs;
   425                   Lisp_Object lglyph = LGSTRING_GLYPH (lgstring, lglyph_index);
   426                   ABC char_metric;
   427                   unsigned gl;
   428 
   429                   if (NILP (lglyph))
   430                     {
   431                       lglyph = LGLYPH_NEW ();
   432                       LGSTRING_SET_GLYPH (lgstring, lglyph_index, lglyph);
   433                     }
   434                   /* Copy to a 32-bit data type to shut up the
   435                      compiler warning in LGLYPH_SET_CODE about
   436                      comparison being always false.  */
   437                   gl = glyphs[j];
   438                   LGLYPH_SET_CODE (lglyph, gl);
   439 
   440                   /* Detect clusters, for linking codes back to
   441                      characters.  */
   442                   if (attributes[j].fClusterStart)
   443                     {
   444                       while (from < nchars_in_run && clusters[from] < j)
   445                         from++;
   446                       if (from >= nchars_in_run)
   447                         from = to = nchars_in_run - 1;
   448                       else
   449                         {
   450                           int k;
   451                           to = nchars_in_run - 1;
   452                           for (k = from + 1; k < nchars_in_run; k++)
   453                             {
   454                               if (clusters[k] > j)
   455                                 {
   456                                   to = k - 1;
   457                                   break;
   458                                 }
   459                             }
   460                         }
   461                       cluster_offset = 0;
   462 
   463                       /* For RTL text, the Uniscribe shaper prepares
   464                          the values in ADVANCES array for layout in
   465                          reverse order, whereby "advance width" is
   466                          applied to move the pen in reverse direction
   467                          and _before_ drawing the glyph.  Since we
   468                          draw glyphs in their normal left-to-right
   469                          order, we need to adjust the coordinates of
   470                          each non-base glyph in a grapheme cluster via
   471                          X-OFF component of the gstring's ADJUSTMENT
   472                          sub-vector.  This loop computes, for each
   473                          grapheme cluster, the initial value of the
   474                          adjustment for the base character, which is
   475                          then updated for each successive glyph in the
   476                          grapheme cluster.  */
   477                       /* FIXME: Should we use DIRECTION here instead
   478                          of what ScriptItemize guessed?  */
   479                       if (items[i].a.fRTL)
   480                         {
   481                           int j1 = j;
   482 
   483                           adj_offset = 0;
   484                           while (j1 < nglyphs && !attributes[j1].fClusterStart)
   485                             {
   486                               adj_offset += advances[j1];
   487                               j1++;
   488                             }
   489                         }
   490                     }
   491 
   492                   int char_idx = items[i].iCharPos + from + cluster_offset;
   493                   if (from + cluster_offset > to)
   494                     char_idx = items[i].iCharPos + to;
   495                   cluster_offset++;
   496                   LGLYPH_SET_CHAR (lglyph, chars[char_idx]);
   497                   LGLYPH_SET_FROM (lglyph, items[i].iCharPos + from);
   498                   LGLYPH_SET_TO (lglyph, items[i].iCharPos + to);
   499 
   500                   /* Metrics.  */
   501                   LGLYPH_SET_WIDTH (lglyph, advances[j]);
   502                   LGLYPH_SET_ASCENT (lglyph, font->ascent);
   503                   LGLYPH_SET_DESCENT (lglyph, font->descent);
   504 
   505                   result = ScriptGetGlyphABCWidth
   506                     (context, (SCRIPT_CACHE) &(uniscribe_font->cache),
   507                      glyphs[j], &char_metric);
   508                   if (result == E_PENDING && !context)
   509                     {
   510                       /* Cache incomplete... */
   511                       f = XFRAME (selected_frame);
   512                       context = get_frame_dc (f);
   513                       old_font = SelectObject (context, FONT_HANDLE (font));
   514                       result = ScriptGetGlyphABCWidth
   515                         (context, (SCRIPT_CACHE) &(uniscribe_font->cache),
   516                          glyphs[j], &char_metric);
   517                     }
   518 
   519                   if (SUCCEEDED (result))
   520                     {
   521                       int lbearing = char_metric.abcA;
   522                       int rbearing = char_metric.abcA + char_metric.abcB;
   523 
   524                       LGLYPH_SET_LBEARING (lglyph, lbearing);
   525                       LGLYPH_SET_RBEARING (lglyph, rbearing);
   526                     }
   527                   else
   528                     {
   529                       LGLYPH_SET_LBEARING (lglyph, 0);
   530                       LGLYPH_SET_RBEARING (lglyph, advances[j]);
   531                     }
   532 
   533                   if (offsets[j].du || offsets[j].dv
   534                       /* For non-base glyphs of RTL grapheme clusters,
   535                          adjust the X offset even if both DU and DV
   536                          are zero.  */
   537                       || (!attributes[j].fClusterStart && items[i].a.fRTL))
   538                     {
   539                       Lisp_Object vec = make_uninit_vector (3);
   540 
   541                       if (items[i].a.fRTL)
   542                         {
   543                           /* Empirically, it looks like Uniscribe
   544                              interprets DU in reverse direction for
   545                              RTL clusters.  E.g., if we don't reverse
   546                              the direction, the Hebrew point HOLAM is
   547                              drawn above the right edge of the base
   548                              consonant, instead of above the left edge.  */
   549                           ASET (vec, 0, make_fixnum (-offsets[j].du
   550                                                      + adj_offset));
   551                           /* Update the adjustment value for the width
   552                              advance of the glyph we just emitted.  */
   553                           adj_offset -= 2 * advances[j];
   554                         }
   555                       else
   556                         ASET (vec, 0, make_fixnum (offsets[j].du + adj_offset));
   557                       /* In the font definition coordinate system, the
   558                          Y coordinate points up, while in our screen
   559                          coordinates Y grows downwards.  So we need to
   560                          reverse the sign of Y-OFFSET here.  */
   561                       ASET (vec, 1, make_fixnum (-offsets[j].dv));
   562                       /* Based on what ftfont.c does... */
   563                       ASET (vec, 2, make_fixnum (advances[j]));
   564                       LGLYPH_SET_ADJUSTMENT (lglyph, vec);
   565                     }
   566                   else
   567                     {
   568                       LGLYPH_SET_ADJUSTMENT (lglyph, Qnil);
   569                       /* Update the adjustment value to compensate for
   570                          the width of the base character.  */
   571                       if (items[i].a.fRTL)
   572                         adj_offset -= advances[j];
   573                     }
   574                 }
   575             }
   576         }
   577       done_glyphs += nglyphs;
   578     }
   579 
   580   xfree (items);
   581 
   582   if (context)
   583     {
   584       SelectObject (context, old_font);
   585       release_frame_dc (f, context);
   586     }
   587 
   588   if (NILP (lgstring))
   589     return Qnil;
   590   else
   591     return make_fixnum (done_glyphs);
   592 }
   593 
   594 /* Uniscribe implementation of encode_char for font backend.
   595    Return a glyph code of FONT for character C (Unicode code point).
   596    If FONT doesn't have such a glyph, return FONT_INVALID_CODE.  */
   597 static unsigned
   598 uniscribe_encode_char (struct font *font, int c)
   599 {
   600   HDC context = NULL;
   601   struct frame *f = NULL;
   602   HFONT old_font = NULL;
   603   unsigned code = FONT_INVALID_CODE;
   604   wchar_t ch[2];
   605   int len;
   606   SCRIPT_ITEM* items;
   607   int nitems;
   608   struct uniscribe_font_info *uniscribe_font
   609     = (struct uniscribe_font_info *)font;
   610 
   611   if (c < 0x10000)
   612     {
   613       ch[0] = (wchar_t) c;
   614       len = 1;
   615     }
   616   else
   617     {
   618       DWORD surrogate = c - 0x10000;
   619 
   620       /* High surrogate: U+D800 - U+DBFF.  */
   621       ch[0] = 0xD800 + ((surrogate >> 10) & 0x03FF);
   622       /* Low surrogate: U+DC00 - U+DFFF.  */
   623       ch[1] = 0xDC00 + (surrogate & 0x03FF);
   624       len = 2;
   625     }
   626 
   627   /* Non BMP characters must be handled by the uniscribe shaping
   628      engine as GDI functions (except blindly displaying lines of
   629      Unicode text) and the promising looking ScriptGetCMap do not
   630      convert surrogate pairs to glyph indexes correctly.  */
   631     {
   632       items = (SCRIPT_ITEM *) alloca (sizeof (SCRIPT_ITEM) * 2 + 1);
   633       if (SUCCEEDED (ScriptItemize (ch, len, 2, NULL, NULL, items, &nitems)))
   634         {
   635           HRESULT result;
   636           /* Surrogates seem to need 2 here, even though only one glyph is
   637              returned.  Indic characters can also produce 2 or more glyphs for
   638              a single code point, but they need to use uniscribe_shape
   639              above for correct display.  */
   640           WORD glyphs[2], clusters[2];
   641           SCRIPT_VISATTR attrs[2];
   642           int nglyphs;
   643 
   644           /* Force ScriptShape to generate glyphs in the logical
   645              order.  */
   646           items[0].a.fLogicalOrder = 1;
   647 
   648           result = ScriptShape (context,
   649                                 (SCRIPT_CACHE) &(uniscribe_font->cache),
   650                                 ch, len, 2, &(items[0].a),
   651                                 glyphs, clusters, attrs, &nglyphs);
   652 
   653           if (result == E_PENDING)
   654             {
   655               /* Use selected frame until API is updated to pass
   656                  the frame.  */
   657               f = XFRAME (selected_frame);
   658               context = get_frame_dc (f);
   659               old_font = SelectObject (context, FONT_HANDLE (font));
   660               result = ScriptShape (context,
   661                                     (SCRIPT_CACHE) &(uniscribe_font->cache),
   662                                     ch, len, 2, &(items[0].a),
   663                                     glyphs, clusters, attrs, &nglyphs);
   664             }
   665 
   666           if (SUCCEEDED (result) && nglyphs == 1)
   667             {
   668               /* Some fonts return .notdef glyphs instead of failing.
   669                  (TrueType spec reserves glyph code 0 for .notdef)  */
   670               if (glyphs[0])
   671                 code = glyphs[0];
   672             }
   673           else if (SUCCEEDED (result) || result == E_OUTOFMEMORY)
   674             {
   675               /* This character produces zero or more than one glyph
   676                  when shaped. But we still need the return from here
   677                  to be valid for the shaping engine to be invoked
   678                  later.  */
   679               result = ScriptGetCMap (context,
   680                                       (SCRIPT_CACHE) &(uniscribe_font->cache),
   681                                       ch, len, 0, glyphs);
   682               if (SUCCEEDED (result) && glyphs[0])
   683                 code = glyphs[0];
   684             }
   685         }
   686     }
   687     if (context)
   688       {
   689         SelectObject (context, old_font);
   690         release_frame_dc (f, context);
   691       }
   692 
   693     return code;
   694 }
   695 
   696 /*
   697    Shared with w32font:
   698    Lisp_Object uniscribe_get_cache (Lisp_Object frame);
   699    void uniscribe_free_entity (Lisp_Object font_entity);
   700    int uniscribe_has_char (Lisp_Object entity, int c);
   701    void uniscribe_text_extents (struct font *font, unsigned *code,
   702                                 int nglyphs, struct font_metrics *metrics);
   703    int uniscribe_draw (struct glyph_string *s, int from, int to,
   704                        int x, int y, int with_background);
   705 
   706    Unused:
   707    int uniscribe_prepare_face (struct frame *f, struct face *face);
   708    void uniscribe_done_face (struct frame *f, struct face *face);
   709    int uniscribe_get_bitmap (struct font *font, unsigned code,
   710                              struct font_bitmap *bitmap, int bits_per_pixel);
   711    void uniscribe_free_bitmap (struct font *font, struct font_bitmap *bitmap);
   712    int uniscribe_anchor_point (struct font *font, unsigned code,
   713                                int index, int *x, int *y);
   714    int uniscribe_start_for_frame (struct frame *f);
   715    int uniscribe_end_for_frame (struct frame *f);
   716 
   717 */
   718 
   719 
   720 /* Callback function for EnumFontFamiliesEx.
   721    Adds the name of opentype fonts to a Lisp list (passed in as the
   722    lParam arg). */
   723 static int CALLBACK ALIGN_STACK
   724 add_opentype_font_name_to_list (ENUMLOGFONTEX *logical_font,
   725                                 NEWTEXTMETRICEX *physical_font,
   726                                 DWORD font_type, LPARAM list_object)
   727 {
   728   Lisp_Object* list = (Lisp_Object *) list_object;
   729   Lisp_Object family;
   730 
   731   /* Skip vertical fonts (intended only for printing)  */
   732   if (logical_font->elfLogFont.lfFaceName[0] == '@')
   733     return 1;
   734 
   735   /* Skip non opentype fonts.  Count old truetype fonts as opentype,
   736      as some of them do contain GPOS and GSUB data that Uniscribe
   737      can make use of.  */
   738   if (!(physical_font->ntmTm.ntmFlags & NTMFLAGS_OPENTYPE)
   739       && font_type != TRUETYPE_FONTTYPE)
   740     return 1;
   741 
   742   /* Skip fonts that have no Unicode coverage.  */
   743   if (!physical_font->ntmFontSig.fsUsb[3]
   744       && !physical_font->ntmFontSig.fsUsb[2]
   745       && !physical_font->ntmFontSig.fsUsb[1]
   746       && !(physical_font->ntmFontSig.fsUsb[0] & 0x3fffffff))
   747     return 1;
   748 
   749   family = intern_font_name (logical_font->elfLogFont.lfFaceName);
   750   if (! memq_no_quit (family, *list))
   751     *list = Fcons (family, *list);
   752 
   753   return 1;
   754 }
   755 
   756 
   757 /* :otf property handling.
   758    Since the necessary Uniscribe APIs for getting font tag information
   759    are only available in Vista, we may need to parse the font data directly
   760    according to the OpenType Specification.  */
   761 
   762 /* Push into DWORD backwards to cope with endianness.  */
   763 #define OTF_TAG(STR)                                          \
   764   ((STR[3] << 24) | (STR[2] << 16) | (STR[1] << 8) | STR[0])
   765 
   766 #define OTF_INT16_VAL(TABLE, OFFSET, PTR)                    \
   767   do {                                                       \
   768     BYTE temp, data[2];                                      \
   769     if (GetFontData (context, TABLE, OFFSET, data, 2) != 2)  \
   770       goto font_table_error;                                 \
   771     temp = data[0], data[0] = data[1], data[1] = temp;       \
   772     memcpy (PTR, data, 2);                                   \
   773   } while (0)
   774 
   775 /* Do not reverse the bytes, because we will compare with a OTF_TAG value
   776    that has them reversed already.  */
   777 #define OTF_DWORDTAG_VAL(TABLE, OFFSET, PTR)                    \
   778   do {                                                          \
   779     if (GetFontData (context, TABLE, OFFSET, PTR, 4) != 4)      \
   780       goto font_table_error;                                    \
   781   } while (0)
   782 
   783 #define OTF_TAG_VAL(TABLE, OFFSET, STR)                      \
   784   do {                                                       \
   785     if (GetFontData (context, TABLE, OFFSET, STR, 4) != 4)   \
   786       goto font_table_error;                                 \
   787     STR[4] = '\0';                                           \
   788   } while (0)
   789 
   790 #define SNAME(VAL) SSDATA (SYMBOL_NAME (VAL))
   791 
   792 /* Uniscribe APIs available only since Windows Vista.  */
   793 typedef HRESULT (WINAPI *ScriptGetFontScriptTags_Proc)
   794   (HDC, SCRIPT_CACHE *, SCRIPT_ANALYSIS *, int, OPENTYPE_TAG *, int *);
   795 
   796 typedef HRESULT (WINAPI *ScriptGetFontLanguageTags_Proc)
   797   (HDC, SCRIPT_CACHE *, SCRIPT_ANALYSIS *, OPENTYPE_TAG, int, OPENTYPE_TAG *, int *);
   798 
   799 typedef HRESULT (WINAPI *ScriptGetFontFeatureTags_Proc)
   800   (HDC, SCRIPT_CACHE *, SCRIPT_ANALYSIS *, OPENTYPE_TAG, OPENTYPE_TAG, int, OPENTYPE_TAG *, int *);
   801 
   802 ScriptGetFontScriptTags_Proc script_get_font_scripts_fn;
   803 ScriptGetFontLanguageTags_Proc script_get_font_languages_fn;
   804 ScriptGetFontFeatureTags_Proc script_get_font_features_fn;
   805 
   806 static bool uniscribe_new_apis;
   807 
   808 /* Verify that all the required features in FEATURES, each of whose
   809    elements is a list or nil, can be found among the N feature tags in
   810    FTAGS.  Return 'true' if the required features are supported,
   811    'false' if not.  Each list in FEATURES can include an element of
   812    nil, which means all the elements after it must not be in FTAGS.  */
   813 static bool
   814 uniscribe_check_features (Lisp_Object features[2], OPENTYPE_TAG *ftags, int n)
   815 {
   816   int j;
   817 
   818   for (j = 0; j < 2; j++)
   819     {
   820       bool negative = false;
   821       Lisp_Object rest;
   822 
   823       for (rest = features[j]; CONSP (rest); rest = XCDR (rest))
   824         {
   825           Lisp_Object feature = XCAR (rest);
   826 
   827           /* The font must NOT have any of the features after nil.
   828              See the doc string of 'font-spec', under ':otf'.  */
   829           if (NILP (feature))
   830             negative = true;
   831           else
   832             {
   833               OPENTYPE_TAG feature_tag = OTF_TAG (SNAME (feature));
   834               int i;
   835 
   836               for (i = 0; i < n; i++)
   837                 {
   838                   if (ftags[i] == feature_tag)
   839                     {
   840                       /* Test fails if we find a feature that the font
   841                          must NOT have.  */
   842                       if (negative)
   843                         return false;
   844                       break;
   845                     }
   846                 }
   847 
   848               /* Test fails if we do NOT find a feature that the font
   849                  should have.  */
   850               if (i >= n && !negative)
   851                 return false;
   852             }
   853         }
   854     }
   855 
   856   return true;
   857 }
   858 
   859 /* Check if font supports the required OTF script/language/features
   860    using the Unsicribe APIs available since Windows Vista.  We prefer
   861    these APIs as a kind of future-proofing Emacs: they seem to
   862    retrieve script tags that the old code (and also libotf) doesn't
   863    seem to be able to get, e.g., some fonts that claim support for
   864    "dev2" script don't show "deva", but the new APIs do report it.  */
   865 static int
   866 uniscribe_check_otf_1 (HDC context, Lisp_Object script, Lisp_Object lang,
   867                        Lisp_Object features[2], int *retval)
   868 {
   869   SCRIPT_CACHE cache = NULL;
   870   OPENTYPE_TAG tags[32], script_tag, lang_tag;
   871   int max_tags = ARRAYELTS (tags);
   872   int ntags, i, ret = 0;
   873   HRESULT rslt;
   874 
   875   *retval = 0;
   876 
   877   rslt = script_get_font_scripts_fn (context, &cache, NULL, max_tags,
   878                                      tags, &ntags);
   879   if (FAILED (rslt))
   880     {
   881       DebPrint (("ScriptGetFontScriptTags failed with 0x%x\n", rslt));
   882       ret = -1;
   883       goto no_support;
   884     }
   885   if (NILP (script))
   886     script_tag = OTF_TAG ("DFLT");
   887   else
   888     script_tag = OTF_TAG (SNAME (script));
   889   for (i = 0; i < ntags; i++)
   890     if (tags[i] == script_tag)
   891       break;
   892 
   893   if (i >= ntags)
   894     goto no_support;
   895 
   896   if (NILP (lang))
   897     lang_tag = OTF_TAG ("dflt");
   898   else
   899     {
   900       rslt = script_get_font_languages_fn (context, &cache, NULL, script_tag,
   901                                            max_tags, tags, &ntags);
   902       if (FAILED (rslt))
   903         {
   904           DebPrint (("ScriptGetFontLanguageTags failed with 0x%x\n", rslt));
   905           ret = -1;
   906           goto no_support;
   907         }
   908       if (ntags == 0)
   909         lang_tag = OTF_TAG ("dflt");
   910       else
   911         {
   912           lang_tag = OTF_TAG (SNAME (lang));
   913           for (i = 0; i < ntags; i++)
   914             if (tags[i] == lang_tag)
   915               break;
   916 
   917           if (i >= ntags)
   918             goto no_support;
   919         }
   920     }
   921 
   922   if (!NILP (features[0]))
   923     {
   924       /* Are the 2 feature lists valid?  */
   925       if (!CONSP (features[0])
   926           || (!NILP (features[1]) && !CONSP (features[1])))
   927         goto no_support;
   928       rslt = script_get_font_features_fn (context, &cache, NULL,
   929                                           script_tag, lang_tag,
   930                                           max_tags, tags, &ntags);
   931       if (FAILED (rslt))
   932         {
   933           DebPrint (("ScriptGetFontFeatureTags failed with 0x%x\n", rslt));
   934           ret = -1;
   935           goto no_support;
   936         }
   937 
   938       /* ScriptGetFontFeatureTags doesn't let us query features
   939          separately for GSUB and GPOS, so we check them all together.
   940          It doesn't really matter, since the features in GSUB and GPOS
   941          are disjoint, i.e. no feature can appear in both tables.  */
   942       if (!uniscribe_check_features (features, tags, ntags))
   943         goto no_support;
   944     }
   945 
   946   ret = 1;
   947   *retval = 1;
   948 
   949  no_support:
   950   if (cache)
   951     ScriptFreeCache (&cache);
   952   return ret;
   953 }
   954 
   955 /* Check if font supports the otf script/language/features specified.
   956    OTF_SPEC is in the format
   957      (script lang [(gsub_feature ...)|nil] [(gpos_feature ...)]?) */
   958 int
   959 uniscribe_check_otf (LOGFONT *font, Lisp_Object otf_spec)
   960 {
   961   Lisp_Object script, lang, rest;
   962   Lisp_Object features[2];
   963   DWORD feature_tables[2];
   964   DWORD script_tag, default_script, lang_tag = 0;
   965   struct frame * f;
   966   HDC context;
   967   HFONT check_font, old_font;
   968   int i, retval = 0;
   969 
   970   /* Check the spec is in the right format.  */
   971   if (!CONSP (otf_spec) || XFIXNUM (Flength (otf_spec)) < 3)
   972     return 0;
   973 
   974   /* Break otf_spec into its components.  */
   975   script = XCAR (otf_spec);
   976   rest = XCDR (otf_spec);
   977 
   978   lang = XCAR (rest);
   979   rest = XCDR (rest);
   980 
   981   features[0] = XCAR (rest);
   982   rest = XCDR (rest);
   983   if (NILP (rest))
   984     features[1] = Qnil;
   985   else
   986     features[1] = XCAR (rest);
   987 
   988   /* Set up graphics context so we can use the font.  */
   989   f = XFRAME (selected_frame);
   990   context = get_frame_dc (f);
   991   check_font = CreateFontIndirect (font);
   992   old_font = SelectObject (context, check_font);
   993 
   994   /* If we are on Vista or later, use the new APIs.  */
   995   if (uniscribe_new_apis
   996       && !w32_disable_new_uniscribe_apis
   997       && uniscribe_check_otf_1 (context, script, lang, features, &retval) != -1)
   998     goto done;
   999 
  1000   /* Set up tags we will use in the search.  */
  1001   feature_tables[0] = OTF_TAG ("GSUB");
  1002   feature_tables[1] = OTF_TAG ("GPOS");
  1003   default_script = OTF_TAG ("DFLT");
  1004   if (NILP (script))
  1005     script_tag = default_script;
  1006   else
  1007     script_tag = OTF_TAG (SNAME (script));
  1008   if (!NILP (lang))
  1009     lang_tag = OTF_TAG (SNAME (lang));
  1010 
  1011   /* Scan GSUB and GPOS tables.  */
  1012   for (i = 0; i < 2; i++)
  1013     {
  1014       int j, n_match_features;
  1015       unsigned short scriptlist_table, feature_table, n_scripts;
  1016       unsigned short script_table, langsys_table, n_langs;
  1017       unsigned short feature_index, n_features;
  1018       DWORD tbl = feature_tables[i];
  1019       DWORD feature_id, *ftags;
  1020       Lisp_Object farray[2];
  1021 
  1022       /* Skip if no features requested from this table.  */
  1023       if (NILP (features[i]))
  1024         continue;
  1025 
  1026       /* If features is not a cons, this font spec is messed up.  */
  1027       if (!CONSP (features[i]))
  1028         goto no_support;
  1029 
  1030       /* Read GPOS/GSUB header.  */
  1031       OTF_INT16_VAL (tbl, 4, &scriptlist_table);
  1032       OTF_INT16_VAL (tbl, 6, &feature_table);
  1033       OTF_INT16_VAL (tbl, scriptlist_table, &n_scripts);
  1034 
  1035       /* Find the appropriate script table.  */
  1036       script_table = 0;
  1037       for (j = 0; j < n_scripts; j++)
  1038         {
  1039           DWORD script_id;
  1040           OTF_DWORDTAG_VAL (tbl, scriptlist_table + 2 + j * 6, &script_id);
  1041           if (script_id == script_tag)
  1042             {
  1043               OTF_INT16_VAL (tbl, scriptlist_table + 6 + j * 6, &script_table);
  1044               break;
  1045             }
  1046 #if 0     /* Causes false positives.  */
  1047           /* If there is a DFLT script defined in the font, use it
  1048              if the specified script is not found.  */
  1049           else if (script_id == default_script)
  1050             OTF_INT16_VAL (tbl, scriptlist_table + 6 + j * 6, &script_table);
  1051 #endif
  1052         }
  1053       /* If no specific or default script table was found, then this font
  1054          does not support the script.  */
  1055       if (!script_table)
  1056         goto no_support;
  1057 
  1058       /* Offset is from beginning of scriptlist_table.  */
  1059       script_table += scriptlist_table;
  1060 
  1061       /* Get default langsys table.  */
  1062       OTF_INT16_VAL (tbl, script_table, &langsys_table);
  1063 
  1064       /* If lang was specified, see if font contains a specific entry.  */
  1065       if (!NILP (lang))
  1066         {
  1067           OTF_INT16_VAL (tbl, script_table + 2, &n_langs);
  1068 
  1069           for (j = 0; j < n_langs; j++)
  1070             {
  1071               DWORD lang_id;
  1072               OTF_DWORDTAG_VAL (tbl, script_table + 4 + j * 6, &lang_id);
  1073               if (lang_id == lang_tag)
  1074                 {
  1075                   OTF_INT16_VAL (tbl, script_table + 8 + j * 6, &langsys_table);
  1076                   break;
  1077                 }
  1078             }
  1079         }
  1080 
  1081       if (!langsys_table)
  1082         goto no_support;
  1083 
  1084       /* Offset is from beginning of script table.  */
  1085       langsys_table += script_table;
  1086 
  1087       /* If there are no features to check, skip checking.  */
  1088       if (NILP (features[i]))
  1089         continue;
  1090       if (!CONSP (features[i]))
  1091         goto no_support;
  1092 
  1093       n_match_features = 0;
  1094 
  1095       /* First get required feature (if any).  */
  1096       OTF_INT16_VAL (tbl, langsys_table + 2, &feature_index);
  1097       if (feature_index != 0xFFFF)
  1098         n_match_features = 1;
  1099       OTF_INT16_VAL (tbl, langsys_table + 4, &n_features);
  1100       n_match_features += n_features;
  1101       USE_SAFE_ALLOCA;
  1102       SAFE_NALLOCA (ftags, 1, n_match_features);
  1103       int k = 0;
  1104       if (feature_index != 0xFFFF)
  1105         {
  1106           OTF_DWORDTAG_VAL (tbl, feature_table + 2 + feature_index * 6,
  1107                             &feature_id);
  1108           ftags[k++] = feature_id;
  1109         }
  1110       /* Now get all the other features.  */
  1111       for (j = 0; j < n_features; j++)
  1112         {
  1113           OTF_INT16_VAL (tbl, langsys_table + 6 + j * 2, &feature_index);
  1114           OTF_DWORDTAG_VAL (tbl, feature_table + 2 + feature_index * 6,
  1115                             &feature_id);
  1116           ftags[k++] = feature_id;
  1117         }
  1118 
  1119       /* Check the features for this table.  */
  1120       farray[0] = features[i];
  1121       farray[1] = Qnil;
  1122       if (!uniscribe_check_features (farray, ftags, n_match_features))
  1123         goto no_support;
  1124       SAFE_FREE ();
  1125     }
  1126 
  1127   retval = 1;
  1128 
  1129  done:
  1130  no_support:
  1131  font_table_error:
  1132   /* restore graphics context.  */
  1133   SelectObject (context, old_font);
  1134   DeleteObject (check_font);
  1135   release_frame_dc (f, context);
  1136 
  1137   return retval;
  1138 }
  1139 
  1140 static Lisp_Object
  1141 otf_features (HDC context, const char *table)
  1142 {
  1143   Lisp_Object script_list = Qnil;
  1144   unsigned short scriptlist_table, n_scripts, feature_table;
  1145   DWORD tbl = OTF_TAG (table);
  1146   int i, j, k;
  1147 
  1148   /* Look for scripts in the table.  */
  1149   OTF_INT16_VAL (tbl, 4, &scriptlist_table);
  1150   OTF_INT16_VAL (tbl, 6, &feature_table);
  1151   OTF_INT16_VAL (tbl, scriptlist_table, &n_scripts);
  1152 
  1153   for (i = n_scripts - 1; i >= 0; i--)
  1154     {
  1155       char script[5], lang[5];
  1156       unsigned short script_table, lang_count, langsys_table, feature_count;
  1157       Lisp_Object script_tag, langsys_list, langsys_tag, feature_list;
  1158       unsigned short record_offset = scriptlist_table + 2 + i * 6;
  1159       OTF_TAG_VAL (tbl, record_offset, script);
  1160       OTF_INT16_VAL (tbl, record_offset + 4, &script_table);
  1161 
  1162       /* Offset is from beginning of script table.  */
  1163       script_table += scriptlist_table;
  1164 
  1165       script_tag = intern (script);
  1166       langsys_list = Qnil;
  1167 
  1168       /* Optional default lang.  */
  1169       OTF_INT16_VAL (tbl, script_table, &langsys_table);
  1170       if (langsys_table)
  1171         {
  1172           /* Offset is from beginning of script table.  */
  1173           langsys_table += script_table;
  1174 
  1175           langsys_tag = Qnil;
  1176           feature_list = Qnil;
  1177           OTF_INT16_VAL (tbl, langsys_table + 4, &feature_count);
  1178           for (k = feature_count - 1; k >= 0; k--)
  1179             {
  1180               char feature[5];
  1181               unsigned short index;
  1182               OTF_INT16_VAL (tbl, langsys_table + 6 + k * 2, &index);
  1183               OTF_TAG_VAL (tbl, feature_table + 2 + index * 6, feature);
  1184               feature_list = Fcons (intern (feature), feature_list);
  1185             }
  1186           langsys_list = Fcons (Fcons (langsys_tag, feature_list),
  1187                                 langsys_list);
  1188         }
  1189 
  1190       /* List of supported languages.  */
  1191       OTF_INT16_VAL (tbl, script_table + 2, &lang_count);
  1192 
  1193       for (j = lang_count - 1; j >= 0; j--)
  1194         {
  1195           record_offset = script_table + 4 + j * 6;
  1196           OTF_TAG_VAL (tbl, record_offset, lang);
  1197           OTF_INT16_VAL (tbl, record_offset + 4, &langsys_table);
  1198 
  1199           /* Offset is from beginning of script table.  */
  1200           langsys_table += script_table;
  1201 
  1202           langsys_tag = intern (lang);
  1203           feature_list = Qnil;
  1204           OTF_INT16_VAL (tbl, langsys_table + 4, &feature_count);
  1205           for (k = feature_count - 1; k >= 0; k--)
  1206             {
  1207               char feature[5];
  1208               unsigned short index;
  1209               OTF_INT16_VAL (tbl, langsys_table + 6 + k * 2, &index);
  1210               OTF_TAG_VAL (tbl, feature_table + 2 + index * 6, feature);
  1211               feature_list = Fcons (intern (feature), feature_list);
  1212             }
  1213           langsys_list = Fcons (Fcons (langsys_tag, feature_list),
  1214                                 langsys_list);
  1215 
  1216         }
  1217 
  1218       script_list = Fcons (Fcons (script_tag, langsys_list), script_list);
  1219     }
  1220 
  1221   return script_list;
  1222 
  1223 font_table_error:
  1224   return Qnil;
  1225 }
  1226 
  1227 #ifdef HAVE_HARFBUZZ
  1228 
  1229 /* W32 implementation of the 'list' method for HarfBuzz backend.  */
  1230 static Lisp_Object
  1231 w32hb_list (struct frame *f, Lisp_Object font_spec)
  1232 {
  1233   Lisp_Object fonts = w32font_list_internal (f, font_spec, true);
  1234   FONT_ADD_LOG ("harfbuzz-list", font_spec, fonts);
  1235 
  1236   for (Lisp_Object tail = fonts; CONSP (tail); tail = XCDR (tail))
  1237     ASET (XCAR (tail), FONT_TYPE_INDEX, Qharfbuzz);
  1238 
  1239   return fonts;
  1240 }
  1241 
  1242 /* W32 implementation of the 'match' method for HarfBuzz backend.  */
  1243 static Lisp_Object
  1244 w32hb_match (struct frame *f, Lisp_Object font_spec)
  1245 {
  1246   Lisp_Object entity = w32font_match_internal (f, font_spec, true);
  1247   FONT_ADD_LOG ("harfbuzz-match", font_spec, entity);
  1248 
  1249   if (! NILP (entity))
  1250     ASET (entity, FONT_TYPE_INDEX, Qharfbuzz);
  1251   return entity;
  1252 }
  1253 
  1254 /* Callback function to free memory.  We need this so we could pass it
  1255    to HarfBuzz as the function to call to destroy objects for which we
  1256    allocated data by calling our 'malloc' (as opposed to 'malloc' from
  1257    the MS CRT, against which HarfBuzz was linked).  */
  1258 static void
  1259 free_cb (void *ptr)
  1260 {
  1261   free (ptr);
  1262 }
  1263 
  1264 /* A function used as reference_table_func for HarfBuzz.  It returns
  1265    the data of a specified table of a font as a blob.  */
  1266 static hb_blob_t *
  1267 w32hb_get_font_table (hb_face_t *face, hb_tag_t tag, void *data)
  1268 {
  1269   struct frame *f = XFRAME (selected_frame);
  1270   HDC context = get_frame_dc (f);
  1271   HFONT old_font = SelectObject (context, (HFONT) data);
  1272   char *font_data = NULL;
  1273   DWORD font_data_size = 0, val;
  1274   DWORD table = bswap_32 (tag);
  1275   hb_blob_t *blob = NULL;
  1276 
  1277   val = GetFontData (context, table, 0, font_data, font_data_size);
  1278   if (val != GDI_ERROR)
  1279     {
  1280       font_data_size = val;
  1281       /* Don't call xmalloc, because it can signal an error, while
  1282          we are inside a critical section established by get_frame_dc.  */
  1283       font_data = malloc (font_data_size);
  1284       if (font_data)
  1285         {
  1286           val = GetFontData (context, table, 0, font_data, font_data_size);
  1287           if (val != GDI_ERROR)
  1288             blob = hb_blob_create (font_data, font_data_size,
  1289                                    HB_MEMORY_MODE_READONLY, font_data, free_cb);
  1290         }
  1291     }
  1292 
  1293   /* Restore graphics context.  */
  1294   SelectObject (context, old_font);
  1295   release_frame_dc (f, context);
  1296 
  1297   return blob;
  1298 }
  1299 
  1300 /* Helper function used by the HarfBuzz implementations of the
  1301    encode_char, has_char, and begin_hb_font methods.  It creates an
  1302    hb_font_t object for a given Emacs font.  */
  1303 static hb_font_t *
  1304 w32hb_get_font (struct font *font, double *scale)
  1305 {
  1306   hb_font_t *hb_font = NULL;
  1307   HFONT font_handle = FONT_HANDLE (font);
  1308   hb_face_t *hb_face =
  1309     hb_face_create_for_tables (w32hb_get_font_table, font_handle, NULL);
  1310   if (hb_face_get_glyph_count (hb_face) > 0)
  1311     {
  1312       hb_font = hb_font_create (hb_face);
  1313       /* This is needed for HarfBuzz before 2.0.0; it is the default
  1314          in later versions.  */
  1315       hb_ot_font_set_funcs (hb_font);
  1316     }
  1317 
  1318   struct uniscribe_font_info *uniscribe_font =
  1319     (struct uniscribe_font_info *) font;
  1320   unsigned upem = hb_face_get_upem (hb_face);
  1321   eassert (upem > 0);
  1322   /* https://support.microsoft.com/en-sg/help/74299/info-calculating-the-logical-height-and-point-size-of-a-font.  */
  1323   LONG font_point_size =
  1324     uniscribe_font->w32_font.metrics.tmHeight
  1325     - uniscribe_font->w32_font.metrics.tmInternalLeading;
  1326   /* https://docs.microsoft.com/en-us/typography/opentype/spec/ttch01,
  1327      under "Converting FUnits to pixels".  */
  1328   *scale = font_point_size * 1.0 / upem;
  1329 
  1330   hb_face_destroy (hb_face);
  1331 
  1332   /* FIXME: Can hb_font be non-NULL and yet invalid?  Compare to get_empty?  */
  1333   return hb_font;
  1334 }
  1335 
  1336 /* W32 implementation of encode_char method for HarfBuzz backend.  */
  1337 static unsigned
  1338 w32hb_encode_char (struct font *font, int c)
  1339 {
  1340   struct uniscribe_font_info *uniscribe_font
  1341     = (struct uniscribe_font_info *) font;
  1342   eassert (uniscribe_font->w32_font.font.driver == &harfbuzz_font_driver);
  1343   hb_font_t *hb_font = uniscribe_font->cache;
  1344 
  1345   /* First time we use this font with HarfBuzz, create the hb_font_t
  1346      object and cache it.  */
  1347   if (!hb_font)
  1348     {
  1349       double scale;
  1350       hb_font = w32hb_get_font (font, &scale);
  1351       if (!hb_font)
  1352         return FONT_INVALID_CODE;
  1353 
  1354       uniscribe_font->cache = hb_font;
  1355       eassert (scale > 0.0);
  1356       uniscribe_font->scale = scale;
  1357     }
  1358   hb_codepoint_t glyph;
  1359   if (hb_font_get_nominal_glyph (hb_font, c, &glyph))
  1360     return glyph;
  1361   return FONT_INVALID_CODE;
  1362 }
  1363 
  1364 /* W32 implementation of HarfBuzz begin_hb_font and end_hb_font
  1365    methods.  */
  1366 
  1367 /* Return a HarfBuzz font object for FONT and store in POSITION_UNIT
  1368    the scale factor to convert a hb_position_t value to the number of
  1369    pixels.  Return NULL if HarfBuzz font object is not available for
  1370    FONT.  */
  1371 static hb_font_t *
  1372 w32hb_begin_font (struct font *font, double *position_unit)
  1373 {
  1374   struct uniscribe_font_info *uniscribe_font
  1375     = (struct uniscribe_font_info *) font;
  1376   eassert (uniscribe_font->w32_font.font.driver == &harfbuzz_font_driver);
  1377 
  1378   /* First time we use this font with HarfBuzz, create the hb_font_t
  1379      object and cache it.  */
  1380   if (!uniscribe_font->cache)
  1381     {
  1382       double scale;
  1383       uniscribe_font->cache = w32hb_get_font (font, &scale);
  1384       eassert (scale > 0.0);
  1385       uniscribe_font->scale = scale;
  1386     }
  1387   *position_unit = uniscribe_font->scale;
  1388   return (hb_font_t *) uniscribe_font->cache;
  1389 }
  1390 
  1391 /* W32 implementation of get_variation_glyphs method for HarfBuzz.
  1392 
  1393    Return the number of variation glyphs of character C supported by
  1394    FONT.  VARIATIONS is an array of 256 elements.  If the variation
  1395    selector N (1..256) defines a glyph, that glyph code is stored in
  1396    the (N-1)th element of VARIATIONS.  */
  1397 static int
  1398 w32hb_get_variation_glyphs (struct font *font, int c, unsigned variations[256])
  1399 {
  1400   struct uniscribe_font_info *uniscribe_font
  1401     = (struct uniscribe_font_info *) font;
  1402   eassert (uniscribe_font->w32_font.font.driver == &harfbuzz_font_driver);
  1403 
  1404   /* First time we use this font with HarfBuzz, create the hb_font_t
  1405      object and cache it.  */
  1406   if (!uniscribe_font->cache)
  1407     {
  1408       double scale;
  1409       uniscribe_font->cache = w32hb_get_font (font, &scale);
  1410       eassert (scale > 0.0);
  1411       uniscribe_font->scale = scale;
  1412     }
  1413 
  1414   int i, n = 0;
  1415   hb_font_t *hb_font = uniscribe_font->cache;
  1416   for (i = 0; i < 16; i++)
  1417     {
  1418       if (hb_font_get_variation_glyph (hb_font, c, 0xFE00 + i, &variations[i]))
  1419         n++;
  1420       else
  1421         variations[i] = 0;
  1422     }
  1423   for ( ; i < 256; i++)
  1424     {
  1425       if (hb_font_get_variation_glyph (hb_font, c, 0xE0100 + (i - 16),
  1426                                        &variations[i]))
  1427         n++;
  1428       else
  1429         variations[i] = 0;
  1430     }
  1431 
  1432   return n;
  1433 }
  1434 #endif  /* HAVE_HARFBUZZ */
  1435 
  1436 #undef OTF_INT16_VAL
  1437 #undef OTF_TAG_VAL
  1438 #undef OTF_TAG
  1439 
  1440 
  1441 struct font_driver uniscribe_font_driver =
  1442   {
  1443     LISPSYM_INITIALLY (Quniscribe),
  1444     0, /* case insensitive */
  1445     w32font_get_cache,
  1446     uniscribe_list,
  1447     uniscribe_match,
  1448     uniscribe_list_family,
  1449     NULL, /* free_entity */
  1450     uniscribe_open,
  1451     uniscribe_close,
  1452     NULL, /* prepare_face */
  1453     NULL, /* done_face */
  1454     w32font_has_char,
  1455     uniscribe_encode_char,
  1456     w32font_text_extents,
  1457     w32font_draw,
  1458     NULL, /* get_bitmap */
  1459     NULL, /* free_bitmap */
  1460     NULL, /* anchor_point */
  1461     uniscribe_otf_capability, /* Defined so (font-get FONTOBJ :otf) works.  */
  1462     NULL, /* otf_drive - use shape instead.  */
  1463     NULL, /* start_for_frame */
  1464     NULL, /* end_for_frame */
  1465     uniscribe_shape,
  1466     NULL, /* check */
  1467     NULL, /* get_variation_glyphs */
  1468     NULL, /* filter_properties */
  1469     NULL, /* cached_font_ok */
  1470   };
  1471 
  1472 /* Note that this should be called at every startup, not just when dumping,
  1473    as it needs to test for the existence of the Uniscribe library.  */
  1474 void syms_of_w32uniscribe (void);
  1475 
  1476 static void syms_of_w32uniscribe_for_pdumper (void);
  1477 
  1478 void
  1479 syms_of_w32uniscribe (void)
  1480 {
  1481   pdumper_do_now_and_after_load (syms_of_w32uniscribe_for_pdumper);
  1482 }
  1483 
  1484 #ifdef HAVE_HARFBUZZ
  1485 static bool
  1486 load_harfbuzz_funcs (HMODULE library)
  1487 {
  1488   LOAD_DLL_FN (library, hb_blob_create);
  1489   LOAD_DLL_FN (library, hb_face_create_for_tables);
  1490   LOAD_DLL_FN (library, hb_face_get_glyph_count);
  1491   LOAD_DLL_FN (library, hb_font_create);
  1492   LOAD_DLL_FN (library, hb_font_destroy);
  1493   LOAD_DLL_FN (library, hb_face_get_upem);
  1494   LOAD_DLL_FN (library, hb_face_destroy);
  1495   LOAD_DLL_FN (library, hb_font_get_nominal_glyph);
  1496   LOAD_DLL_FN (library, hb_font_get_variation_glyph);
  1497   LOAD_DLL_FN (library, hb_ot_font_set_funcs);
  1498   return hbfont_init_w32_funcs (library);
  1499 }
  1500 #endif  /* HAVE_HARFBUZZ */
  1501 
  1502 static void
  1503 syms_of_w32uniscribe_for_pdumper (void)
  1504 {
  1505   /* Don't init Uniscribe and HarfBuzz when dumping */
  1506   if (!initialized)
  1507     return;
  1508 
  1509   /* Don't register if Uniscribe is not available.  */
  1510   HMODULE uniscribe = GetModuleHandle ("usp10");
  1511   if (!uniscribe)
  1512     return;
  1513 
  1514   uniscribe_available = 1;
  1515 
  1516   register_font_driver (&uniscribe_font_driver, NULL);
  1517 
  1518   script_get_font_scripts_fn = (ScriptGetFontScriptTags_Proc)
  1519     get_proc_addr (uniscribe, "ScriptGetFontScriptTags");
  1520   script_get_font_languages_fn = (ScriptGetFontLanguageTags_Proc)
  1521     get_proc_addr (uniscribe, "ScriptGetFontLanguageTags");
  1522   script_get_font_features_fn = (ScriptGetFontFeatureTags_Proc)
  1523     get_proc_addr (uniscribe, "ScriptGetFontFeatureTags");
  1524   if (script_get_font_scripts_fn
  1525       && script_get_font_languages_fn
  1526       && script_get_font_features_fn)
  1527     uniscribe_new_apis = true;
  1528   else
  1529     uniscribe_new_apis = false;
  1530 
  1531 #ifdef HAVE_HARFBUZZ
  1532   /* Currently, HarfBuzz DLLs are always named libharfbuzz-0.dll, as
  1533      the project keeps the ABI backward-compatible.  So we can
  1534      hard-code the name of the library here, for now.  If they ever
  1535      break ABI compatibility, we may need to load the DLL that
  1536      corresponds to the HarfBuzz version for which Emacs was built.  */
  1537   HMODULE harfbuzz = LoadLibrary ("libharfbuzz-0.dll");
  1538   /* Don't register if HarfBuzz is not available.  */
  1539   if (!harfbuzz)
  1540     return;
  1541 
  1542   if (!load_harfbuzz_funcs (harfbuzz))
  1543     return;
  1544 
  1545   Fput (Quniscribe, Qfont_driver_superseded_by, Qharfbuzz);
  1546   harfbuzz_available = 1;
  1547   harfbuzz_font_driver = uniscribe_font_driver;
  1548   harfbuzz_font_driver.type = Qharfbuzz;
  1549   harfbuzz_font_driver.list = w32hb_list;
  1550   harfbuzz_font_driver.match = w32hb_match;
  1551   harfbuzz_font_driver.encode_char = w32hb_encode_char;
  1552   harfbuzz_font_driver.otf_capability = hbfont_otf_capability;
  1553   harfbuzz_font_driver.shape = hbfont_shape;
  1554   harfbuzz_font_driver.get_variation_glyphs = w32hb_get_variation_glyphs;
  1555   harfbuzz_font_driver.combining_capability = hbfont_combining_capability;
  1556   harfbuzz_font_driver.begin_hb_font = w32hb_begin_font;
  1557   register_font_driver (&harfbuzz_font_driver, NULL);
  1558 #endif  /* HAVE_HARFBUZZ */
  1559 }
/* [<][>][^][v][top][bottom][index][help] */