XftFontDescription.st
author Jan Vrany <jan.vrany@fit.cvut.cz>
Thu, 02 Jan 2014 23:54:56 +0100
changeset 6190 d651313d4044
parent 6189 9194261bf002
child 6191 86ef1e69ffc1
permissions -rw-r--r--
Fixes to share XftFontDescription instances.

"{ Package: 'stx:libview' }"

FontDescription subclass:#XftFontDescription
	instanceVariableNames:'device fontId drawId closestFont'
	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'
	poolDictionaries:''
	category:'Graphics-Support'
!

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

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:{
        'regular'.  FC_WEIGHT_REGULAR.
        'medium'.   FC_WEIGHT_MEDIUM.
        'bold'.     FC_WEIGHT_BOLD.
    }.
    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:'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>"
! !

!XftFontDescription methodsFor:'accessing-private'!

getDevice

    ^ device

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

getFontId

    ^ fontId

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

!XftFontDescription methodsFor:'displaying'!

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

    | extents |

    drawId isNil ifTrue:[
        drawId := self xftDrawCreate: device displayId screen: device screen drawable: aGC id.
    ] ifFalse:[
        self xftDrawChange: drawId drawable: aGC id
    ].
    self xftDrawSetClip: drawId rectangle: aGC clippingBounds.  
    extents :=  self xftTextExtents: device displayId font: fontId string: aString from: index1 to: index2.

    opaque ifTrue:[
        "/ While following is technically correct
        "/
        "/ self xftDrawRect: drawId color: aGC backgroundPaint   x: x - extents third y:y - extents fourth width: extents first height: extents second
        "/
        "/ We have to clear while ascent+descent because otherwise Text with background become
        "/ funny-looking. This is a bug in Text which has to be compensated here...
        self xftDrawRect: drawId color: aGC backgroundPaint   x: x - extents third y:y - self ascent width: extents first height: self height

    ].
    self xftDrawString: drawId color: aGC paint font: fontId x: x y: y  string: aString from: index1 to: index2

    "Created: / 21-12-2013 / 21:11:07 / Jan Vrany <jan.vrany@fit.cvut.cz>"
    "Modified: / 31-12-2013 / 01:28:02 / Jan Vrany <jan.vrany@fit.cvut.cz>"
! !

!XftFontDescription methodsFor:'error reporting'!

primitiveFailedIfNoXft
    <resource: #skipInDebuggersWalkBack>
%{
#ifdef XFT
    RETURN ( self );
#endif
%}.
    self primitiveFailed: 'Xft support not available'

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

!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 getDevice == aGraphicsDevice]) ifTrue:[
        ^ closestFont onDevice: aGraphicsDevice.
    ].

    aGraphicsDevice deviceFonts do:[:aFont |
        (self sameDeviceFontAs:aFont) ifTrue:[
            ^ 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).
        self xftPatternAdd: myPatternId attribute: FC_SLANT value: (StXStyle2FCSlantMap at: style).

        newFontId := self xftFontOpenPattern: aGraphicsDevice displayId pattern: myPatternId.
        newFontId notNil ifTrue:[
            "/ Good, this font exist!!
            fontId := newFontId.
            device := aGraphicsDevice.
            aGraphicsDevice registerFont: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 be open (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 class new
                                setDevice: aGraphicsDevice patternId: closestPatternId2 fontId: newFontId;
                                yourself.
            aGraphicsDevice registerFont: closestFont.
            ^ closestFont
        ].
    ] ensure:[
        self xftPatternDestroy: myPatternId.
        self xftPatternDestroy: closestPatternId1.
        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 shouldImplement

    "Modified: / 02-01-2014 / 23:15:27 / Jan Vrany <jan.vrany@fit.cvut.cz>"
! !

!XftFontDescription methodsFor:'initialization'!

setDevice: deviceArg patternId: patternIdArg fontId: fontIdArg

    device := deviceArg.
    fontId := fontIdArg.

    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.

    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 |

    self primitiveFailedIfNoXft.
%{
#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 |

    self primitiveFailedIfNoXft.
%{
#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 |

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

    r := aColor scaledRed.
    g := aColor scaledGreen.
    b := aColor scaledBlue.
    a := aColor alpha * 65535.
    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  |

    self primitiveFailedIfNoXft.
    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 |

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

    r := aColor scaledRed.
    g := aColor scaledGreen.
    b := aColor scaledBlue.
    a := aColor alpha * 65535.
    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 |

    self primitiveFailedIfNoXft.
%{
#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 |

    self primitiveFailedIfNoXft.
%{
#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 |

    self primitiveFailedIfNoXft.
%{
#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 |

    self primitiveFailedIfNoXft.
%{
#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 |

    self primitiveFailedIfNoXft.
%{
#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 |

    self primitiveFailedIfNoXft.
%{
#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;
    }

    p = XftFontMatch( DISPLAY(displayId) , SCREEN( screen ), FC_PATTERN( patternId ), &r );
    if (r == XftResultMatch) {
        RETURN ( FC_PATTERN_HANDLE_NEW ( p ) );
    } else {
        if ( p ) {
            XftPatternDestroy( p );
        }
        RETURN ( nil );
    }
    err:;
#endif
%}.
    self primitiveFailed: error

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

xftFontOpenPattern: displayId pattern: patternId

    | error |

    self primitiveFailedIfNoXft.
%{
#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 |

    self primitiveFailedIfNoXft.

%{
#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

    self primitiveFailedIfNoXft.
%{
#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 |

    self primitiveFailedIfNoXft.
%{
#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 |

    self primitiveFailedIfNoXft.
    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 |

    self primitiveFailedIfNoXft.
    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 |

    self primitiveFailedIfNoXft.
%{
#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 |

    self primitiveFailedIfNoXft.
    extents :=  Array new: 6.
%{
#ifdef XFT
    XGlyphInfo info;
    int _start, _stop;
    if ( ! __isExternalAddressLike(displayIdArg) ) {
        error = @symbol(BadArg1);
        goto err;
    }
    if ( ! __isExternalAddressLike(fontIdArg) ) {
        error = @symbol(BadArg2);
        goto err;
    }
    if ( ! __isSmallInteger(start) ) {
        error = @symbol(BadArg4);
        goto err;
    }
    _start = __intVal(start);
    if ( ! __isSmallInteger(stop) ) {
        error = @symbol(BadArg5);
        goto err;
    }
    _stop = __intVal(stop);
    if ( __isStringLike(text) ) {
        XftTextExtents8(DISPLAY(displayIdArg), XFT_FONT(fontIdArg),
                        __stringVal(text) + (_start - 1), _stop - _start + 1, &info);
    } else {
        error = @symbol(BadArg3);
        goto err;
    }
    __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:'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>"
!

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 class methodsFor:'documentation'!

version
    ^ '$Header: /cvs/stx/stx/libview/XftFontDescription.st,v 1.12 2014-01-02 22:54:56 vrany Exp $'
!

version_CVS
    ^ '$Header: /cvs/stx/stx/libview/XftFontDescription.st,v 1.12 2014-01-02 22:54:56 vrany Exp $'
! !


XftFontDescription initialize!