XftFontDescription.st
author Claus Gittinger <cg@exept.de>
Sun, 27 Apr 2014 23:31:11 +0200
changeset 6393 cca8bffee09b
parent 6392 9f883d05ac3b
child 6394 a0b5daba32fd
permissions -rw-r--r--
*** empty log message ***

"{ Package: 'stx:libview' }"

FontDescription subclass:#XftFontDescription
	instanceVariableNames:'device fontId sharedDrawId closestFont minCode maxCode'
	classVariableNames:'FC_FAMILY FC_STYLE FC_SLANT FC_WEIGHT FC_SIZE FC_ASPECT
		FC_PIXEL_SIZE FC_SPACING FC_FOUNDRY FC_ANTIALIAS FC_HINTING
		FC_HINT_STYLE FC_VERTICAL_LAYOUT FC_AUTOHINT FC_WIDTH FC_FILE
		FC_INDEX FC_FT_FACE FC_RASTERIZER FC_OUTLINE FC_SCALABLE FC_SCALE
		FC_DPI FC_RGBA FC_MINSPACE FC_SOURCE FC_CHARSET FC_LANG
		FC_FONTVERSION FC_FULLNAME FC_FAMILYLANG FC_STYLELANG
		FC_FULLNAMELANG FC_CAPABILITY FC_FONTFORMAT FC_EMBOLDEN
		FC_EMBEDDED_BITMAP FC_DECORATIVE FC_LCD_FILTER FC_NAMELANG
		FC_CHAR_WIDTH FC_CHAR_HEIGHT FC_MATRIX FC_WEIGHT_THIN
		FC_WEIGHT_EXTRALIGHT FC_WEIGHT_ULTRALIGHT FC_WEIGHT_LIGHT
		FC_WEIGHT_BOOK FC_WEIGHT_REGULAR FC_WEIGHT_NORMAL
		FC_WEIGHT_MEDIUM FC_WEIGHT_DEMIBOLD FC_WEIGHT_SEMIBOLD
		FC_WEIGHT_BOLD FC_WEIGHT_EXTRABOLD FC_WEIGHT_ULTRABOLD
		FC_WEIGHT_BLACK FC_WEIGHT_HEAVY FC_WEIGHT_EXTRABLACK
		FC_WEIGHT_ULTRABLACK FC_SLANT_ROMAN FC_SLANT_ITALIC
		FC_SLANT_OBLIQUE FC_WIDTH_ULTRACONDENSED FC_WIDTH_EXTRACONDENSED
		FC_WIDTH_CONDENSED FC_WIDTH_SEMICONDENSED FC_WIDTH_NORMAL
		FC_WIDTH_SEMIEXPANDED FC_WIDTH_EXPANDED FC_WIDTH_EXTRAEXPANDED
		FC_WIDTH_ULTRAEXPANDED FC_PROPORTIONAL FC_DUAL FC_MONO
		FC_CHARCELL FC_RGBA_UNKNOWN FC_RGBA_RGB FC_RGBA_BGR FC_RGBA_VRGB
		FC_RGBA_VBGR FC_RGBA_NONE FC_HINT_NONE FC_HINT_SLIGHT
		FC_HINT_MEDIUM FC_HINT_FULL FC_LCD_NONE FC_LCD_DEFAULT
		FC_LCD_LIGHT FC_LCD_LEGACY StXFace2FCWeightMap
		StXStyle2FCSlantMap CachedFontList RecentlyUsedFonts'
	poolDictionaries:''
	category:'Graphics-Support'
!

Object subclass:#FCFontListParser
	instanceVariableNames:'pipeStream lineStream currentDescription'
	classVariableNames:''
	poolDictionaries:''
	privateIn:XftFontDescription
!

ExternalAddress subclass:#FCPatternHandle
	instanceVariableNames:''
	classVariableNames:''
	poolDictionaries:''
	privateIn:XftFontDescription
!

ExternalAddress subclass:#XftDrawHandle
	instanceVariableNames:''
	classVariableNames:''
	poolDictionaries:''
	privateIn:XftFontDescription
!

ExternalAddress subclass:#XftFontHandle
	instanceVariableNames:''
	classVariableNames:''
	poolDictionaries:''
	privateIn:XftFontDescription
!

!XftFontDescription primitiveDefinitions!
%{
/*
 * includes, defines, structure definitions
 * and typedefs come here.
 */

#undef True
#undef False
#undef Time
#define Time XTime

#ifdef XFT

extern OBJ __GLOBAL_GET_BY_NAME();

# define __HANDLE_VAL(type, externalAddress) \
	((type)__externalAddressVal(externalAddress))
#define __HANDLE_NEW(ptr, __cls)                \
	({                                      \
	    OBJ handle;                         \
	    handle = __MKEXTERNALADDRESS(ptr);  \
	    __InstPtr(handle)->o_class =        \
		__GLOBAL_GET_BY_NAME(__cls);    \
	    handle;                             \
	})



# define DISPLAY(x)    __HANDLE_VAL(Display*, x)
# define SCREEN(x)     ((int)(__intVal(x)))
# define DRAWABLE(x)   __HANDLE_VAL(Drawable, x)
# define GC(x)         __HANDLE_VAL(GC, x)
# define VISUAL(x)     __HANDLE_VAL(Visual*, x)
# define COLORMAP(x)   __HANDLE_VAL(Colormap, x)




/* FontConfig objects */
# define FC_PATTERN(x)                  __HANDLE_VAL(XftPattern*, x)
# define FC_PATTERN_HANDLE_NEW(x)       __HANDLE_NEW(x, "XftFontDescription::FCPatternHandle")

/* Xft Objects */

# define XFT_FONT(x)            __HANDLE_VAL(XftFont*, x)
# define XFT_FONT_HANDLE_NEW(x) __HANDLE_NEW(x, "XftFontDescription::XftFontHandle")

# define XFT_DRAW(x)            __HANDLE_VAL(XftDraw*, x)
# define XFT_DRAW_HANDLE_NEW(x) __HANDLE_NEW(x, "XftFontDescription::XftDrawHandle")


# include <X11/Xft/Xft.h>
# include <X11/Xft/XftCompat.h>

#endif

%}
! !

!XftFontDescription class methodsFor:'documentation'!

documentation
"
    WARNING: Unfinished.

    Experimental implementation of custom font rendered using
    Xft library (UNIX / X Window only), To actually use it,
    add following definitions to the end of stx/configurations/myConf
    (works on Ubuntu 12.10)

    --- snip ---
    XDEFS+=-DXFT
    XINCLUDE+=$(shell pkg-config --cflags xft)
    LIB_XFT=-l:libXft.so.2 -l:libfontconfig.so.1
    --- snip --

    NOTE: This class should be named XftFont, however then
    there would be a name clash with XftFont structure
    defined in Xft.h - therefore the class is named
    XftFontDescription to avoid that name clash.


    [author:]
	Jan Vrany <jan.vrany@fit.cvut.cz>

    [instance variables:]

    [class variables:]

    [see also:]

"
! !

!XftFontDescription class methodsFor:'initialization'!

flushListOfAvailableFonts
    CachedFontList := nil.

    "
     XftFontDescription flushListOfAvailableFonts
    "
!

