XftFontDescription.st
author Stefan Vogel <sv@exept.de>
Fri, 15 Jul 2016 13:57:43 +0200
branchdelegated_gc
changeset 7412 d4b5f3114373
parent 7215 53d6c2df7b06
permissions -rw-r--r--
Need device instvar CVS ----------------------------------------------------------------------

'From Smalltalk/X, Version:6.2.5.0 on 17-12-2014 at 18:03:00'                   !

"{ 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.
	'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:'converting'!

asNonXftFont
    |newFont|

    newFont := FontDescription 
                    family:family 
                    face:face 
                    style:style 
                    size:(sizeUnit == #px ifTrue:[pixelSize] ifFalse:[size]) 
                    sizeUnit:sizeUnit
                    encoding:encoding.

    ^ newFont 
! !

!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 + 1.
    stringLen > 8000 ifTrue:[
        index2 := index1 + 8000 - 1.
    ]  ifFalse:[
        stringLen <= 0 ifTrue:[^ self].
        index2 := index2Arg.
    ].
    bytesPerCharacter := aString bitsPerCharacter // 8.
    transformation := aGC transformation.

    clipR := aGC deviceClippingBoundsOrNil.
    clipR notNil ifTrue:[
        clipX := clipR left.
        clipY := clipR top.
        clipW := clipR width.
        clipH := clipR height.
clipW > 32767 ifTrue:['clipW > 32767 ' errorPrintCR. clipW errorPrintCR. self halt. clipW := 32767].
(clipX > 16384 or:[clipX < -16384]) ifTrue:['clipX < 16384 ' errorPrintCR. clipX errorPrintCR.].
        "/ YES YES YES: this MUST be transformed!!
        "/ (see htmlView) fix the notebook, please.
"/        transformation notNil ifTrue:[
"/            clipX := (transformation applyToX:clipX) ceiling.
"/            clipY := (transformation applyToY:clipY) ceiling.
"/        ].
    ].

    transformation isNil ifTrue:[
        drawX := xArg.
        drawY := yArg.
    ] ifFalse:[
        drawX := (transformation applyToX:xArg) ceiling.
        drawY := (transformation applyToY:yArg) ceiling.
    ].

    fg  :=  aGC paint.
    fgPixel := fg colorId.
    fgA := fg scaledAlpha.
    fgR := fg scaledRed.
    fgR notNil ifTrue:[
        fgG := fg scaledGreen.
        fgB := fg scaledBlue.
    ] ifFalse:[
        "/ when drawing into a pixmap...
        fgPixel == 0 ifTrue:[
            fgR := fgG := fgB := 0.
        ] ifFalse:[
            fgR := fgG := fgB := 16rFFFF.
        ]
    ].

    opaque ifTrue:[
        bg  := aGC backgroundPaint.
        bgPixel := bg colorId.
        bgA := bg scaledAlpha.
        bgR := bg scaledRed.
        bgR notNil ifTrue:[
            bgG := bg scaledGreen.
            bgB := bg scaledBlue.
        ] ifFalse:[
            "/ when drawing into a pixmap...
            bgPixel == 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;
        }
if (extents.width < 0) printf("width: %d  < 0\n", extents.width);
        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;
    }
#endif
    err:;
%}.
    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
    ].
    aGraphicsDevice supportsXFTFonts ifFalse:[
        ^ super onDevice:aGraphicsDevice
    ].

    (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) and:[aFont getFontId notNil]]) 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
        ].
    ].

^ self asNonXftFont onDevice:aGraphicsDevice.

    [
        Error handle:[:ex |
            ^ self asNonXftFont onDevice:aGraphicsDevice
        ] do:[
            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)."

    ^ self onDevice:aWorkstation

    "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.
        encoding notNil ifTrue:[encoding := encoding asSymbol].
    ].

    "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
!

getFontResolution
    device isNil ifTrue:[ ^ 72 @ 72 ].
    ^ device resolution
!

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 maxWidthOfSingleGlyph|

    (stop < start) ifTrue:[^ 0].
    maxWidthOfSingleGlyph := self maxWidth.
    "xOff from XFTTextExtents is a signed short.
     Work arond for long strings"
    (stop - start + 1) * maxWidthOfSingleGlyph > 32767 ifTrue:[
        |total chunkSize|

        chunkSize := (32767 // maxWidthOfSingleGlyph) - 1.
        total := 0.
        start to:stop by:chunkSize do:[:eachChunkStart|
            extents := self xftTextExtents:device displayId font:fontId string:aString 
                            from:eachChunkStart to:((eachChunkStart+chunkSize-1) min:stop).
            "/ extents --> #(width height x y xOff yOff)
            total := total + extents fifth.
        ].
        ^ total.
    ].    
    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:[
                        'XftFontDescription [warning]: fc-list program not found - no XFT fonts' errorPrintCR.
                        ^ 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$'
!

version_CVS
    ^ '$Header$'
! !


XftFontDescription initialize!