Mercurial > hg > xemacs-beta

changeset 5763:23dc211f4d2f

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Make fc-name-parse signal on invalid-argument. Add fc-name-parse-harder, which retries without unparseable attributes. Add tests for fc-name-parse and fc-name-parse-harder. A few fixups in comments and docstrings.
author Stephen J. Turnbull <stephen@xemacs.org>
date Sun, 15 Sep 2013 23:50:20 +0900
parents 427a72c6ee17
children 7addb3dbe4b4
files lisp/ChangeLog lisp/font.el lisp/fontconfig.el src/ChangeLog src/font-mgr.c tests/ChangeLog tests/automated/face-tests.el
diffstat 7 files changed, 214 insertions(+), 12 deletions(-) [+]
line wrap: on
line diff
--- a/lisp/ChangeLog	Sun Sep 15 23:47:37 2013 +0900
+++ b/lisp/ChangeLog	Sun Sep 15 23:50:20 2013 +0900
@@ -1,3 +1,10 @@
+2013-09-10  Stephen J. Turnbull  <stephen@xemacs.org>
+
+	* fontconfig.el (fc-name-parse-known-problem-attributes): New.
+	(fc-name-parse-harder): New.
+
+	* font.el (xft-font-create-object): Use fc-name-parse-harder.
+
 2013-08-21  Aidan Kehoe  <kehoea@parhasard.net>
 
 	* startup.el (normal-top-level):
--- a/lisp/font.el	Sun Sep 15 23:47:37 2013 +0900
+++ b/lisp/font.el	Sun Sep 15 23:50:20 2013 +0900
@@ -1,7 +1,7 @@
 ;;; font.el --- New font model
 
 ;; Copyright (c) 1995, 1996 by William M. Perry (wmperry@cs.indiana.edu)
-;; Copyright (c) 1996, 1997 Free Software Foundation, Inc.
+;; Copyright (c) 1996, 1997, 2013 Free Software Foundation, Inc.
 ;; Copyright (C) 2002, 2004 Ben Wing.
 
 ;; Author: wmperry