initialize
    "Invoked at system start or when the class is dynamically loaded."

    " Taken from fontconfig,h "

    FC_FAMILY               := 'family'.           "/* String */
    FC_STYLE                := 'style'.            "/* String */
    FC_SLANT                := 'slant'.            "/* Int */
    FC_WEIGHT               := 'weight'.           "/* Int */
    FC_SIZE                 := 'size'.             "/* Double */
    FC_ASPECT               := 'aspect'.           "/* Double */
    FC_PIXEL_SIZE           := 'pixelsize'.        "/* Double */
    FC_SPACING              := 'spacing'.          "/* Int */
    FC_FOUNDRY              := 'foundry'.          "/* String */
    FC_ANTIALIAS            := 'antialias'.        "/* Bool (depends) */
    FC_HINTING              := 'hinting'.          "/* Bool (true) */
    FC_HINT_STYLE           := 'hintstyle'.        "/* Int */
    FC_VERTICAL_LAYOUT      := 'verticallayout'.       "/* Bool (false) */
    FC_AUTOHINT             := 'autohint'.         "/* Bool (false) */
    FC_WIDTH                := 'width'.            "/* Int */
    FC_FILE                 := 'file'.             "/* String */
    FC_INDEX                := 'index'.            "/* Int */
    FC_FT_FACE              := 'ftface'.           "/* FT_Face */
    FC_RASTERIZER           := 'rasterizer'.       "/* String */
    FC_OUTLINE              := 'outline'.          "/* Bool */
    FC_SCALABLE             := 'scalable'.         "/* Bool */
    FC_SCALE                := 'scale'.            "/* double */
    FC_DPI                  := 'dpi'.              "/* double */
    FC_RGBA                 := 'rgba'.             "/* Int */
    FC_MINSPACE             := 'minspace'.         "/* Bool use minimum line spacing */
    FC_SOURCE               := 'source'.           "/* String (deprecated) */
    FC_CHARSET              := 'charset'.          "/* CharSet */
    FC_LANG                 := 'lang'.             "/* String RFC 3066 langs */
    FC_FONTVERSION          := 'fontversion'.      "/* Int from 'head'.table */
    FC_FULLNAME             := 'fullname'.         "/* String */
    FC_FAMILYLANG           := 'familylang'.       "/* String RFC 3066 langs */
    FC_STYLELANG            := 'stylelang'.        "/* String RFC 3066 langs */
    FC_FULLNAMELANG         := 'fullnamelang'.     "/* String RFC 3066 langs */
    FC_CAPABILITY           := 'capability'.   "/* String */
    FC_FONTFORMAT           := 'fontformat'.       "/* String */
    FC_EMBOLDEN             := 'embolden'.         "/* Bool - true if emboldening needed*/
    FC_EMBEDDED_BITMAP      := 'embeddedbitmap'."/* Bool - true to enable embedded bitmaps */
    FC_DECORATIVE           := 'decorative'.       "/* Bool - true if style is a decorative variant */
    FC_LCD_FILTER           := 'lcdfilter'.        "/* Int */
    FC_NAMELANG             := 'namelang'.         "/* String RFC 3866 langs */


    "Adjust outline rasterizer"
    FC_CHAR_WIDTH           := 'charwidth'."/* Int */
    FC_CHAR_HEIGHT          := 'charheight'."/* Int */
    FC_MATRIX               := 'matrix'.   "/* FcMatrix */

    FC_WEIGHT_THIN          := 0.
    FC_WEIGHT_EXTRALIGHT    := 40.
    FC_WEIGHT_ULTRALIGHT    := FC_WEIGHT_EXTRALIGHT.
    FC_WEIGHT_LIGHT         := 50.
    FC_WEIGHT_BOOK          := 75.
    FC_WEIGHT_REGULAR       := 80.
    FC_WEIGHT_NORMAL        := FC_WEIGHT_REGULAR.
    FC_WEIGHT_MEDIUM        := 100.
    FC_WEIGHT_DEMIBOLD      := 180.
    FC_WEIGHT_SEMIBOLD      := FC_WEIGHT_DEMIBOLD.
    FC_WEIGHT_BOLD          := 200.
    FC_WEIGHT_EXTRABOLD     := 205.
    FC_WEIGHT_ULTRABOLD     := FC_WEIGHT_EXTRABOLD.
    FC_WEIGHT_BLACK         := 210.
    FC_WEIGHT_HEAVY         := FC_WEIGHT_BLACK.
    FC_WEIGHT_EXTRABLACK    := 215.
    FC_WEIGHT_ULTRABLACK    := FC_WEIGHT_EXTRABLACK.

    FC_SLANT_ROMAN          := 0.
    FC_SLANT_ITALIC         := 100.
    FC_SLANT_OBLIQUE        := 110.

    FC_WIDTH_ULTRACONDENSED := 50.
    FC_WIDTH_EXTRACONDENSED := 63.
    FC_WIDTH_CONDENSED      := 75.
    FC_WIDTH_SEMICONDENSED  := 87.
    FC_WIDTH_NORMAL         := 100.
    FC_WIDTH_SEMIEXPANDED   := 113.
    FC_WIDTH_EXPANDED       := 125.
    FC_WIDTH_EXTRAEXPANDED  := 150.
    FC_WIDTH_ULTRAEXPANDED  := 200.

    FC_PROPORTIONAL         := 0.
    FC_DUAL                 := 90.
    FC_MONO                 := 100.
    FC_CHARCELL             := 110.

    "sub-pixel order"
    FC_RGBA_UNKNOWN         := 0.
    FC_RGBA_RGB             := 1.
    FC_RGBA_BGR             := 2.
    FC_RGBA_VRGB            := 3.
    FC_RGBA_VBGR            := 4.
    FC_RGBA_NONE            := 5.

    "hinting style"
    FC_HINT_NONE            := 0.
    FC_HINT_SLIGHT          := 1.
    FC_HINT_MEDIUM          := 2.
    FC_HINT_FULL            := 3.

    "LCD filter"
    FC_LCD_NONE             := 0.
    FC_LCD_DEFAULT          := 1.
    FC_LCD_LIGHT            := 2.
    FC_LCD_LEGACY           := 3.

    StXFace2FCWeightMap := Dictionary withKeysAndValues:{
	'thin'.       FC_WEIGHT_THIN.
	'light'.      FC_WEIGHT_LIGHT.
	'extralight'. FC_WEIGHT_EXTRALIGHT.
	'ultralight'. FC_WEIGHT_ULTRALIGHT.
	'light'.      FC_WEIGHT_LIGHT.
	'book'.       FC_WEIGHT_BOOK.
	'regular'.    FC_WEIGHT_REGULAR.
	'normal'.     FC_WEIGHT_NORMAL.
	'medium'.     FC_WEIGHT_MEDIUM.
	'demibold'.   FC_WEIGHT_DEMIBOLD.
	'semibold'.   FC_WEIGHT_SEMIBOLD.
	'bold'.       FC_WEIGHT_BOLD.
	'extrabold'.  FC_WEIGHT_EXTRABOLD.
	'ultrabold'.  FC_WEIGHT_ULTRABOLD.
	'black'.      FC_WEIGHT_BLACK.
	'heavy'.      FC_WEIGHT_HEAVY.
	'extrablack'. FC_WEIGHT_EXTRABLACK.
	'ultrablack'. FC_WEIGHT_ULTRABLACK.
    }.
    StXStyle2FCSlantMap := Dictionary withKeysAndValues:{
	'roman'.    FC_SLANT_ROMAN.
	'italic'.   FC_SLANT_ITALIC.
	'oblique'.  FC_SLANT_OBLIQUE.
    }.

    "Modified: / 30-12-2013 / 19:48:41 / Jan Vrany <jan.vrany@fit.cvut.cz>"
! !

!XftFontDescription class methodsFor:'instance creation'!

family:familyString face:faceString style:styleString size:size sizeUnit:sizeUnit encoding:encoding
    "returns a font for given family, face, style, size and the specified encoding.
     The returned font is not associated to a specific device"

    |proto|

    CachedFontList notNil ifTrue:[
	proto := CachedFontList
		detect:[:fn |
		    fn family = familyString
		    and:[ fn face = faceString
		    and:[ (fn style = styleString
			  or:[ (fn style = 'oblique' and:[styleString = 'italic'])
			  or:[ (fn style = 'italic' and:[styleString = 'oblique']) ]]) ]]]
		ifNone:nil.
	proto notNil ifTrue:[
	    ^ (proto shallowCopy)
		setDevice: nil patternId: nil fontId: nil;
		family:familyString face:faceString style:styleString size:size sizeUnit:sizeUnit encoding:encoding
	].
    ].
    ^ super
	family:familyString face:faceString style:styleString size:size sizeUnit:sizeUnit encoding:encoding
!

new
"/    self halt.
    ^ super new.
! !

!XftFontDescription class methodsFor:'examples'!

example1
    "
    XftFontDescription example1
    "
    |top textView|

    top := StandardSystemView new.
    top extent:300@200.

    textView := EditTextView new.
    textView origin:0.0 @ 0.0 corner:1.0 @ 1.0.
    textView basicFont: (XftFontDescription family: 'DejaVu Sans' size: 16).

    top addSubView:textView.

    textView contents:('/etc/hosts' asFilename contentsOfEntireFile asText).

    top open.

    "Created: / 20-12-2013 / 00:04:57 / Jan Vrany <jan.vrany@fit.cvut.cz>"
    "Modified: / 30-12-2013 / 19:11:07 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!

example2
    "
    XftFontDescription example2
    "
    |top textView|

    top := StandardSystemView new.
    top extent:300@200.

    textView := EditTextView new.
    textView origin:0.0 @ 0.0 corner:1.0 @ 1.0.
    textView basicFont: (XftFontDescription family: 'DejaVu Sans' size: 30) asItalic.

    top addSubView:textView.

    textView contents:('/etc/hosts' asFilename contentsOfEntireFile).

    top open.

    "Created: / 30-12-2013 / 19:49:05 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!

