1 /* Font backend for the Microsoft W32 Uniscribe API.
  2    Copyright (C) 2008, 2009, 2010 Free Software Foundation, Inc.
  3 
  4 This file is part of GNU Emacs.
  5 
  6 GNU Emacs is free software: you can redistribute it and/or modify
  7 it under the terms of the GNU General Public License as published by
  8 the Free Software Foundation, either version 3 of the License, or
  9 (at your option) any later version.
 10 
 11 GNU Emacs is distributed in the hope that it will be useful,
 12 but WITHOUT ANY WARRANTY; without even the implied warranty of
 13 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 14 GNU General Public License for more details.
 15 
 16 You should have received a copy of the GNU General Public License
 17 along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.  */
 18 
 19 
 20 #include <config.h>
 21 /* Override API version - Uniscribe is only available as standard since
 22    Windows 2000, though most users of older systems will have it
 23    since it installs with Internet Explorer 5.0 and other software.
 24    We only enable the feature if it is available, so there is no chance
 25    of calling non-existent functions.  */
 26 #undef _WIN32_WINNT
 27 #define _WIN32_WINNT 0x500
 28 #include <windows.h>
 29 #include <usp10.h>
 30 #include <setjmp.h>
 31 
 32 #include "lisp.h"
 33 #include "w32term.h"
 34 #include "frame.h"
 35 #include "dispextern.h"
 36 #include "character.h"
 37 #include "charset.h"
 38 #include "composite.h"
 39 #include "fontset.h"
 40 #include "font.h"
 41 #include "w32font.h"
 42 
 43 struct uniscribe_font_info
 44 {
 45   struct w32font_info w32_font;
 46   SCRIPT_CACHE cache;
 47 };
 48 
 49 int uniscribe_available = 0;
 50 
 51 /* Defined in w32font.c, since it is required there as well.  */
 52 extern Lisp_Object Quniscribe;
 53 extern Lisp_Object Qopentype;
 54 
 55 extern int initialized;
 56 
 57 extern struct font_driver uniscribe_font_driver;
 58 
 59 /* EnumFontFamiliesEx callback.  */
 60 static int CALLBACK add_opentype_font_name_to_list P_ ((ENUMLOGFONTEX *,
 61                                                         NEWTEXTMETRICEX *,
 62                                                         DWORD, LPARAM));
 63 /* Used by uniscribe_otf_capability.  */
 64 static Lisp_Object otf_features (HDC context, char *table);
 65 
 66 static int
 67 memq_no_quit (elt, list)
 68      Lisp_Object elt, list;
 69 {
 70   while (CONSP (list) && ! EQ (XCAR (list), elt))
 71     list = XCDR (list);
 72   return (CONSP (list));
 73 }
 74 
 75 
 76 /* Font backend interface implementation.  */
 77 static Lisp_Object
 78 uniscribe_list (frame, font_spec)
 79      Lisp_Object frame, font_spec;
 80 {
 81   Lisp_Object fonts = w32font_list_internal (frame, font_spec, 1);
 82   FONT_ADD_LOG ("uniscribe-list", font_spec, fonts);
 83   return fonts;
 84 }
 85 
 86 static Lisp_Object
 87 uniscribe_match (frame, font_spec)
 88      Lisp_Object frame, font_spec;
 89 {
 90   Lisp_Object entity = w32font_match_internal (frame, font_spec, 1);
 91   FONT_ADD_LOG ("uniscribe-match", font_spec, entity);
 92   return entity;
 93 }
 94 
 95 static Lisp_Object
 96 uniscribe_list_family (frame)
 97      Lisp_Object frame;
 98 {
 99   Lisp_Object list = Qnil;
100   LOGFONT font_match_pattern;
101   HDC dc;
102   FRAME_PTR f = XFRAME (frame);
103 
104   bzero (&font_match_pattern, sizeof (font_match_pattern));
105   /* Limit enumerated fonts to outline fonts to save time.  */
106   font_match_pattern.lfOutPrecision = OUT_OUTLINE_PRECIS;
107 
108   dc = get_frame_dc (f);
109 
110   EnumFontFamiliesEx (dc, &font_match_pattern,
111                       (FONTENUMPROC) add_opentype_font_name_to_list,
112                       (LPARAM) &list, 0);
113   release_frame_dc (f, dc);
114 
115   return list;
116 }
117 
118 static Lisp_Object
119 uniscribe_open (f, font_entity, pixel_size)
120      FRAME_PTR f;
121      Lisp_Object font_entity;
122      int pixel_size;
123 {
124   Lisp_Object font_object
125     = font_make_object (VECSIZE (struct uniscribe_font_info),
126                         font_entity, pixel_size);
127   struct uniscribe_font_info *uniscribe_font
128     = (struct uniscribe_font_info *) XFONT_OBJECT (font_object);
129 
130   ASET (font_object, FONT_TYPE_INDEX, Quniscribe);
131 
132   if (!w32font_open_internal (f, font_entity, pixel_size, font_object))
133     {
134       return Qnil;
135     }
136 
137   /* Initialize the cache for this font.  */
138   uniscribe_font->cache = NULL;
139 
140   /* Uniscribe backend uses glyph indices.  */
141   uniscribe_font->w32_font.glyph_idx = ETO_GLYPH_INDEX;
142 
143   /* Mark the format as opentype  */
144   uniscribe_font->w32_font.font.props[FONT_FORMAT_INDEX] = Qopentype;
145   uniscribe_font->w32_font.font.driver = &uniscribe_font_driver;
146 
147   return font_object;
148 }
149 
150 static void
151 uniscribe_close (f, font)
152      FRAME_PTR f;
153      struct font *font;
154 {
155   struct uniscribe_font_info *uniscribe_font
156     = (struct uniscribe_font_info *) font;
157 
158   if (uniscribe_font->cache)
159     ScriptFreeCache (&(uniscribe_font->cache));
160 
161   w32font_close (f, font);
162 }
163 
164 /* Return a list describing which scripts/languages FONT supports by
165    which GSUB/GPOS features of OpenType tables.  */
166 static Lisp_Object
167 uniscribe_otf_capability (font)
168      struct font *font;
169 {
170   HDC context;
171   HFONT old_font;
172   struct frame *f;
173   Lisp_Object capability = Fcons (Qnil, Qnil);
174   Lisp_Object features;
175 
176   f = XFRAME (selected_frame);
177   context = get_frame_dc (f);
178   old_font = SelectObject (context, FONT_HANDLE(font));
179 
180   features = otf_features (context, "GSUB");
181   XSETCAR (capability, features);
182   features = otf_features (context, "GPOS");
183   XSETCDR (capability, features);
184 
185   SelectObject (context, old_font);
186   release_frame_dc (f, context);
187 
188   return capability;
189 }
190 
191 /* Uniscribe implementation of shape for font backend.
192 
193    Shape text in LGSTRING.  See the docstring of `font-make-gstring'
194    for the format of LGSTRING.  If the (N+1)th element of LGSTRING
195    is nil, input of shaping is from the 1st to (N)th elements.  In
196    each input glyph, FROM, TO, CHAR, and CODE are already set.
197 
198    This function updates all fields of the input glyphs.  If the
199    output glyphs (M) are more than the input glyphs (N), (N+1)th
200    through (M)th elements of LGSTRING are updated possibly by making
201    a new glyph object and storing it in LGSTRING.  If (M) is greater
202    than the length of LGSTRING, nil should be return.  In that case,
203    this function is called again with the larger LGSTRING.  */
204 static Lisp_Object
205 uniscribe_shape (lgstring)
206      Lisp_Object lgstring;
207 {
208   struct font * font;
209   struct uniscribe_font_info * uniscribe_font;
210   EMACS_UINT nchars;
211   int nitems, max_items, i, max_glyphs, done_glyphs;
212   wchar_t *chars;
213   WORD *glyphs, *clusters;
214   SCRIPT_ITEM *items;
215   SCRIPT_VISATTR *attributes;
216   int *advances;
217   GOFFSET *offsets;
218   ABC overall_metrics;
219   HRESULT result;
220   struct frame * f = NULL;
221   HDC context = NULL;
222   HFONT old_font = NULL;
223 
224   CHECK_FONT_GET_OBJECT (LGSTRING_FONT (lgstring), font);
225   uniscribe_font = (struct uniscribe_font_info *) font;
226 
227   /* Get the chars from lgstring in a form we can use with uniscribe.  */
228   max_glyphs = nchars = LGSTRING_GLYPH_LEN (lgstring);
229   done_glyphs = 0;
230   chars = (wchar_t *) alloca (nchars * sizeof (wchar_t));
231   for (i = 0; i < nchars; i++)
232     {
233       /* lgstring can be bigger than the number of characters in it, in
234          the case where more glyphs are required to display those characters.
235          If that is the case, note the real number of characters.  */
236       if (NILP (LGSTRING_GLYPH (lgstring, i)))
237         nchars = i;
238       else
239         chars[i] = LGLYPH_CHAR (LGSTRING_GLYPH (lgstring, i));
240     }
241 
242   /* First we need to break up the glyph string into runs of glyphs that
243      can be treated together.  First try a single run.  */
244   max_items = 2;
245   items = (SCRIPT_ITEM *) xmalloc (sizeof (SCRIPT_ITEM) * max_items + 1);
246 
247   while ((result = ScriptItemize (chars, nchars, max_items, NULL, NULL,
248                                   items, &nitems)) == E_OUTOFMEMORY)
249     {
250       /* If that wasn't enough, keep trying with one more run.  */
251       max_items++;
252       items = (SCRIPT_ITEM *) xrealloc (items,
253                                         sizeof (SCRIPT_ITEM) * max_items + 1);
254     }
255 
256   if (FAILED (result))
257     {
258       xfree (items);
259       return Qnil;
260     }
261 
262   /* TODO: When we get BIDI support, we need to call ScriptLayout here.
263      Requires that we know the surrounding context.  */
264 
265   glyphs = alloca (max_glyphs * sizeof (WORD));
266   clusters = alloca (nchars * sizeof (WORD));
267   attributes = alloca (max_glyphs * sizeof (SCRIPT_VISATTR));
268   advances = alloca (max_glyphs * sizeof (int));
269   offsets = alloca (max_glyphs * sizeof (GOFFSET));
270 
271   for (i = 0; i < nitems; i++)
272     {
273       int nglyphs, nchars_in_run, rtl = items[i].a.fRTL ? -1 : 1;
274       nchars_in_run = items[i+1].iCharPos - items[i].iCharPos;
275 
276       /* Context may be NULL here, in which case the cache should be
277          used without needing to select the font.  */
278       result = ScriptShape (context, &(uniscribe_font->cache),
279                             chars + items[i].iCharPos, nchars_in_run,
280                             max_glyphs - done_glyphs, &(items[i].a),
281                             glyphs, clusters, attributes, &nglyphs);
282 
283       if (result == E_PENDING && !context)
284         {
285           /* This assumes the selected frame is on the same display as the
286              one we are drawing.  It would be better for the frame to be
287              passed in.  */
288           f = XFRAME (selected_frame);
289           context = get_frame_dc (f);
290           old_font = SelectObject (context, FONT_HANDLE(font));
291 
292           result = ScriptShape (context, &(uniscribe_font->cache),
293                                 chars + items[i].iCharPos, nchars_in_run,
294                                 max_glyphs - done_glyphs, &(items[i].a),
295                                 glyphs, clusters, attributes, &nglyphs);
296         }
297 
298       if (result == E_OUTOFMEMORY)
299         {
300           /* Need a bigger lgstring.  */
301           lgstring = Qnil;
302           break;
303         }
304       else if (FAILED (result))
305         {
306           /* Can't shape this run - return results so far if any.  */
307           break;
308         }
309       else if (items[i].a.fNoGlyphIndex)
310         {
311           /* Glyph indices not supported by this font (or OS), means we
312              can't really do any meaningful shaping.  */
313           break;
314         }
315       else
316         {
317           result = ScriptPlace (context, &(uniscribe_font->cache),
318                                 glyphs, nglyphs, attributes, &(items[i].a),
319                                 advances, offsets, &overall_metrics);
320           if (result == E_PENDING && !context)
321             {
322               /* Cache not complete...  */
323               f = XFRAME (selected_frame);
324               context = get_frame_dc (f);
325               old_font = SelectObject (context, FONT_HANDLE(font));
326 
327               result = ScriptPlace (context, &(uniscribe_font->cache),
328                                     glyphs, nglyphs, attributes, &(items[i].a),
329                                     advances, offsets, &overall_metrics);
330             }
331           if (SUCCEEDED (result))
332             {
333               int j, nclusters, from, to;
334 
335               from = rtl > 0 ? 0 : nchars_in_run - 1;
336               to = from;
337 
338               for (j = 0; j < nglyphs; j++)
339                 {
340                   int lglyph_index = j + done_glyphs;
341                   Lisp_Object lglyph = LGSTRING_GLYPH (lgstring, lglyph_index);
342                   ABC char_metric;
343                   unsigned gl;
344 
345                   if (NILP (lglyph))
346                     {
347                       lglyph = Fmake_vector (make_number (LGLYPH_SIZE), Qnil);
348                       LGSTRING_SET_GLYPH (lgstring, lglyph_index, lglyph);
349                     }
350                   /* Copy to a 32-bit data type to shut up the
351                      compiler warning in LGLYPH_SET_CODE about
352                      comparison being always false.  */
353                   gl = glyphs[j];
354                   LGLYPH_SET_CODE (lglyph, gl);
355 
356                   /* Detect clusters, for linking codes back to characters.  */
357                   if (attributes[j].fClusterStart)
358                     {
359                       while (from >= 0 && from < nchars_in_run
360                              && clusters[from] < j)
361                         from += rtl;
362                       if (from < 0)
363                         from = to = 0;
364                       else if (from >= nchars_in_run)
365                         from = to = nchars_in_run - 1;
366                       else
367                         {
368                           int k;
369                           to = rtl > 0 ? nchars_in_run - 1 : 0;
370                           for (k = from + rtl; k >= 0 && k < nchars_in_run;
371                                k += rtl)
372                             {
373                               if (clusters[k] > j)
374                                 {
375                                   to = k - 1;
376                                   break;
377                                 }
378                             }
379                         }
380                     }
381 
382                   LGLYPH_SET_CHAR (lglyph, chars[items[i].iCharPos
383                                                  + from]);
384                   LGLYPH_SET_FROM (lglyph, items[i].iCharPos + from);
385                   LGLYPH_SET_TO (lglyph, items[i].iCharPos + to);
386 
387                   /* Metrics.  */
388                   LGLYPH_SET_WIDTH (lglyph, advances[j]);
389                   LGLYPH_SET_ASCENT (lglyph, font->ascent);
390                   LGLYPH_SET_DESCENT (lglyph, font->descent);
391 
392                   result = ScriptGetGlyphABCWidth (context,
393                                                    &(uniscribe_font->cache),
394                                                    glyphs[j], &char_metric);
395                   if (result == E_PENDING && !context)
396                     {
397                       /* Cache incomplete... */
398                       f = XFRAME (selected_frame);
399                       context = get_frame_dc (f);
400                       old_font = SelectObject (context, FONT_HANDLE(font));
401                       result = ScriptGetGlyphABCWidth (context,
402                                                        &(uniscribe_font->cache),
403                                                        glyphs[j], &char_metric);
404                     }
405 
406                   if (SUCCEEDED (result))
407                     {
408                       LGLYPH_SET_LBEARING (lglyph, char_metric.abcA);
409                       LGLYPH_SET_RBEARING (lglyph, (char_metric.abcA
410                                                     + char_metric.abcB));
411                     }
412                   else
413                     {
414                       LGLYPH_SET_LBEARING (lglyph, 0);
415                       LGLYPH_SET_RBEARING (lglyph, advances[j]);
416                     }
417 
418                   if (offsets[j].du || offsets[j].dv)
419                     {
420                       Lisp_Object vec;
421                       vec = Fmake_vector (make_number (3), Qnil);
422                       ASET (vec, 0, make_number (offsets[j].du));
423                       ASET (vec, 1, make_number (offsets[j].dv));
424                       /* Based on what ftfont.c does... */
425                       ASET (vec, 2, make_number (advances[j]));
426                       LGLYPH_SET_ADJUSTMENT (lglyph, vec);
427                     }
428                   else
429                     LGLYPH_SET_ADJUSTMENT (lglyph, Qnil);
430                 }
431             }
432         }
433       done_glyphs += nglyphs;
434     }
435 
436   xfree (items);
437 
438   if (context)
439     {
440       SelectObject (context, old_font);
441       release_frame_dc (f, context);
442     }
443 
444   if (NILP (lgstring))
445     return Qnil;
446   else
447     return make_number (done_glyphs);
448 }
449 
450 /* Uniscribe implementation of encode_char for font backend.
451    Return a glyph code of FONT for characer C (Unicode code point).
452    If FONT doesn't have such a glyph, return FONT_INVALID_CODE.  */
453 static unsigned
454 uniscribe_encode_char (font, c)
455      struct font *font;
456      int c;
457 {
458   HDC context = NULL;
459   struct frame *f = NULL;
460   HFONT old_font = NULL;
461   unsigned code = FONT_INVALID_CODE;
462   wchar_t ch[2];
463   int len;
464   SCRIPT_ITEM* items;
465   int nitems;
466   struct uniscribe_font_info *uniscribe_font
467     = (struct uniscribe_font_info *)font;
468 
469   if (c < 0x10000)
470     {
471       ch[0] = (wchar_t) c;
472       len = 1;
473     }
474   else
475     {
476       DWORD surrogate = c - 0x10000;
477 
478       /* High surrogate: U+D800 - U+DBFF.  */
479       ch[0] = 0xD800 + ((surrogate >> 10) & 0x03FF);
480       /* Low surrogate: U+DC00 - U+DFFF.  */
481       ch[1] = 0xDC00 + (surrogate & 0x03FF);
482       len = 2;
483     }
484 
485   /* Non BMP characters must be handled by the uniscribe shaping
486      engine as GDI functions (except blindly displaying lines of
487      unicode text) and the promising looking ScriptGetCMap do not
488      convert surrogate pairs to glyph indexes correctly.  */
489     {
490       items = (SCRIPT_ITEM *) alloca (sizeof (SCRIPT_ITEM) * 2 + 1);
491       if (SUCCEEDED (ScriptItemize (ch, len, 2, NULL, NULL, items, &nitems)))
492         {
493           HRESULT result;
494           /* Surrogates seem to need 2 here, even though only one glyph is
495              returned.  Indic characters can also produce 2 or more glyphs for
496              a single code point, but they need to use uniscribe_shape
497              above for correct display.  */
498           WORD glyphs[2], clusters[2];
499           SCRIPT_VISATTR attrs[2];
500           int nglyphs;
501 
502           result = ScriptShape (context, &(uniscribe_font->cache),
503                                 ch, len, 2, &(items[0].a),
504                                 glyphs, clusters, attrs, &nglyphs);
505 
506           if (result == E_PENDING)
507             {
508               /* Use selected frame until API is updated to pass
509                  the frame.  */
510               f = XFRAME (selected_frame);
511               context = get_frame_dc (f);
512               old_font = SelectObject (context, FONT_HANDLE(font));
513               result = ScriptShape (context, &(uniscribe_font->cache),
514                                     ch, len, 2, &(items[0].a),
515                                     glyphs, clusters, attrs, &nglyphs);
516             }
517 
518           if (SUCCEEDED (result) && nglyphs == 1)
519             {
520               /* Some fonts return .notdef glyphs instead of failing.
521                  (Truetype spec reserves glyph code 0 for .notdef)  */
522               if (glyphs[0])
523                 code = glyphs[0];
524             }
525           else if (SUCCEEDED (result) || result == E_OUTOFMEMORY)
526             {
527               /* This character produces zero or more than one glyph
528                  when shaped. But we still need the return from here
529                  to be valid for the shaping engine to be invoked
530                  later.  */
531               result = ScriptGetCMap (context, &(uniscribe_font->cache),
532                                       ch, len, 0, glyphs);
533               if (SUCCEEDED (result) && glyphs[0])
534                 code = glyphs[0];
535             }
536         }
537     }
538     if (context)
539       {
540         SelectObject (context, old_font);
541         release_frame_dc (f, context);
542       }
543 
544     return code;
545 }
546 
547 /*
548    Shared with w32font:
549    Lisp_Object uniscribe_get_cache (Lisp_Object frame);
550    void uniscribe_free_entity (Lisp_Object font_entity);
551    int uniscribe_has_char (Lisp_Object entity, int c);
552    int uniscribe_text_extents (struct font *font, unsigned *code,
553                                int nglyphs, struct font_metrics *metrics);
554    int uniscribe_draw (struct glyph_string *s, int from, int to,
555                        int x, int y, int with_background);
556 
557    Unused:
558    int uniscribe_prepare_face (FRAME_PTR f, struct face *face);
559    void uniscribe_done_face (FRAME_PTR f, struct face *face);
560    int uniscribe_get_bitmap (struct font *font, unsigned code,
561                              struct font_bitmap *bitmap, int bits_per_pixel);
562    void uniscribe_free_bitmap (struct font *font, struct font_bitmap *bitmap);
563    void * uniscribe_get_outline (struct font *font, unsigned code);
564    void uniscribe_free_outline (struct font *font, void *outline);
565    int uniscribe_anchor_point (struct font *font, unsigned code,
566                                int index, int *x, int *y);
567    int uniscribe_start_for_frame (FRAME_PTR f);
568    int uniscribe_end_for_frame (FRAME_PTR f);
569 
570 */
571 
572 
573 /* Callback function for EnumFontFamiliesEx.
574    Adds the name of opentype fonts to a Lisp list (passed in as the
575    lParam arg). */
576 static int CALLBACK
577 add_opentype_font_name_to_list (logical_font, physical_font, font_type,
578                                 list_object)
579      ENUMLOGFONTEX *logical_font;
580      NEWTEXTMETRICEX *physical_font;
581      DWORD font_type;
582      LPARAM list_object;
583 {
584   Lisp_Object* list = (Lisp_Object *) list_object;
585   Lisp_Object family;
586 
587   /* Skip vertical fonts (intended only for printing)  */
588   if (logical_font->elfLogFont.lfFaceName[0] == '@')
589     return 1;
590 
591   /* Skip non opentype fonts.  Count old truetype fonts as opentype,
592      as some of them do contain GPOS and GSUB data that Uniscribe
593      can make use of.  */
594   if (!(physical_font->ntmTm.ntmFlags & NTMFLAGS_OPENTYPE)
595       && font_type != TRUETYPE_FONTTYPE)
596     return 1;
597 
598   /* Skip fonts that have no unicode coverage.  */
599   if (!physical_font->ntmFontSig.fsUsb[3]
600       && !physical_font->ntmFontSig.fsUsb[2]
601       && !physical_font->ntmFontSig.fsUsb[1]
602       && !(physical_font->ntmFontSig.fsUsb[0] & 0x3fffffff))
603     return 1;
604 
605   family = intern_font_name (logical_font->elfLogFont.lfFaceName);
606   if (! memq_no_quit (family, *list))
607     *list = Fcons (family, *list);
608 
609   return 1;
610 }
611 
612 
613 /* :otf property handling.
614    Since the necessary Uniscribe APIs for getting font tag information
615    are only available in Vista, we need to parse the font data directly
616    according to the OpenType Specification.  */
617 
618 /* Push into DWORD backwards to cope with endianness.  */
619 #define OTF_TAG(STR)                                          \
620   ((STR[3] << 24) | (STR[2] << 16) | (STR[1] << 8) | STR[0])
621 
622 #define OTF_INT16_VAL(TABLE, OFFSET, PTR)                    \
623   do {                                                       \
624     BYTE temp, data[2];                                      \
625     if (GetFontData (context, TABLE, OFFSET, data, 2) != 2)  \
626       goto font_table_error;                                 \
627     temp = data[0], data[0] = data[1], data[1] = temp;       \
628     memcpy (PTR, data, 2);                                   \
629   } while (0)
630 
631 /* Do not reverse the bytes, because we will compare with a OTF_TAG value
632    that has them reversed already.  */
633 #define OTF_DWORDTAG_VAL(TABLE, OFFSET, PTR)                    \
634   do {                                                          \
635     if (GetFontData (context, TABLE, OFFSET, PTR, 4) != 4)      \
636       goto font_table_error;                                    \
637   } while (0)
638 
639 #define OTF_TAG_VAL(TABLE, OFFSET, STR)                      \
640   do {                                                       \
641     if (GetFontData (context, TABLE, OFFSET, STR, 4) != 4)   \
642       goto font_table_error;                                 \
643     STR[4] = '\0';                                           \
644   } while (0)
645 
646 static char* NOTHING = "    ";
647 
648 #define SNAME(VAL) SDATA (SYMBOL_NAME (VAL))
649 
650 /* Check if font supports the otf script/language/features specified.
651    OTF_SPEC is in the format
652      (script lang [(gsub_feature ...)|nil] [(gpos_feature ...)]?) */
653 int uniscribe_check_otf (font, otf_spec)
654      LOGFONT *font;
655      Lisp_Object otf_spec;
656 {
657   Lisp_Object script, lang, rest;
658   Lisp_Object features[2];
659   DWORD feature_tables[2];
660   DWORD script_tag, default_script, lang_tag = 0;
661   struct frame * f;
662   HDC context;
663   HFONT check_font, old_font;
664   DWORD table;
665   int i, retval = 0;
666   struct gcpro gcpro1;
667 
668   /* Check the spec is in the right format.  */
669   if (!CONSP (otf_spec) || XINT (Flength (otf_spec)) < 3)
670     return 0;
671 
672   /* Break otf_spec into its components.  */
673   script = XCAR (otf_spec);
674   rest = XCDR (otf_spec);
675 
676   lang = XCAR (rest);
677   rest = XCDR (rest);
678 
679   features[0] = XCAR (rest);
680   rest = XCDR (rest);
681   if (NILP (rest))
682     features[1] = Qnil;
683   else
684     features[1] = XCAR (rest);
685 
686   /* Set up tags we will use in the search.  */
687   feature_tables[0] = OTF_TAG ("GSUB");
688   feature_tables[1] = OTF_TAG ("GPOS");
689   default_script = OTF_TAG ("DFLT");
690   if (NILP (script))
691     script_tag = default_script;
692   else
693     script_tag = OTF_TAG (SNAME (script));
694   if (!NILP (lang))
695     lang_tag = OTF_TAG (SNAME (lang));
696 
697   /* Set up graphics context so we can use the font.  */
698   f = XFRAME (selected_frame);
699   context = get_frame_dc (f);
700   check_font = CreateFontIndirect (font);
701   old_font = SelectObject (context, check_font);
702 
703   /* Everything else is contained within otf_spec so should get
704      marked along with it.  */
705   GCPRO1 (otf_spec);
706 
707   /* Scan GSUB and GPOS tables.  */
708   for (i = 0; i < 2; i++)
709     {
710       int j, n_match_features;
711       unsigned short scriptlist_table, feature_table, n_scripts;
712       unsigned short script_table, langsys_table, n_langs;
713       unsigned short feature_index, n_features;
714       DWORD tbl = feature_tables[i];
715 
716       /* Skip if no features requested from this table.  */
717       if (NILP (features[i]))
718         continue;
719 
720       /* If features is not a cons, this font spec is messed up.  */
721       if (!CONSP (features[i]))
722         goto no_support;
723 
724       /* Read GPOS/GSUB header.  */
725       OTF_INT16_VAL (tbl, 4, &scriptlist_table);
726       OTF_INT16_VAL (tbl, 6, &feature_table);
727       OTF_INT16_VAL (tbl, scriptlist_table, &n_scripts);
728 
729       /* Find the appropriate script table.  */
730       script_table = 0;
731       for (j = 0; j < n_scripts; j++)
732         {
733           DWORD script_id;
734           OTF_DWORDTAG_VAL (tbl, scriptlist_table + 2 + j * 6, &script_id);
735           if (script_id == script_tag)
736             {
737               OTF_INT16_VAL (tbl, scriptlist_table + 6 + j * 6, &script_table);
738               break;
739             }
740 #if 0     /* Causes false positives.  */
741           /* If there is a DFLT script defined in the font, use it
742              if the specified script is not found.  */
743           else if (script_id == default_script)
744             OTF_INT16_VAL (tbl, scriptlist_table + 6 + j * 6, &script_table);
745 #endif
746         }
747       /* If no specific or default script table was found, then this font
748          does not support the script.  */
749       if (!script_table)
750         goto no_support;
751 
752       /* Offset is from beginning of scriptlist_table.  */
753       script_table += scriptlist_table;
754 
755       /* Get default langsys table.  */
756       OTF_INT16_VAL (tbl, script_table, &langsys_table);
757 
758       /* If lang was specified, see if font contains a specific entry.  */
759       if (!NILP (lang))
760         {
761           OTF_INT16_VAL (tbl, script_table + 2, &n_langs);
762 
763           for (j = 0; j < n_langs; j++)
764             {
765               DWORD lang_id;
766               OTF_DWORDTAG_VAL (tbl, script_table + 4 + j * 6, &lang_id);
767               if (lang_id == lang_tag)
768                 {
769                   OTF_INT16_VAL (tbl, script_table + 8 + j * 6, &langsys_table);
770                   break;
771                 }
772             }
773         }
774 
775       if (!langsys_table)
776         goto no_support;
777 
778       /* Offset is from beginning of script table.  */
779       langsys_table += script_table;
780 
781       /* Check the features.  Features may contain nil according to
782          documentation in font_prop_validate_otf, so count them.  */
783       n_match_features = 0;
784       for (rest = features[i]; CONSP (rest); rest = XCDR (rest))
785         {
786           Lisp_Object feature = XCAR (rest);
787           if (!NILP (feature))
788             n_match_features++;
789         }
790 
791       /* If there are no features to check, skip checking.  */
792       if (!n_match_features)
793         continue;
794 
795       /* First check required feature (if any).  */
796       OTF_INT16_VAL (tbl, langsys_table + 2, &feature_index);
797       if (feature_index != 0xFFFF)
798         {
799           char feature_id[5];
800           OTF_TAG_VAL (tbl, feature_table + 2 + feature_index * 6, feature_id);
801           OTF_TAG_VAL (tbl, feature_table + 2 + feature_index * 6, feature_id);
802           /* Assume no duplicates in the font table. This allows us to mark
803              the features off by simply decrementing a counter.  */
804           if (!NILP (Fmemq (intern (feature_id), features[i])))
805             n_match_features--;
806         }
807       /* Now check all the other features.  */
808       OTF_INT16_VAL (tbl, langsys_table + 4, &n_features);
809       for (j = 0; j < n_features; j++)
810         {
811           char feature_id[5];
812           OTF_INT16_VAL (tbl, langsys_table + 6 + j * 2, &feature_index);
813           OTF_TAG_VAL (tbl, feature_table + 2 + feature_index * 6, feature_id);
814           /* Assume no duplicates in the font table. This allows us to mark
815              the features off by simply decrementing a counter.  */
816           if (!NILP (Fmemq (intern (feature_id), features[i])))
817             n_match_features--;
818         }
819 
820       if (n_match_features > 0)
821         goto no_support;
822     }
823 
824   retval = 1;
825 
826  no_support:
827  font_table_error:
828   /* restore graphics context.  */
829   SelectObject (context, old_font);
830   DeleteObject (check_font);
831   release_frame_dc (f, context);
832 
833   return retval;
834 }
835 
836 static Lisp_Object
837 otf_features (HDC context, char *table)
838 {
839   Lisp_Object script_list = Qnil;
840   unsigned short scriptlist_table, n_scripts, feature_table;
841   DWORD tbl = OTF_TAG (table);
842   int i, j, k;
843 
844   /* Look for scripts in the table.  */
845   OTF_INT16_VAL (tbl, 4, &scriptlist_table);
846   OTF_INT16_VAL (tbl, 6, &feature_table);
847   OTF_INT16_VAL (tbl, scriptlist_table, &n_scripts);
848 
849   for (i = 0; i < n_scripts; i++)
850     {
851       char script[5], lang[5];
852       unsigned short script_table, lang_count, langsys_table, feature_count;
853       Lisp_Object script_tag, langsys_list, langsys_tag, feature_list;
854       unsigned short record_offset = scriptlist_table + 2 + i * 6;
855       OTF_TAG_VAL (tbl, record_offset, script);
856       OTF_INT16_VAL (tbl, record_offset + 4, &script_table);
857 
858       /* Offset is from beginning of script table.  */
859       script_table += scriptlist_table;
860 
861       script_tag = intern (script);
862       langsys_list = Qnil;
863 
864       /* Optional default lang.  */
865       OTF_INT16_VAL (tbl, script_table, &langsys_table);
866       if (langsys_table)
867         {
868           /* Offset is from beginning of script table.  */
869           langsys_table += script_table;
870 
871           langsys_tag = Qnil;
872           feature_list = Qnil;
873           OTF_INT16_VAL (tbl, langsys_table + 4, &feature_count);
874           for (k = 0; k < feature_count; k++)
875             {
876               char feature[5];
877               unsigned short index;
878               OTF_INT16_VAL (tbl, langsys_table + 6 + k * 2, &index);
879               OTF_TAG_VAL (tbl, feature_table + 2 + index * 6, feature);
880               feature_list = Fcons (intern (feature), feature_list);
881             }
882           langsys_list = Fcons (Fcons (langsys_tag, feature_list),
883                                 langsys_list);
884         }
885 
886       /* List of supported languages.  */
887       OTF_INT16_VAL (tbl, script_table + 2, &lang_count);
888 
889       for (j = 0; j < lang_count; j++)
890         {
891           record_offset = script_table + 4 + j * 6;
892           OTF_TAG_VAL (tbl, record_offset, lang);
893           OTF_INT16_VAL (tbl, record_offset + 4, &langsys_table);
894 
895           /* Offset is from beginning of script table.  */
896           langsys_table += script_table;
897 
898           langsys_tag = intern (lang);
899           feature_list = Qnil;
900           OTF_INT16_VAL (tbl, langsys_table + 4, &feature_count);
901           for (k = 0; k < feature_count; k++)
902             {
903               char feature[5];
904               unsigned short index;
905               OTF_INT16_VAL (tbl, langsys_table + 6 + k * 2, &index);
906               OTF_TAG_VAL (tbl, feature_table + 2 + index * 6, feature);
907               feature_list = Fcons (intern (feature), feature_list);
908             }
909           langsys_list = Fcons (Fcons (langsys_tag, feature_list),
910                                 langsys_list);
911 
912         }
913 
914       script_list = Fcons (Fcons (script_tag, langsys_list), script_list);
915     }
916 
917   return script_list;
918 
919 font_table_error:
920   return Qnil;
921 }
922 
923 #undef OTF_INT16_VAL
924 #undef OTF_TAG_VAL
925 #undef OTF_TAG
926 
927 
928 struct font_driver uniscribe_font_driver =
929   {
930     0, /* Quniscribe */
931     0, /* case insensitive */
932     w32font_get_cache,
933     uniscribe_list,
934     uniscribe_match,
935     uniscribe_list_family,
936     NULL, /* free_entity */
937     uniscribe_open,
938     uniscribe_close,
939     NULL, /* prepare_face */
940     NULL, /* done_face */
941     w32font_has_char,
942     uniscribe_encode_char,
943     w32font_text_extents,
944     w32font_draw,
945     NULL, /* get_bitmap */
946     NULL, /* free_bitmap */
947     NULL, /* get_outline */
948     NULL, /* free_outline */
949     NULL, /* anchor_point */
950     uniscribe_otf_capability, /* Defined so (font-get FONTOBJ :otf) works.  */ 
951     NULL, /* otf_drive - use shape instead.  */
952     NULL, /* start_for_frame */
953     NULL, /* end_for_frame */
954     uniscribe_shape
955   };
956 
957 /* Note that this should be called at every startup, not just when dumping,
958    as it needs to test for the existence of the Uniscribe library.  */
959 void
960 syms_of_w32uniscribe ()
961 {
962   HMODULE uniscribe;
963 
964   /* Don't init uniscribe when dumping */
965   if (!initialized)
966     return;
967 
968   /* Don't register if uniscribe is not available.  */
969   uniscribe = GetModuleHandle ("usp10");
970   if (!uniscribe)
971     return;
972 
973   uniscribe_font_driver.type = Quniscribe;
974   uniscribe_available = 1;
975 
976   register_font_driver (&uniscribe_font_driver, NULL);
977 }
978 
979 /* arch-tag: 9530f0e1-7471-47dd-a780-94330af87ea0
980    (do not change this comment) */