@@ -786,7 +786,9 @@
 Optional DEVICE defaults to `default-x-device'."
   (let* ((name fontname)
 	 (device (or device (default-x-device)))
-	 (pattern (fc-font-match device (fc-name-parse name)))
+	 ;; names generated by font-instance-truename may contain
+	 ;; unparseable object specifications
+	 (pattern (fc-font-match device (fc-name-parse-harder name)))
 	 (font-obj (make-font))
 	 (family (fc-pattern-get-family pattern 0))
 	 (size (fc-pattern-get-or-compute-size pattern 0))
--- a/lisp/fontconfig.el	Sun Sep 15 23:47:37 2013 +0900
+++ b/lisp/fontconfig.el	Sun Sep 15 23:50:20 2013 +0900
@@ -1,7 +1,7 @@
 ;;; fontconfig.el --- New font model, NG
 
 ;; Copyright (c) 2003 Eric Knauel and Matthias Neubauer
-;; Copyright (C) 2004, 2005 Free Software Foundation, Inc.
+;; Copyright (C) 2004, 2005, 2013 Free Software Foundation, Inc.
 
 ;; Authors:	Eric Knauel <knauel@informatik.uni-tuebingen.de>
 ;;		Matthias Neubauer <neubauer@informatik.uni-freiburg.de>
@@ -519,6 +519,77 @@
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;
+;; Workarounds
+;;
+
+(defvar fc-name-parse-known-problem-attributes
+  '("charset")
+  "List of attribute names known to induce fc-name-parse failures.
+
+Note: The name returned by `xft-font-truename' has been observed to be
+unparseable.  The cause is unknown so you can't assume getting a name from a
+font instance then instantiating the font again will round-trip.  Hypotheses:
+\(1) name too long. FALSE
+\(2) name has postscriptname attribute. FALSE
+\(3) name has charset attribute. OBSERVED")
+
+(defun fc-name-parse-harder (fontname)
+  "Parse an Fc font name and return its representation as a Fc pattern object.
+Unlike `fc-parse-name', unparseable objects are skipped and reported in the
+*Warnings* buffer.  \(The *Warnings* buffer is popped up unless all of the
+unparsed objects are listed in `fc-name-parse-known-problem-attributes'.)"
+  (labels ((repair-embedded-colons (l)
+	     ;; #### May need generalization to other separators?
+	     (let ((ll l))
+	       (while (cdr l)
+	         (when (string-match ".*\\\\$" (cadr l))
+		   (setcdr l (cons (concat (cadr l) ":" (caddr l)) (cdddr l))))
+	         (setq l (cdr l)))
+	       ll))
+	   (prepare-omits (object)
+	     (declare (special display))
+	     (let* ((reports fc-name-parse-known-problem-attributes)
+		    (report (car reports))
+		    (display-this t))
+	       (while reports
+		 (if (string= report (subseq object 0 (length report)))
+		     (setq object (concat "(KNOWN) " object)
+			   display-this nil
+			   reports nil)
+		   (setq report (pop reports))))
+	       (push display-this display)
+	       (concat object "\n")))
+	   (any (bools)
+	     (let (ret)
+	       (while bools
+		 (setq ret (or (pop bools) ret))))))
+    (let* ((objects (repair-embedded-colons (split-string fontname ":")))
+	   (name (pop objects))
+	   (omits nil)
+	   (outcomes (list 'dummy)))
+      (while objects
+        (let ((object (pop objects)))
+	  (condition-case nil
+	      (let ((try (concat name ":" object)))
+	        (fc-name-parse try)
+	        (setq name try))
+	    (invalid-argument
+	     (push object omits)))))
+      (when omits
+	(setq display nil)
+	(setq omits (mapconcat #'prepare-omits omits ""))
+	(lwarn 'fontconfig (if (apply #'any display) 'warning 'info)
+	  "Some objects in fontname weren't parsed (details in *Warnings*).
+This shouldn't affect your XEmacs except that the font may be inaccurate.
+Please report any unparseable objects below not marked as KNOWN with
+M-x report-xemacs-bug.  Objects:\n%sFontname:\n%s"
+	  omits
+	  fontname))
+      (fc-name-parse name)
+      )))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
 ;; The XLFD fontname UI
 ;;
 
--- a/src/ChangeLog	Sun Sep 15 23:47:37 2013 +0900
+++ b/src/ChangeLog	Sun Sep 15 23:50:20 2013 +0900
@@ -1,3 +1,9 @@
+2013-09-10  Stephen J. Turnbull  <stephen@xemacs.org>
+
+	* font-mgr.c: Fix a bunch of comments and reformat some docstrings.
+	(Ffc_name_parse):
+	Make FcNameParse signal invalid-argument when parse fails.
+
 2013-09-09  Stephen J. Turnbull  <stephen@xemacs.org>
 
 	* alloc.c (free_normal_lisp_object):
--- a/src/font-mgr.c	Sun Sep 15 23:47:37 2013 +0900
+++ b/src/font-mgr.c	Sun Sep 15 23:50:20 2013 +0900
@@ -2,7 +2,7 @@
 
 Copyright (C) 2003 Eric Knauel and Matthias Neubauer
 Copyright (C) 2005 Eric Knauel
-Copyright (C) 2004-2009 Free Software Foundation, Inc.
+Copyright (C) 2004-2009, 2013 Free Software Foundation, Inc.
 Copyright (C) 2010 Ben Wing.
 
 Authors:	Eric Knauel <knauel@informatik.uni-tuebingen.de>
@@ -143,11 +143,9 @@
 static void string_list_to_fcobjectset (Lisp_Object list, FcObjectSet *os);
 
 /* 
-   extract the C representation of the Lisp string STR and convert it
+   Extract the C representation of the Lisp string STR and convert it
    to the encoding used by the Fontconfig API for property and font
-   names.  I suppose that Qnative is the right encoding, the manual
-   doesn't say much about this topic.  This functions assumes that STR
-   is a Lisp string.
+   names.  These functions assume that STR is a Lisp string.
 */
 #define extract_fcapi_string(str) \
   (LISP_STRING_TO_EXTERNAL ((str), Qfc_font_name_encoding))
@@ -157,6 +155,7 @@
 
 /* #### This homebrew lashup should be replaced with FcConstants.
 
+   #### This isn't true any more (fontconfig v2.10.95), if it ever was.
    fontconfig assumes that objects (property names) are statically allocated,
    and you will get bizarre results if you pass Lisp string data or strings
    allocated on the stack as objects.  fontconfig _does_ copy values, so we
@@ -227,19 +226,28 @@
   fc_pattern *fcpat = XFC_PATTERN (ALLOC_NORMAL_LISP_OBJECT (fc_pattern));
 
   fcpat->fcpatPtr = FcPatternCreate ();
+  assert (fcpat->fcpatPtr);
   return wrap_fc_pattern (fcpat);
 }
 
 DEFUN ("fc-name-parse", Ffc_name_parse, 1, 1, 0, /*
-Parse an Fc font name and return its representation as a fc pattern object.
+Parse an Fc font name and return its representation as a Fc pattern object.
+Signal `invalid-argument' if the name is unparseable.
+
+Note: The name returned by xft-font-truename has been observed to be
+unparseable \(in the case of the xft-font-default-font-name).  The cause
+is unknown so you can't assume getting a name from a font instance then
+instantiating the font again will round-trip.  See `fc-name-parse-harder'.
 */
       (name))
 {
   fc_pattern *fcpat = XFC_PATTERN (ALLOC_NORMAL_LISP_OBJECT (fc_pattern));
 
   CHECK_STRING (name);
-
   fcpat->fcpatPtr = FcNameParse ((FcChar8 *) extract_fcapi_string (name));
+  if (!fcpat->fcpatPtr)
+    /* #### Is this the best API?  Could return a symbol or similar. */
+    invalid_argument ("unparseable Fc font name", name);
   return wrap_fc_pattern (fcpat);
 }
 
@@ -1386,8 +1394,8 @@
 #endif
 
   DEFVAR_LISP ("xft-xlfd-font-regexp", &Vxlfd_font_name_regexp /*
-The regular expression used to match XLFD font names. */			       
-	      );
+The regular expression used to match XLFD font names.
+*/ );
   Vxlfd_font_name_regexp = make_xlfd_font_regexp();
 }
 