example3
    "
    XftFontDescription example2
    "
    |top textView|

    top := StandardSystemView new.
    top extent:300@200.

    textView := EditTextView new.
    textView origin:0.0 @ 0.0 corner:1.0 @ 1.0.
    textView basicFont: (XftFontDescription family: 'Indie Flower' size: 30).

    top addSubView:textView.

    textView contents:('/etc/hosts' asFilename contentsOfEntireFile).

    top open.

    "Created: / 30-12-2013 / 19:49:05 / Jan Vrany <jan.vrany@fit.cvut.cz>"
! !

!XftFontDescription class methodsFor:'queries'!

listOfAvailableFonts
    "uses fc-list to get a list of available fontDescriptions"

    CachedFontList isNil ifTrue:[
	CachedFontList := FCFontListParser new listOfAvailableFonts
    ].
    ^ CachedFontList

    "
     XftFontDescription flushListOfAvailableFonts.
     XftFontDescription listOfAvailableFonts
    "
! !

!XftFontDescription methodsFor:'accessing'!

encoding
    ^ encoding ? 'iso10646-1'
!

face
    ^ face ? ''
!

fullName
    ^ name ? (self userFriendlyName)
!

graphicsDevice
    ^ device

    "Created: / 02-01-2014 / 23:22:39 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!

maxCode
    ^ maxCode ? 16rFFFF
!

maxCode:something
    maxCode := something.
!

minCode
    ^ minCode ? 0
!

minCode:something
    minCode := something.
!

size
    ^ size ? 0
!

style
    ^ style ? ''
!

weight:aNumber
    "set the weight"

    self assert:(self fontId isNil). "/ cannot change an instantiated font

    aNumber == FC_WEIGHT_THIN ifTrue:[ face := 'thin'. ^ self].
    aNumber == FC_WEIGHT_EXTRALIGHT ifTrue:[ face := 'extralight'. ^ self].
    aNumber == FC_WEIGHT_LIGHT ifTrue:[ face := 'light'. ^ self].
    aNumber == FC_WEIGHT_BOOK ifTrue:[ face := 'book'. ^ self].
    aNumber == FC_WEIGHT_REGULAR ifTrue:[ face := 'regular'. ^ self].
    aNumber == FC_WEIGHT_MEDIUM ifTrue:[ face := 'medium'. ^ self].
    aNumber == FC_WEIGHT_DEMIBOLD ifTrue:[ face := 'demibold'. ^ self].
    aNumber == FC_WEIGHT_BOLD ifTrue:[ face := 'bold'. ^ self].
    aNumber == FC_WEIGHT_EXTRABOLD ifTrue:[ face := 'extrabold'. ^ self].
    aNumber == FC_WEIGHT_BLACK ifTrue:[ face := 'black'. ^ self].
    aNumber == FC_WEIGHT_EXTRABLACK ifTrue:[ face := 'extrablack'. ^ self].

    aNumber <= (FC_WEIGHT_EXTRALIGHT + FC_WEIGHT_LIGHT // 2) ifTrue:[
	face := 'extralight'.
	^ self.
    ].
    aNumber <= (FC_WEIGHT_LIGHT + FC_WEIGHT_BOOK // 2) ifTrue:[
	face := 'light'.
	^ self.
    ].
    aNumber <= (FC_WEIGHT_MEDIUM + FC_WEIGHT_DEMIBOLD // 2) ifTrue:[
	face := 'medium'.
	^ self.
    ].
    aNumber <= (FC_WEIGHT_DEMIBOLD + FC_WEIGHT_BOLD // 2) ifTrue:[
	face := 'demibold'.
	^ self.
    ].
    aNumber <= (FC_WEIGHT_BOLD + FC_WEIGHT_BLACK // 2) ifTrue:[
	face := 'bold'.
	^ self.
    ].
    face := 'extrabold'.
    ^ self

"/    FC_WEIGHT_THIN          := 0.
"/    FC_WEIGHT_EXTRALIGHT    := 40.
"/    FC_WEIGHT_ULTRALIGHT    := FC_WEIGHT_EXTRALIGHT.
"/    FC_WEIGHT_LIGHT         := 50.
"/    FC_WEIGHT_BOOK          := 75.
"/    FC_WEIGHT_REGULAR       := 80.
"/    FC_WEIGHT_NORMAL        := FC_WEIGHT_REGULAR.
"/    FC_WEIGHT_MEDIUM        := 100.
"/    FC_WEIGHT_DEMIBOLD      := 180.
"/    FC_WEIGHT_SEMIBOLD      := FC_WEIGHT_DEMIBOLD.
"/    FC_WEIGHT_BOLD          := 200.
"/    FC_WEIGHT_EXTRABOLD     := 205.
"/    FC_WEIGHT_ULTRABOLD     := FC_WEIGHT_EXTRABOLD.
"/    FC_WEIGHT_BLACK         := 210.
"/    FC_WEIGHT_HEAVY         := FC_WEIGHT_BLACK.
"/    FC_WEIGHT_EXTRABLACK    := 215.
"/    FC_WEIGHT_ULTRABLACK    := FC_WEIGHT_EXTRABLACK.
! !

!XftFontDescription methodsFor:'accessing-private'!

getFontId
    ^ fontId

    "Created: / 02-01-2014 / 23:29:04 / Jan Vrany <jan.vrany@fit.cvut.cz>"
! !

!XftFontDescription methodsFor:'displaying'!

displayString:aString from:index1 to:index2Arg x:xArg y:yArg in:aGC opaque:opaque
    "display a partial string at some position in aGC."

    |index2 bytesPerCharacter transformation clipR clipX clipY clipW clipH fg fgR fgG fgB fgA fgPixel bg bgR bgG bgB bgA bgPixel drawX drawY displayId screen drawableId error  stringLen|

    "limit the string len, otherwise bad output is generated"
    stringLen := index2Arg - index1.
    stringLen > 8000 ifTrue:[
	index2 := index2Arg - (stringLen - 8000).
    ]  ifFalse:[
	index2 := index2Arg.
    ].
    bytesPerCharacter := aString bitsPerCharacter // 8.
    transformation := aGC transformation.

    clipR := aGC clippingBoundsOrNil.
    clipR notNil ifTrue:[
	clipX := clipR left.
	clipY := clipR top.
	clipW := clipR width.
	clipH := clipR height.
    ].

    transformation isNil ifTrue:[
	drawX := xArg.
	drawY := yArg.
    ] ifFalse:[
	drawX := transformation applyToX:xArg.
	drawY := transformation applyToY:yArg.
	clipR notNil ifTrue:[
	    clipX := transformation applyToX:clipX.
	    clipY := transformation applyToY:clipY.
	    clipW := transformation applyScaleX:clipW.
	    clipH := transformation applyScaleY:clipH.
	].
    ].

    fg  :=  aGC paint.
    fgPixel := fg colorId.
    "/ fgPixel notNil ifTrue:[
	fgR := fg scaledRed.
	fgG := fg scaledGreen.
	fgB := fg scaledBlue.
	fgA := (fg alpha * 65535) rounded.
    "/].
    fgR isNil ifTrue:[
	"/ when drawing into a pixmap...
	fg colorId == 0 ifTrue:[
	    fgR := fgG := fgB := 0.
	] ifFalse:[
	    fgR := fgG := fgB := 16rFFFF.
	]
    ].

    opaque ifTrue:[
	bg  := aGC backgroundPaint.
	bgPixel := bg colorId.
	"/bgPixel notNil ifTrue:[
	    bgR := bg scaledRed.
	    bgG := bg scaledGreen.
	    bgB := bg scaledBlue.
	    bgA := (bg alpha * 65535) rounded.
	"/].
	bgR isNil ifTrue:[
	    "/ when drawing into a pixmap...
	    bg colorId == 0 ifTrue:[
		bgR := bgG := bgB := 0.
	    ] ifFalse:[
		bgR := bgG := bgB := 16rFFFF.
	    ]
	].
    ].
    displayId := device displayIdOrErrorIfBroken.
    displayId isNil ifTrue:[
	^ self.
    ].
    screen := device screen.
    drawableId := aGC drawableId.

