Re: Very preliminary patch for controlling XFT fonts for message display

 Here is a revised version of my changes to mime.tcl to implement
things better and more cleanly. This version of the patch fixes
various problems with my first one:

- it makes a real attempt to determine if an XFT font exists. Normally
  TK 8.5 seems to accept any syntactically valid XFT font name (but you
  may get some default font if the font doesn't actually exist).

  (I have verified that this code appears to work, at least for obvious
  bad fonts.)

- TK 8.5 doesn't accept 'font1,font2,font3 ...' in font names to do an
  XFT font search for the first one found, so we need to support the
  existing space-separated way of having a list of fonts. This is
  especially handy since TK 8.5 doesn't support (in -font) font families
  with spaces in their names, so we don't have to worry about that
  either.

I've also noticed that html_dpackage.tcl also contains a similar
issue; it assumes that it can form font names for the HTML fonts
in XLFD format. I'm still mulling over what the best option
here is because I'm not sure that just creating XFT font names on
the fly is the right answer (although it clearly works for now).

As before, I hope this is useful to someone.

Index: lib/mime.tcl
===================================================================
RCS file: /cvsroot/exmh/exmh/lib/mime.tcl,v
retrieving revision 1.59
diff -u -r1.59 mime.tcl
--- lib/mime.tcl	21 Apr 2011 07:45:22 -0000	1.59
+++ lib/mime.tcl	22 May 2012 16:48:40 -0000
@@ -2137,7 +2137,7 @@
     return $subpart
 }
 proc MimeParseSingle {tkw part fileIO } {
-    global mimeHdr mime miscRE msg
+    global mimeHdr mime miscRE msg mhProfile
 
     set mimeHdr($part=1,color) $mimeHdr($part,color)
     set part $part=1
@@ -2202,7 +2202,10 @@
         #
         set firstLine ""
         while {! [eof $fileIO]} {
-            set firstLinePosition [tell $fileIO]
+            #set firstLinePosition [tell $fileIO]
+	    if {! [info exists mhProfile(exmhshowproc)]} {
+	      set firstLinePosition [tell $fileIO]
+	    }
             gets $fileIO firstLine
             if { ! [regexp {(?n)^\s*$} $firstLine ] } {
               break
@@ -2681,6 +2684,116 @@
     }
 }
 proc Mime_GetFont {w weight slant fontSet size charset} {
+    # should be some kind of one-time flag?
+    if {[catch {::tk::pkgconfig get fontsystem} xft]} {
+	return [Mime_GetFont_XLFD $w $weight $slant $fontSet $size $charset]
+    } else {
+	return [Mime_GetFont_XFT $w $weight $slant $fontSet $size $charset]
+    }
+}
+
+# Setting XFT fonts always succeeds regardless of whether the font exists.
+# If we want to notice invalid fonts, we need to check that the font we got
+# is something like the font we expected and is not the default font.
+# ... except, of course, that sometimes we are asking for the default font,
+# and sometimes fonts have different actual names than the ones we use.
+proc Mime_FontExists_XFT {family points addons} {
+    # Certain fonts always exist, but would probably fail later tests because
+    # their real names are of course not these standard names.
+    if {[lsearch -nocase {monospace serif sans-serif times courier helvetica} $family] != -1} {
+	return 1
+    }
+    set deffamily [font actual "thereisnosuchfont $points $addons" -family]
+    set ourfamily [font actual "$family $points $addons" -family]
+    if {[string compare -nocase $ourfamily $family] != 0 &&
+	[string compare -nocase $ourfamily $deffamily] == 0} {
+	return 0
+    } else {
+	return 1
+    }
+}
+
+proc Mime_GetFont_XFT {w weight slant fontSet size charset} {
+    global mime
+
+    # Insure there is always a default MIME font set so we can skip
+    # duplicating this later.
+	if ![info exists mime(defaultFont)] {
+	    set mime(defaultFont) [option get $w font Font]
+	    if {[string length $mime(defaultFont)] == 0} {
+		set mime(defaultFont) fixed
+	    }
+	}
+
+    # Handle the most common situation, using an XLFD-like pattern to
+    # match things easily. Note that unlike the XLFD case, we match
+    # UTF-8 and Unicode as well since the normal default font can handle
+    # that (well, we assume in the XFT world).
+    if {[string match medium-r-plain-$mime(fontSize)-us-ascii \
+	    $weight-$slant-$fontSet-$size-$charset] || \
+	    [string match medium-r-plain-$mime(fontSize)-utf-8 \
+	    $weight-$slant-$fontSet-$size-$charset] || \
+	    [string match medium-r-plain-$mime(fontSize)-iso-10646-1 \
+	    $weight-$slant-$fontSet-$size-$charset] || \
+	    [string match medium-r-plain-$mime(fontSize)-iso-8859-1 \
+	    $weight-$slant-$fontSet-$size-$charset]} {
+	# Special case the most common situation
+	return $mime(defaultFont)
+    }
+
+    # size is in decipoints, we want it in points. we assume that this
+    # division will always work right.
+    set points [expr {$size / 10}]
+
+    # Determine additional properties of the font, which is one or both of
+    # italic and bold. If we are being asked for medium regular, we
+    # leave this stuff blank.
+    set adds ""
+    if {[string compare $slant i] == 0} {
+	set adds "italic"
+    }
+    if {[string compare $weight bold] == 0} {
+	set adds "$adds bold"
+    }
+
+    # Try to see if the font exists.
+    # Our search order is:
+    # - specific font for the charset in that style
+    # - default font for the style
+    # - global MIME default font, which we assume has all of the characters
+    #   needed these days.
+    # an XFT-enabled app-defaults file should ship with default font
+    # settings of
+    # 	*mime_default_{fixed,plain}_families: monospace
+    #	*mime_default_{title,proportional}_families: sans-serif
+    # ... or something like that.
+    #
+    # We do not attempt to specifically ask XFT for a spacing for various
+    # reasons, including that people want to use proportional and/or fixed
+    # fonts for 'plain text'. This means that the XFT font name we want is
+    # simply (in Tk format):
+    #	$family $points $adds
+    #
+    # See http://www.tcl.tk/man/tcl8.5/TkCmd/font.htm
+    foreach cs [list $charset default] {
+	set i 1
+	while {![catch {set family $mime(family,$cs,$fontSet,$i)} err]} {
+	    # A $family of '*' means that this is a default entry filled
+	    # in dynamically instead of anything the user supplied, so we
+	    # must skip it.
+	    if {[string compare $family "*"] != 0 &&
+		[Mime_FontExists_XFT $family $points $adds]} {
+		return "$family $points $adds"
+	    }
+	    incr i
+	}
+    }
+    # If we cannot find any other font, we return the default MIME font.
+    # We've already insured that it exists above.
+    return $mime(defaultFont)
+}
+
+proc Mime_GetFont_XLFD {w weight slant fontSet size charset} {
     global mime
     # weight = {bold medium}
     # slant = {i r}

	- cks