--- a/tests/ChangeLog	Sun Sep 15 23:47:37 2013 +0900
+++ b/tests/ChangeLog	Sun Sep 15 23:50:20 2013 +0900
@@ -1,3 +1,7 @@
+2013-09-10  Stephen J. Turnbull  <stephen@xemacs.org>
+
+	* automated/face-tests.el: New file.  Start with fontconfig tests.
+
 2013-06-23  Stephen J. Turnbull  <stephen@xemacs.org>
 
 	* XEmacs 21.5.34 "kale" is released.
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/tests/automated/face-tests.el	Sun Sep 15 23:50:20 2013 +0900
@@ -0,0 +1,104 @@
+;;; face-tests.el --- test text display (faces, fonts)   -*- coding: utf-8 -*-
+
+;; Copyright (C) 2013 Free Software Foundation, Inc.
+
+;; Author: Stephen J. Turnbull <stephen@xemacs.org>
+;; Created: 2013
+;; Keywords: tests
+
+;; This file is part of XEmacs.
+
+;; XEmacs is free software: you can redistribute it and/or modify it
+;; under the terms of the GNU General Public License as published by the
+;; Free Software Foundation, either version 3 of the License, or (at your
+;; option) any later version.
+
+;; XEmacs is distributed in the hope that it will be useful, but WITHOUT
+;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+;; FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
+;; for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with XEmacs.  If not, see <http://www.gnu.org/licenses/>.
+
+;;; Synched up with: Not in FSF.
+
+;;; Commentary:
+
+;; Test text display (faces, fonts)
+
+;; Test fontconfig
+
+(let* ((test-name-parts
+	'("Bitstream Vera Sans Mono-16"
+	  "familylang=en"
+	  "style=Roman"
+	  "stylelang=en"
+	  "fullname=Bitstream Vera Sans Mono"
+	  "fullnamelang=en"
+	  "slant=0"
+	  "weight=80"
+	  "width=100"
+	  "pixelsize=21.3174"
+	  "spacing=100"
+	  "foundry=bitstream"
+	  "antialias=True"
+	  "hintstyle=3"
+	  "hinting=True"
+	  "verticallayout=False"
+	  "autohint=False"
+	  "globaladvance=True"
+	  "file=/usr/X11/lib/X11/fonts/TTF/VeraMono.ttf"
+	  "index=0"
+	  "outline=True"
+	  "scalable=True"
+	  "dpi=95.9282"
+	  "rgba=0"
+	  "scale=1"
+	  "minspace=False"
+	  "charset=  |>^1!|>^1!P0oWQ |>^1!|>^1!|>^1!!!!%#gfN8.!!B7%ggR6OF3y?4!!K?&   !!!)$      9;*f! !!!.%     !!!)$!!!!# !!#0GM>RAd#y#fx   !!!W5  !!#3H !!!!&      !!#6I<UKaX!!!?+!!!%#!!!!X    !!#AL      !!!1& !!+u{!!!!)       "
+	  "lang=aa|ay|bi|br|ch|co|da|de|en|es|et|eu|fi|fj|fo|fr|fur|fy|gd|gl|gv|ho|ia|id|ie|io|is|it|lb|mg|nb|nds|nl|nn|no|nr|nso|oc|om|pt|rm|sma|smj|so|sq|ss|st|sv|sw|tl|tn|tr|ts|uz|vo|vot|wa|xh|yap|zu|an|crh|fil|ht|jv|kj|ku-tr|kwm|li|ms|ng|pap-an|pap-aw|rn|rw|sc|sg|sn|su|za"
+	  "fontversion=131072"
+	  "fontformat=TrueType"
+	  "embolden=False"
+	  "embeddedbitmap=True"
+	  "decorative=False"
+	  "lcdfilter=1"
+	  "namelang=en"
+	  "prgname=xemacs"
+	  "hash=sha256\\:da4281dc7db17a3dfce64a62ced92875c5895340055ec8ba24a3914eb97b349d"
+	  "postscriptname=BitstreamVeraSansMono-Roman"))
+	(test-name-degenerate "")
+	(test-name-trivial (nth 0 test-name-parts))
+	(test-name-short
+	 (concat (nth 0 test-name-parts) ":" (nth 26 test-name-parts)))
+	(test-name-long	(mapconcat #'identity
+				   (append (subseq test-name-parts 0 26)
+					   (subseq test-name-parts 27))
+				   ":"))
+	(test-name-full (mapconcat #'identity test-name-parts ":"))
+	)
+  (labels ((try (fontname)
+	     (fc-name-unparse (fc-name-parse fontname)))
+	   (try-harder (fontname)
+	     (fc-name-unparse (fc-name-parse-harder fontname))))
+    (Assert (string= test-name-degenerate (try test-name-degenerate)))
+    (Assert (string= test-name-degenerate (try-harder test-name-degenerate)))
+    (Assert (string= test-name-trivial (try test-name-trivial)))
+    (Assert (string= test-name-trivial (try-harder test-name-trivial)))
+    ;; Note when the `try' form fails, the `try-harder' form returns a
+    ;; shorter name.
+    (Check-Error 'invalid-argument
+		 (string= test-name-short (try test-name-short)))
+    (Assert (string= test-name-trivial (try-harder test-name-short)))
+    (Assert (string= test-name-long (try test-name-long)))
+    (Assert (string= test-name-long (try-harder test-name-long)))
+    ;; Note when the `try' form fails, the `try-harder' form returns a
+    ;; shorter name.
+    (Check-Error 'invalid-argument
+		 (string= test-name-full (try test-name-full)))
+    (Assert (string= test-name-long (try-harder test-name-full)))
+    ) ; labels
+  ) ; let
+
+;;; end face-tests.el