%{
#ifdef XFT
    XftFont *font;
    XftDraw *draw;
    XftColor color;
    XGlyphInfo extents;
    XRectangle clipRX;
    char* string;
    int len;
    int __bytesPerCharacter;

    if (!(__bothSmallInteger(drawX, drawY)
	  && __bothSmallInteger(index1, index2)
	  && __isSmallInteger(bytesPerCharacter)
	  && (__isSmallInteger(fgPixel) || (__bothSmallInteger(fgR, fgG) && __bothSmallInteger(fgB, fgA)))
	  && (opaque == false || __isSmallInteger(bgPixel) || (__bothSmallInteger(bgR, bgG) && __bothSmallInteger(bgB, bgA)))
	  && __isNonNilObject(aString)
    )) {
	goto err;
    }

    __bytesPerCharacter = __intVal(bytesPerCharacter);

    if ( __INST(sharedDrawId) == nil ) {
	__INST(sharedDrawId) = XFT_DRAW_HANDLE_NEW ( XftDrawCreate ( DISPLAY( displayId ) ,
					       DRAWABLE( drawableId ) ,
					       DefaultVisual( DISPLAY( displayId), SCREEN (screen) ) ,
					       DefaultColormap( DISPLAY( displayId), SCREEN (screen) ) ) );
	__STORE(self, __INST(sharedDrawId));
    }

    if ( XftDrawDrawable ( XFT_DRAW ( __INST(sharedDrawId) ) ) != DRAWABLE( drawableId ) ) {
	XftDrawChange( XFT_DRAW( __INST(sharedDrawId) ) , DRAWABLE( drawableId ) );
    }

    string = __stringVal( aString ) + (( __intVal(index1) - 1 ) * __bytesPerCharacter);
    len = __intVal(index2) - __intVal(index1) + 1;

    if (clipR != nil) {
	clipRX.x = __intVal(clipX);
	clipRX.y = __intVal(clipY);
	clipRX.width = __intVal(clipW);
	clipRX.height = __intVal(clipH);
	XftDrawSetClipRectangles( XFT_DRAW( __INST( sharedDrawId ) ) , 0, 0, &clipRX, 1);
    } else {
	XftDrawSetClip( XFT_DRAW( __INST( sharedDrawId ) ) , 0);
    }

    if (opaque == true) {
	if (bgPixel != nil) {
	    color.pixel = (unsigned long)__intVal(bgPixel);
	}
	// else {
	    color.color.red = __intVal(bgR);
	    color.color.green = __intVal(bgG);
	    color.color.blue = __intVal(bgB);
	    color.color.alpha = __intVal(bgA);
	// }
	switch (__bytesPerCharacter) {
	case 1:
	    XftTextExtents8( DISPLAY( displayId ), XFT_FONT( __INST( fontId ) ), (FcChar8*)string, len, &extents);
	    break;
	case 2:
	    XftTextExtents16( DISPLAY( displayId ), XFT_FONT( __INST( fontId ) ), (FcChar16*)string, len, &extents);
	    break;
	case 4:
	    XftTextExtents32( DISPLAY( displayId ), XFT_FONT( __INST( fontId ) ), (FcChar32*)string, len, &extents);
	    break;
	}
	XftDrawRect( XFT_DRAW ( __INST( sharedDrawId ) ), &color, __intVal(drawX) - extents.x, __intVal(drawY) - XFT_FONT( __INST( fontId ) )->ascent, extents.width, XFT_FONT(__INST (fontId ) )->height);
    }
    if (fgPixel != nil) {
	color.pixel = (unsigned long)__intVal(fgPixel);
    }
    // else {
	color.color.red = __intVal(fgR);
	color.color.green = __intVal(fgG);
	color.color.blue = __intVal(fgB);
	color.color.alpha = __intVal(fgA);
    // }
    switch (__bytesPerCharacter) {
    case 1:
	XftDrawString8( XFT_DRAW ( __INST( sharedDrawId ) ), &color, XFT_FONT( __INST( fontId ) ),
			__intVal(drawX),
			__intVal(drawY),
			(FcChar8*)string,
			len);
	RETURN ( self );
	break;
    case 2:
	XftDrawString16( XFT_DRAW ( __INST( sharedDrawId ) ), &color, XFT_FONT( __INST( fontId ) ),
			__intVal(drawX),
			__intVal(drawY),
			(FcChar16*)string,
			len);
	RETURN ( self );
	break;
    case 4:
	XftDrawString32( XFT_DRAW ( __INST( sharedDrawId ) ), &color, XFT_FONT( __INST( fontId ) ),
			__intVal(drawX),
			__intVal(drawY),
			(FcChar32*)string,
			len);
	RETURN ( self );
	break;
    }
    err:;
#endif
%}.
    self primitiveFailed: error.

    "Created: / 21-12-2013 / 21:11:07 / Jan Vrany <jan.vrany@fit.cvut.cz>"
    "Modified: / 10-01-2014 / 11:13:56 / Jan Vrany <jan.vrany@fit.cvut.cz>"
! !

!XftFontDescription methodsFor:'error reporting'!

primitiveFailed
    <resource: #skipInDebuggersWalkBack>
%{
#ifndef XFT
%}.
    super primitiveFailed:'Xft support is not configured'.
%{
#endif
%}.
    super primitiveFailed
!

primitiveFailed:errorString
    <resource: #skipInDebuggersWalkBack>
%{
#ifndef XFT
%}.
    super primitiveFailed:'Xft support is not configured'.
%{
#endif
%}.
    super primitiveFailed:errorString
! !

!XftFontDescription methodsFor:'getting a device font'!

onDevice:aGraphicsDevice
    "Create a new XftFont representing the closes font as
     myself on aDevice; if one already exists, return the one."

    | myPatternId closestPatternId1 closestPatternId2 newFontId |

    "if I am already assigned to that device ..."
    (device == aGraphicsDevice) ifTrue:[^ self].

    (aGraphicsDevice isNil and:[device notNil]) ifTrue:[
	^ self
    ].

    (closestFont notNil and:[closestFont graphicsDevice == aGraphicsDevice]) ifTrue:[
	^ closestFont onDevice: aGraphicsDevice.
    ].

    RecentlyUsedFonts isNil ifTrue:[
	RecentlyUsedFonts := OrderedCollection new:10.
    ].

    RecentlyUsedFonts keysAndValuesDo:[:index :aFont |
	((aFont class == self class) and:[self sameDeviceFontAs:aFont]) ifTrue:[
	    "/ Transcript showCR:'hit'.
	    RecentlyUsedFonts removeIndex:index.
	    RecentlyUsedFonts addFirst:aFont.
	    ^ aFont
	]
    ].

    RecentlyUsedFonts size > 20 ifTrue:[
	RecentlyUsedFonts removeLast.
    ].

    aGraphicsDevice deviceFonts do:[:aFont |
	((aFont class == self class) and:[self sameDeviceFontAs:aFont]) ifTrue:[
	    RecentlyUsedFonts addFirst:aFont.
	    ^ aFont
	].
    ].

    [
	myPatternId := self xftPatternCreate.
	self xftPatternAdd: myPatternId attribute: FC_FAMILY  value: family.
	pixelSize notNil ifTrue:[
	    self xftPatternAdd: myPatternId attribute: FC_PIXEL_SIZE value: pixelSize.
	] ifFalse:[
	    self xftPatternAdd: myPatternId attribute: FC_SIZE value: size.
	].
	self xftPatternAdd: myPatternId attribute: FC_WEIGHT value: (StXFace2FCWeightMap at: (face ? 'regular')).
	self xftPatternAdd: myPatternId attribute: FC_SLANT value: (StXStyle2FCSlantMap at: (style ? 'roman') ifAbsent:[StXStyle2FCSlantMap at: (style ? 'roman') asLowercase]).

	newFontId := self xftFontOpenPattern: aGraphicsDevice displayId pattern: myPatternId.
	newFontId notNil ifTrue:[
	    "/ Good, this font exists!!
	    fontId := newFontId.
	    device := aGraphicsDevice.
	    aGraphicsDevice registerFont:self.
	    RecentlyUsedFonts addFirst:self.
	    ^ self.
	] ifFalse:[
	    closestPatternId1 := self xftFontMatch: aGraphicsDevice displayId screen: aGraphicsDevice screen pattern: myPatternId.
	    closestPatternId1 isNil ifTrue:[
		self error: 'No font matches'.
	    ].
	    "
	    self xftPatternGet: closestPatternId attribute: 'family' index: 0.
	    self xftPatternGet: closestPatternId attribute: 'size' index: 0.
	    "
	    closestPatternId2 := self xftPatternDuplicate: closestPatternId1.
	    newFontId := self xftFontOpenPattern: aGraphicsDevice displayId pattern: closestPatternId1.
	    "/ !!!!!!!! closestPatternId is no longer valid !!!!!!!!
	    closestPatternId1 :=  nil.
	    newFontId isNil ifTrue:[
		self error: 'Pattern matched, but font could not be opened (should not happen)'.
	    ].

	    "/ Search for existing registered font. Note, that XftFont instances
	    "/ are shared (and refcounted) so newFontId = aFont getFontId is enough
	    "/ to check whether some other font instance represents the same font...
	    aGraphicsDevice deviceFonts do:[:aFont |
		((self class == aFont class) and:[newFontId = aFont getFontId]) ifTrue:[
		    closestFont := aFont.
		    ^ closestFont
		].
	    ].

	    closestFont := self shallowCopy
				setDevice: aGraphicsDevice patternId: closestPatternId2 fontId: newFontId;
				yourself.
	    aGraphicsDevice registerFont: closestFont.
	    RecentlyUsedFonts addFirst:closestFont.
	    ^ closestFont
	].
    ] ensure:[
	myPatternId notNil ifTrue:[self xftPatternDestroy: myPatternId].
	closestPatternId1 notNil ifTrue:[self xftPatternDestroy: closestPatternId1].
	closestPatternId2 notNil ifTrue:[self xftPatternDestroy: closestPatternId2].
    ].

    "
     (XftFontDescription family:'monospace' size:16) onDevice:Screen current
    "

    "Modified: / 14-04-1997 / 18:22:31 / cg"
    "Modified: / 02-01-2014 / 23:43:27 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!

onDevice:aWorkstation ifAbsent:aBlock
    "Create a new XftFont representing the same font as
     myself on aWorkstation. This does NOT try to look for existing
     or replacement fonts (i.e. can be used to get physical fonts)."

    "/ Apparently, this is not needed.
    self shouldImplement

    "Modified: / 02-01-2014 / 23:15:27 / Jan Vrany <jan.vrany@fit.cvut.cz>"
    "Modified (comment): / 04-01-2014 / 02:06:22 / Jan Vrany <jan.vrany@fit.cvut.cz>"
! !

!XftFontDescription methodsFor:'initialization'!

setDevice: deviceArg patternId: patternIdArg fontId: fontIdArg
    device := deviceArg.
    fontId := fontIdArg.
    patternIdArg notNil ifTrue:[
	family  := self xftPatternGet: patternIdArg attribute: FC_FAMILY index: 0.
	size    := self xftPatternGet: patternIdArg attribute: FC_SIZE index: 0.
	face    := self xftPatternGet: patternIdArg attribute: FC_WEIGHT index: 0.
	face    := StXFace2FCWeightMap keyAtValue: face.
	style   := self xftPatternGet: patternIdArg attribute: FC_SLANT index: 0.
	style   := StXStyle2FCSlantMap keyAtValue: style.

	name:= self xftPatternGet: patternIdArg attribute: 'fullname' index: 0.

	encoding:= self xftPatternGet: patternIdArg attribute: 'encoding' index: 0.
    ].

    "Created: / 21-12-2013 / 00:46:10 / Jan Vrany <jan.vrany@fit.cvut.cz>"
    "Modified: / 30-12-2013 / 12:49:58 / Jan Vrany <jan.vrany@fit.cvut.cz>"
! !

!XftFontDescription methodsFor:'primitives'!

xftAvailable
%{
#ifdef XFT
    RETURN ( true )
#endif
%}.
    ^ false

    "Created: / 20-12-2013 / 21:10:25 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!

xftDrawChange: xftDrawId drawable: drawableId
    | error |

%{
#ifdef XFT
    if ( ! __isExternalAddressLike(xftDrawId) ) {
	error = @symbol(BadArg1);
	goto err;
    }
    if ( ! __isExternalAddressLike(drawableId) ) {
	error = @symbol(BadArg2);
	goto err;
    }
    if (XftDrawDrawable( XFT_DRAW(xftDrawId) ) != DRAWABLE( drawableId ) ) {
	XftDrawChange( XFT_DRAW(xftDrawId) , DRAWABLE( drawableId ) );
    }
    RETURN ( self );
    err:;
#endif
%}.
    self primitiveFailed: error

    "Created: / 26-12-2013 / 12:17:36 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!

xftDrawCreate: displayId screen: screen drawable: drawableId
    | error |

%{
#ifdef XFT
    if ( ! __isExternalAddressLike(displayId) ) {
	error = @symbol(BadArg1);
	goto err;
    }
    if ( ! __isSmallInteger(screen) ) {
	error = @symbol(BadArg2);
	goto err;
    }
    if ( ! __isExternalAddressLike(drawableId) ) {
	error = @symbol(BadArg3);
	goto err;
    }
    RETURN ( XFT_DRAW_HANDLE_NEW (  XftDrawCreate ( DISPLAY( displayId ) ,
						   DRAWABLE( drawableId ) ,
						   DefaultVisual( DISPLAY( displayId), SCREEN (screen) ) ,
						   DefaultColormap( DISPLAY( displayId), SCREEN (screen) ) ) ) );
    err:;
#endif
%}.
    self primitiveFailed: error

    "Created: / 21-12-2013 / 21:12:47 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!

xftDrawRect: drawIdArg color: aColor x: x y: y width: w height: h
    | error r g b a pix |

    aColor isColor ifFalse:[^self primitiveFailed: #BadArg2].

    r := aColor scaledRed.
    g := aColor scaledGreen.
    b := aColor scaledBlue.
    a := aColor alpha * 65535.
    r isNil ifTrue:[
	"/ when drawing into a pixmap...
	aColor colorId == 0 ifTrue:[
	    r := g := b := 0.
	] ifFalse:[
	    r := g := b := 16rFFFF.
	]
    ].
    pix := aColor colorId.
%{
#ifdef XFT
    XftColor clr;
    if ( ! __isExternalAddressLike(drawIdArg) ) {
	error = @symbol(BadArg1);
	goto err;
    }
    if ( ! __isSmallInteger(pix) ) {
	error = @symbol(BadColorId);
	goto err;
    }
    if ( ! __isSmallInteger(x) ) {
	error = @symbol(BadArg3);
	goto err;
    }
    if ( ! __isSmallInteger(y) ) {
	error = @symbol(BadArg4);
	goto err;
    }
    if ( ! __isSmallInteger(w) ) {
	error = @symbol(BadArg5);
	goto err;
    }
    if ( ! __isSmallInteger(h) ) {
	error = @symbol(BadArg6);
	goto err;
    }
    clr.pixel = (unsigned long)__intVal(pix);
    clr.color.red = __intVal(r);
    clr.color.green = __intVal(g);
    clr.color.blue = __intVal(b);
    clr.color.alpha = __intVal(a);

    XftDrawRect(XFT_DRAW(drawIdArg), &clr,
			__intVal(x), __intVal(y), __intVal(w) ,__intVal(h));

    RETURN ( self );
    err:;
#endif
%}.
    self primitiveFailed: error.

    "Created: / 28-12-2013 / 23:35:42 / Jan Vrany <jan.vrany@fit.cvut.cz>"
    "Modified: / 31-12-2013 / 00:37:41 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!

xftDrawSetClip: drawIdArg rectangle: rect
    | error xObj yObj wObj hObj  |

    rect notNil ifTrue:[
	xObj := rect left.
	yObj := rect top.
	wObj := rect width.
	hObj := rect height.
    ].
%{
#ifdef XFT
    XRectangle r;
    if ( ! __isExternalAddressLike(drawIdArg) ) {
	error = @symbol(BadArg1);
	goto err;
    }
    if (rect != nil) {
	r.x = __intVal(xObj);
	r.y = __intVal(yObj);
	r.width = __intVal(wObj);
	r.height = __intVal(hObj);
	XftDrawSetClipRectangles( XFT_DRAW(drawIdArg) , 0, 0, &r, 1);
    } else {
	XftDrawSetClipRectangles( XFT_DRAW(drawIdArg) , 0, 0, (XRectangle*)NULL, 0);
    }
    RETURN ( self );
    err:;
#endif
%}.
    self primitiveFailed: error.

    "Created: / 31-12-2013 / 01:24:39 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!

xftDrawString: drawIdArg color: aColor font: fontIdArg x: x y: y string: text from: start to: stop
    | error r g b a pix |

    aColor isColor ifFalse:[^self primitiveFailed: #BadArg2].

    r := aColor scaledRed.
    g := aColor scaledGreen.
    b := aColor scaledBlue.
    a := aColor alpha * 65535.
    r isNil ifTrue:[
	"/ when drawing into a pixmap...
	aColor colorId == 0 ifTrue:[
	    r := g := b := 0.
	] ifFalse:[
	    r := g := b := 16rFFFF.
	]
    ].
    pix := aColor colorId.
%{
#ifdef XFT
    int _start, _stop;
    int _x, _y;
    XftColor clr;
    if ( ! __isExternalAddressLike(drawIdArg) ) {
	error = @symbol(BadArg1);
	goto err;
    }
    if ( ! __isSmallInteger(pix) ) {
	error = @symbol(BadColorId);
	goto err;
    }
    if ( ! __isSmallInteger(x) ) {
	error = @symbol(BadArg4);
	goto err;
    }
    _x = __intVal(x);
    if ( ! __isSmallInteger(y) ) {
	error = @symbol(BadArg5);
	goto err;
    }
    _y = __intVal(y);


    if ( ! __isSmallInteger(start) ) {
	error = @symbol(BadArg6);
	goto err;
    }
    _start = __intVal(start);
    if ( ! __isSmallInteger(stop) ) {
	error = @symbol(BadArg7);
	goto err;
    }
    _stop = __intVal(stop);

    clr.pixel = (unsigned long)__intVal(pix);
    clr.color.red = __intVal(r);
    clr.color.green = __intVal(g);
    clr.color.blue = __intVal(b);
    clr.color.alpha = __intVal(a);

    if ( __isStringLike(text) ) {
	XftDrawString8(XFT_DRAW(drawIdArg), &clr, XFT_FONT(fontIdArg),
			_x, _y,
			__stringVal(text) + (_start - 1), _stop - _start + 1);
	RETURN ( self );
    } else {
	error = @symbol(BadArg5);
	goto err;
    }
    err:;
#endif
%}.
    self primitiveFailed: error.

    "Created: / 28-12-2013 / 12:32:18 / Jan Vrany <jan.vrany@fit.cvut.cz>"
    "Modified: / 30-12-2013 / 20:00:49 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!

xftFontGetAscent: fontIdArg
    | error |

%{
#ifdef XFT
    int v;
    if ( ! __isExternalAddressLike(fontIdArg) ) {
	error = @symbol(BadArg1);
	goto err;
    }
    v = XFT_FONT(fontIdArg)->ascent;
    RETURN ( __MKINT( v ) );
    err:;
#endif
%}.
    self primitiveFailed: error

    "Created: / 21-12-2013 / 00:56:13 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!

xftFontGetDescent:fontIdArg
    | error |

%{
#ifdef XFT
    int v;
    if ( ! __isExternalAddressLike(fontIdArg) ) {
	error = @symbol(BadArg1);
	goto err;
    }
    v = XFT_FONT(fontIdArg)->descent;
    RETURN ( __MKINT( v ) );
    err:;
#endif
%}.
    self primitiveFailed: error

    "Created: / 21-12-2013 / 00:56:23 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!

xftFontGetHeight: fontIdArg
    | error |

%{
#ifdef XFT
    int v;
    if ( ! __isExternalAddressLike(fontIdArg) ) {
	error = @symbol(BadArg1);
	goto err;
    }
    v = XFT_FONT(fontIdArg)->height;
    RETURN ( __MKINT( v ) );
    err:;
#endif
%}.
    self primitiveFailed: error

    "Created: / 21-12-2013 / 00:56:32 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!

xftFontGetMaxAdvanceWidth: fontIdArg
    | error |

%{
#ifdef XFT
    int v;
    if ( ! __isExternalAddressLike(fontIdArg) ) {
	error = @symbol(BadArg1);
	goto err;
    }
    v = XFT_FONT(fontIdArg)->max_advance_width;
    RETURN ( __MKINT( v ) );
    err:;
#endif
%}.
    self primitiveFailed: error

    "Created: / 30-12-2013 / 20:02:20 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!

xftFontGetPattern: fontIdArg
    | error |

%{
#ifdef XFT
    XftPattern* p;
    if ( ! __isExternalAddressLike(fontIdArg) ) {
	error = @symbol(BadArg1);
	goto err;
    }
    p = XFT_FONT(fontIdArg)->pattern;
    if (p == NULL) {
	RETURN ( nil );
    } else {
	RETURN ( FC_PATTERN_HANDLE_NEW ( p ) );
    }
    err:;
#endif
%}.
    self primitiveFailed: error

    "Created: / 21-12-2013 / 00:55:11 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!

xftFontMatch: displayId screen: screen pattern: patternId
    | error |

%{
#ifdef XFT
    XftPattern* p;
    XftResult r;

    if ( ! __isExternalAddressLike(displayId) ) {
	error = @symbol(BadArg1);
	goto err;
    }
    if ( ! __isSmallInteger( screen ) ) {
	error = @symbol(BadArg2);
	goto err;
    }
    if ( ! __isExternalAddressLike(patternId) ) {
	error = @symbol(BadArg3);
	goto err;
    }

    XftConfigSubstitute(FC_PATTERN( patternId ));
    XftDefaultSubstitute(DISPLAY(displayId) , SCREEN( screen ), FC_PATTERN( patternId ));
    p = XftFontMatch( DISPLAY(displayId) , SCREEN( screen ), FC_PATTERN( patternId ), &r );
    if (p) {
	RETURN ( FC_PATTERN_HANDLE_NEW ( p ) );
    } else {
	error = @symbol(XftFontMatchReturnedNull);
    }
    err:;
#endif
%}.
    self primitiveFailed: error

    "Created: / 21-12-2013 / 00:08:48 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!

xftFontOpenPattern: displayId pattern: patternId
    | error |

%{
#ifdef XFT
    XftFont* f;
    if ( ! __isExternalAddressLike(displayId) ) {
	error = @symbol(BadArg1);
	goto err;
    }
    if ( ! __isExternalAddressLike(patternId) ) {
	error = @symbol(BadArg2);
	goto err;
    }

    f = XftFontOpenPattern( DISPLAY(displayId) , FC_PATTERN( patternId ) );
    if (f == NULL) {
	RETURN ( nil );
    } else {
	RETURN ( XFT_FONT_HANDLE_NEW ( f ) );
    }
    err:;
#endif
%}.
    self primitiveFailed: error

    "Created: / 20-12-2013 / 23:53:59 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!

xftPatternAdd: pattern attribute: attribute value: value
    "Add a value to the specified pattern element after existing values"

    ^ self xftPatternAdd: pattern attribute: attribute value: value append: true.

    "Created: / 20-12-2013 / 23:43:31 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!

xftPatternAdd: pattern attribute: attribute value: value append: append
    "Add a value to the specified pattern element.  If 'append' is true, the value
     is added after existing values, otherwise it is added before them."

    | error |

%{
#ifdef XFT
    XftValue v;
    Bool b;

    if ( ! __isExternalAddressLike ( pattern ) ) {
	error = @symbol(BadArg1);
	goto err;
    }
    if ( ! __isStringLike ( attribute ) ) {
	error = @symbol(BadArg2);
	goto err;
    }
    if ( append != true && append != false ) {
	error = @symbol(BadArg4);
	goto err;
    }
    if ( __isStringLike ( value ) ) {
	v.type = FcTypeString;
	/* Passing pointer inside Smalltalk should be safe,
	 * Xft/FontConfig libraries seem to allocate and store
	 * a __copy__ of the string (if I understood the code correctly)
	 */
	v.u.s = __stringVal( value);
    } else if ( __isSmallInteger( value ) ) {
	v.type = XftTypeInteger;
	v.u.i = (int)__intVal( value );
    } else if ( value == true || value == false ) {
	v.type = XftTypeBool;
	v.u.b = value == true ? True : False;
    } else if ( __isFloat ( value ) ) {
	v.type = XftTypeDouble;
	v.u.d = __floatVal( value );
    } else if ( value == nil ) {
	v.type = XftTypeVoid;
	v.u.f = NULL;
    } else {
	error = @symbol(BadArg3);
	goto err;
    }
    b = XftPatternAdd( FC_PATTERN(pattern), __stringVal(attribute), v, append == true ? True : False );
    RETURN ( b == True ? true : false );

    err:;
#endif
%}.
    self primitiveFailed: error

    "Created: / 20-12-2013 / 21:50:00 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!

xftPatternCreate
%{
#ifdef XFT
    RETURN ( FC_PATTERN_HANDLE_NEW ( XftPatternCreate() ) );
#endif
%}.
    self primitiveFailed.

    "Created: / 20-12-2013 / 21:19:00 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!

xftPatternDel: pattern attribute: attribute
    | error |
%{
#ifdef XFT
    if ( ! __isExternalAddressLike ( pattern ) ) {
	error = @symbol(BadArg1);
	goto err;
    }
    if ( ! __isStringLike ( attribute ) ) {
	error = @symbol(BadArg2);
	goto err;
    }
    XftPatternDel( FC_PATTERN(pattern), __stringVal ( attribute ) );
    RETURN ( self );

    err:;
#endif
%}.
    self primitiveFailed: error

    "Created: / 20-12-2013 / 21:33:47 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!

xftPatternDestroy: addr
    | error |

    addr isNil ifTrue:[ ^ self ].

%{
#ifdef XFT
    if ( ! __isExternalAddressLike(addr) ) {
	error = @symbol(BadArg1);
	goto err;
    }
    XftPatternDestroy( FC_PATTERN(addr) );
    RETURN ( self );

    err:;
#endif
%}.
    self primitiveFailed: error

    "Created: / 20-12-2013 / 21:33:47 / Jan Vrany <jan.vrany@fit.cvut.cz>"
    "Modified: / 20-12-2013 / 23:48:45 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!

xftPatternDuplicate: addr
    | error |

    addr isNil ifTrue:[ ^ self ].

%{
#ifdef XFT
    if ( ! __isExternalAddressLike(addr) ) {
	error = @symbol(BadArg1);
	goto err;
    }
    RETURN ( FC_PATTERN_HANDLE_NEW ( XftPatternDuplicate( FC_PATTERN(addr) ) ) );
    err:;
#endif
%}.
    self primitiveFailed: error

    "Created: / 21-12-2013 / 01:14:03 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!

xftPatternGet: pattern attribute: attribute index: index
    "Return a value from the specified element -- multiple values can be indexed
     with 'index' starting at zero."

    | error |

%{
#ifdef XFT
    XftValue v;
    XftResult r;

    if ( ! __isExternalAddressLike ( pattern ) ) {
	error = @symbol(BadArg1);
	goto err;
    }
    if ( ! __isStringLike ( attribute ) ) {
	error = @symbol(BadArg2);
	goto err;
    }
    if ( ! __isSmallInteger( index ) ) {
	error = @symbol(BadArg3);
	goto err;
    }
    r = XftPatternGet(FC_PATTERN(pattern), __stringVal( attribute ), __intVal( index ), &v);
    if ( r != XftResultMatch) {
	RETURN ( nil );
    }
    if ( v.type == XftTypeString) {
	RETURN ( __MKSTRING(v.u.s) );
    } else if ( v.type == XftTypeInteger ) {
	RETURN ( __MKINT (v.u.i) );
    } else if ( v.type == XftTypeBool ) {
	RETURN ( v.u.b == True ? true : false );
    } else if ( v.type == XftTypeDouble ) {
	RETURN ( __MKFLOAT (v.u.d) );
    } else if ( v.type == XftTypeVoid ) {
	RETURN ( nil );
    } else {
	error = @symbol(UnssuportedTypeValue);
	goto err;
    }
    err:;
#endif
%}.
    self primitiveFailed: error

    "Created: / 20-12-2013 / 21:50:44 / Jan Vrany <jan.vrany@fit.cvut.cz>"
    "Modified: / 21-12-2013 / 01:06:25 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!

xftTextExtents: displayIdArg font: fontIdArg string: text from: start to: stop
    | error extents bitsPerCharacter |

    extents :=  Array new: 6.
    bitsPerCharacter := text bitsPerCharacter.
%{
#ifdef XFT
    XGlyphInfo info;
    int bytesPerCharacter;
    char *string;
    int len;

    bytesPerCharacter = __intVal(bitsPerCharacter) / 8;

    if ( ! __isExternalAddressLike(displayIdArg) ) {
	error = @symbol(BadArg1);
	goto err;
    }
    if ( ! __isExternalAddressLike(fontIdArg) ) {
	error = @symbol(BadArg2);
	goto err;
    }
    if ( ! __isSmallInteger(start) ) {
	error = @symbol(BadArg4);
	goto err;
    }
    if ( ! __isSmallInteger(stop) ) {
	error = @symbol(BadArg5);
	goto err;
    }

    string = __stringVal( text ) + (( __intVal(start) - 1 ) * bytesPerCharacter);
    len = __intVal(stop) - __intVal(start) + 1;


    switch (bytesPerCharacter) {
    case 1:
	XftTextExtents8(DISPLAY(displayIdArg), XFT_FONT(fontIdArg), (FcChar8*)string, len, &info);
	break;
    case 2:
	XftTextExtents16(DISPLAY(displayIdArg), XFT_FONT(fontIdArg), (FcChar16*)string, len, &info);
	break;
    case 4:
	XftTextExtents32(DISPLAY(displayIdArg), XFT_FONT(fontIdArg), (FcChar32*)string, len, &info);
	break;
    }
    __ArrayInstPtr(extents)->a_element[0] = __MKSMALLINT(info.width);
    __ArrayInstPtr(extents)->a_element[1] = __MKSMALLINT(info.height);
    __ArrayInstPtr(extents)->a_element[2] = __MKSMALLINT(info.x);
    __ArrayInstPtr(extents)->a_element[3] = __MKSMALLINT(info.y);
    __ArrayInstPtr(extents)->a_element[4] = __MKSMALLINT(info.xOff);
    __ArrayInstPtr(extents)->a_element[5] = __MKSMALLINT(info.yOff);
    error = nil;
    err:;
#endif
%}.
    error notNil ifTrue:[
	self primitiveFailed: error.
	^ nil.
    ].
    ^ extents

    "Created: / 21-12-2013 / 10:42:15 / Jan Vrany <jan.vrany@fit.cvut.cz>"
    "Modified: / 30-12-2013 / 20:00:30 / Jan Vrany <jan.vrany@fit.cvut.cz>"
! !

!XftFontDescription methodsFor:'printing & storing'!

storeOn:aStream
    "append a character sequence to the argument, aStream from which the
     receiver can be reconstructed using readFrom:."

    aStream nextPutAll:'(XftFontDescription family:'. family storeOn:aStream.
    aStream nextPutAll:' face:'.        face storeOn:aStream.
    aStream nextPutAll:' style:'.       style storeOn:aStream.
    aStream nextPutAll:' size:'.        size storeOn:aStream.
    aStream nextPutAll:' encoding:'.    encoding storeOn:aStream.
    aStream nextPut:$)

    "
     (XftFontDescription family: 'DejaVu Sans' size: 8) storeString
    "
! !

!XftFontDescription methodsFor:'queries-dimensions'!

ascent
    "return the ascent - the number of pixels above the baseLine."

    ^ self xftFontGetAscent: fontId

    "Created: / 21-12-2013 / 01:19:46 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!

descent
    "return the descent - the number of pixels below the baseLine."

    ^ self xftFontGetDescent: fontId

    "Created: / 21-12-2013 / 01:20:09 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!

getFontMetrics
    |info|

    info := DeviceWorkstation::DeviceFontMetrics new.
    info
      ascent:self ascent
      descent:self descent
      maxAscent:self maxAscent
      maxDescent:self maxDescent
      minWidth:self maxWidth
      maxWidth:self maxWidth
      avgWidth:self maxWidth
      minCode:self minCode
      maxCode:self maxCode
      direction:#LeftToRight.
    ^ info
!

height
    "return the height - the number of pixels above plus below the baseLine."

    ^ self xftFontGetHeight: fontId

    "Created: / 21-12-2013 / 01:20:21 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!

isFixedWidth
    "return true, if this is a fixed pitch font (i.e. all characters
     are of the same width)"

    ^ false "/ How to check?

    "Created: / 21-12-2013 / 10:38:47 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!

maxAscent
    "return the fonts maximum-ascent (i.e. the maximum of all characters);
     That is the number of units (usually pixels) above the baseline."

    ^ self ascent

    "Created: / 30-12-2013 / 20:01:01 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!

maxDescent
    "return the fonts maximum-descent (i.e. the maximum of all characters);
     That is the number of units (usually pixels) below the baseline."

    ^ self descent

    "Created: / 30-12-2013 / 20:01:08 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!

maxWidth
    "return the fonts maximum-width character (i.e. the maximum of all characters);
     That is a number of units (usually pixels)."

    ^ self xftFontGetMaxAdvanceWidth: fontId

    "Created: / 30-12-2013 / 20:02:48 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!

widthOf:aString from:start to:stop
    "return the width of a sub string"

    | extents |

    (stop < start) ifTrue:[^ 0].
    extents := self xftTextExtents: device displayId font: fontId string: aString from: start to: stop.
    "/ extents --> #(width height x y xOff yOff)
    ^ extents fifth.

    "Created: / 21-12-2013 / 10:42:15 / Jan Vrany <jan.vrany@fit.cvut.cz>"
    "Modified: / 29-12-2013 / 21:16:50 / Jan Vrany <jan.vrany@fit.cvut.cz>"
! !

!XftFontDescription methodsFor:'release'!

releaseDrawIfAssociatedWith: view
    | drawableId |

    view isNil ifTrue:[ ^ self ].
    drawableId := view id.
    drawableId isNil ifTrue: [ ^ self ].
%{
#ifdef XFT
    if ( __INST(sharedDrawId) != nil ) {
	if (XftDrawDrawable(XFT_DRAW(__INST(sharedDrawId))) == DRAWABLE(drawableId)) {
	    __INST(sharedDrawId) = nil;
	    XftDrawDestroy(DRAWABLE(drawableId));
	}
    }
    RETURN (self);
#endif
%}.
    self primitiveFailed

    "Created: / 12-01-2014 / 19:48:51 / Jan Vrany <jan.vrany@fit.cvut.cz>"
    "Modified: / 12-01-2014 / 22:09:27 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!

releaseFromDevice
    "I am no longer available on the device"

    device := nil.
    fontId := nil.
    sharedDrawId := nil.
    closestFont := nil
! !

!XftFontDescription methodsFor:'testing'!

isUsed
    ^ sharedDrawId notNil
!

isXftFont
    ^ true
! !

!XftFontDescription::FCFontListParser class methodsFor:'documentation'!

documentation
"
    parses fc-list output to get a list of XftFontDescriptions

    [author:]
	cg

    [instance variables:]

    [class variables:]

    [see also:]

"
! !

!XftFontDescription::FCFontListParser methodsFor:'api'!

listOfAvailableFonts
    |readEntry list l fcListProg|

    list := OrderedCollection new.

    readEntry :=
	[
	    |key|

	    [l startsWith:'Pattern has'] whileFalse:[
	      l := pipeStream nextLine. Transcript showCR:l.
	    ].

	    currentDescription := XftFontDescription new.
	    [ l := pipeStream nextLine. l notEmptyOrNil ] whileTrue:[
		"/ Transcript showCR:l.
		lineStream := l readStream. lineStream skipSeparators.
		key := lineStream upToSeparator.
		(
		    #('family:' 'style:' 'slant:' 'weight:' 'width:'
		      'pixelsize:' 'spacing:' 'foundry:' 'antialias:'
		      'file:' 'outline' 'scalable:' 'charset:' 'lang:'
		      'fontversion:' 'fontformat:' 'decorative:' 'index:'
		      'outline:' 'familylang:' 'stylelang:' 'fullname:'
		      'fullnamelang:' 'capability:' 'hash:' 'postscriptname:'
		    ) includes:key
		) ifTrue:[
		    self perform:('fc_',(key allButLast)) asSymbol
		] ifFalse:[
		    Transcript show:'Xft ignored line: '; showCR:l.
		    self breakPoint:#cg.
		].
	    ].
	    list add:currentDescription
	].

    fcListProg := #('/usr/bin/fc-list' '/usr/X11/bin/fc-list') detect:[:eachProg|
			eachProg asFilename isExecutableProgram
		    ] ifNone:[
			'fc-list program not found - no XFT fonts' infoPrintCR.
			^ list.
		    ].

    pipeStream := PipeStream readingFrom:fcListProg, ' -v'.
    [
	[pipeStream atEnd] whileFalse:[
	    l := pipeStream nextLine.
	    readEntry value.
	]
    ] ensure:[
	pipeStream close
    ].
    ^ list

    "
     FCFontListParser new listOfAvailableFonts
    "
! !

!XftFontDescription::FCFontListParser methodsFor:'font list keywords'!

fc_antialias
    "helper for font listing"

    currentDescription isAntialiasedFont:(self getBoolean).
!

fc_capability
    "helper for font listing"

    "currentDescription capability:" (self getString).
!

fc_charset
    "helper for font listing"

    |page bits l min max minCode maxCode|

    [ l := pipeStream nextLine. l notEmpty ] whileTrue:[
	"/ Transcript show:'->'; showCR:l.
	(l startsWith:Character tab) ifFalse:[
	    (l startsWith:'(') ifFalse:[self halt].
	    currentDescription minCode:minCode.
	    currentDescription maxCode:maxCode.
	    ^ self.
	].

	lineStream := l readStream.
	lineStream skipSeparators.
	page := Integer readFrom:(lineStream upTo:$:) radix:16.
	lineStream next.
	bits := 0 to:7 collect:[:i|
	    lineStream skipSeparators.
	    Integer readFrom:(lineStream upToSeparator) radix:16.
	].
	min := (page * 256 + 0).
	max := (page * 256 + 255).
	minCode isNil ifTrue:[
	    minCode := min.
	    maxCode := max.
	] ifFalse:[
	    minCode := minCode min:min.
	    maxCode := maxCode max:max.
	].
    ].
    "/ currentDescription characterSet:(self getString).
    currentDescription minCode:minCode.
    currentDescription maxCode:maxCode.
!

fc_decorative
    "helper for font listing"

    currentDescription isDecorativeFont:(self getBoolean).
!

fc_family
    "helper for font listing"

    currentDescription family:(self getString).
!

fc_familylang
    "helper for font listing"

    "currentDescription familylang:" (self getString).
!

fc_file
    "helper for font listing"

    currentDescription file:(self getString).
!

fc_fontformat
    "helper for font listing"

    currentDescription fontFormat:(self getString).
!

fc_fontversion
    "helper for font listing"

    currentDescription fontVersion:(self getInteger).
!

fc_foundry
    "helper for font listing"

    currentDescription foundry:(self getString).
!

fc_fullname
    "helper for font listing"

    "currentDescription fullname:" (self getString).
!

fc_fullnamelang
    "helper for font listing"

    "currentDescription fullnamelang:" (self getString).
!

fc_hash
    "helper for font listing"

    "currentDescription hash:" self getString.
!

fc_index
    "helper for font listing"

    "currentDescription index:" (self getInteger).
!

fc_lang
    "helper for font listing"

    "/ currentDescription characterSet:(self getString).
!

fc_outline
    "helper for font listing"

    currentDescription isOutlineFont:(self getBoolean).
!

fc_pixelsize
    "helper for font listing"

    currentDescription setPixelSize:(self getInteger).
    currentDescription setSizeUnit:#px.
    "/ currentDescription setSize:(self getInteger).
    "/ currentDescription setSizeUnit:#pt.
!

fc_postscriptname
    "helper for font listing"

    "currentDescription postscriptname:" self getString.
!

fc_scalable
    "helper for font listing"

    currentDescription isScalableFont:(self getBoolean).
!

fc_slant
    "helper for font listing"

    currentDescription slant:(self getInteger).
!

fc_spacing
    "helper for font listing"

    currentDescription spacing:(self getInteger).
!

fc_style
    "helper for font listing"

    |xftStyle|

    xftStyle := self getString.
"/    ((xftStyle includesString:'Bold') or:[xftStyle includesString:'Fett']) ifTrue:[
"/        currentDescription face:'bold'.
"/        currentDescription style:'roman'.
"/        ^ self.
"/    ].
    ((xftStyle includesString:'Italic') or:[xftStyle includesString:'Oblique']) ifTrue:[
"/        currentDescription face:'medium'.
	currentDescription style:'italic'.
	^ self.
    ].
"/    (xftStyle includesString:'Regular') ifTrue:[
"/        currentDescription face:'regular'.
"/        currentDescription style:'roman'.
"/        ^ self.
"/    ].
"/ self halt.
"/    currentDescription face:'medium'.
    currentDescription style:'roman'.
!

fc_stylelang
    "helper for font listing"

    "currentDescription stylelang:" (self getString).
!

fc_weight
    "helper for font listing"

    currentDescription weight:(self getInteger).
!

fc_width
    "helper for font listing"

    currentDescription width:(self getInteger).
! !

!XftFontDescription::FCFontListParser methodsFor:'helpers'!

getBoolean
    "helper for font listing"

    |s|

    lineStream skipSeparators.
    s := lineStream nextAlphaNumericWord.
    ^ s = 'FcTrue'.
!

getInteger
    "helper for font listing"

    lineStream skipSeparators.
    ^ Integer readFrom:lineStream.
!

getString
    "helper for font listing"

    lineStream skipSeparators.
    lineStream peekFor:$".
    ^ (lineStream upTo:$").
! !

!XftFontDescription class methodsFor:'documentation'!

version
    ^ '$Header: /cvs/stx/stx/libview/XftFontDescription.st,v 1.48 2014-04-27 21:31:11 cg Exp $'
!

version_CVS
    ^ '$Header: /cvs/stx/stx/libview/XftFontDescription.st,v 1.48 2014-04-27 21:31:11 cg Exp $'
! !


XftFontDescription initialize!