XWorkstation.st
changeset 7409 2de3e4caafbb
parent 7371 d88ae8653ca8
child 7413 3ecf41208027
child 7489 07c626716aed
equal deleted inserted replaced
7408:d1cebfa53c19 7409:2de3e4caafbb
  6868 
  6868 
  6869 !XWorkstation methodsFor:'font stuff'!
  6869 !XWorkstation methodsFor:'font stuff'!
  6870 
  6870 
  6871 createFontFor:aFontName
  6871 createFontFor:aFontName
  6872     "a basic method for X-font allocation; this method allows
  6872     "a basic method for X-font allocation; this method allows
  6873      any font to be aquired (even those not conforming to
  6873      any font to be acquired (even those not conforming to
  6874      standard naming conventions, such as cursor, fixed or k14)"
  6874      standard naming conventions, such as cursor, fixed or k14)"
  6875 
  6875 
  6876     <context: #return>
  6876     <context: #return>
  6877 
  6877 
  6878 %{  /* STACK: 100000 */
  6878 %{  /* STACK: 100000 */
  6881     XFontStruct *newFont;
  6881     XFontStruct *newFont;
  6882 
  6882 
  6883     if (ISCONNECTED
  6883     if (ISCONNECTED
  6884      && __isStringLike(aFontName)) {
  6884      && __isStringLike(aFontName)) {
  6885 
  6885 
  6886 	ENTER_XLIB();
  6886         ENTER_XLIB();
  6887 	newFont = XLoadQueryFont(myDpy, (char *)__stringVal(aFontName));
  6887         newFont = XLoadQueryFont(myDpy, (char *)__stringVal(aFontName));
  6888 	LEAVE_XLIB();
  6888         LEAVE_XLIB();
  6889 #ifdef COUNT_RESOURCES
  6889 #ifdef COUNT_RESOURCES
  6890 	if (newFont)
  6890         if (newFont)
  6891 	    __cnt_font++;
  6891             __cnt_font++;
  6892 #endif
  6892 #endif
  6893 
  6893 
  6894 	RETURN ( newFont ? __MKEXTERNALADDRESS(newFont) : nil );
  6894         RETURN ( newFont ? __MKEXTERNALADDRESS(newFont) : nil );
  6895     }
  6895     }
  6896 %}.
  6896 %}.
  6897     "/ --- disabled due to UNLIMITEDSTACK -- self primitiveFailedOrClosedConnection.
  6897     "/ --- disabled due to UNLIMITEDSTACK -- self primitiveFailedOrClosedConnection.
  6898     ^ nil
  6898     ^ nil
  6899 !
  6899 !
  7560        Screen current getDefaultFontWithEncoding:#'iso10646-1'
  7560        Screen current getDefaultFontWithEncoding:#'iso10646-1'
  7561      "
  7561      "
  7562 !
  7562 !
  7563 
  7563 
  7564 getFontWithFamily:familyString face:faceString
  7564 getFontWithFamily:familyString face:faceString
  7565 	    style:styleArgString size:sizeArgOrNil sizeUnit:sizeUnit encoding:encoding
  7565             style:styleArgString size:sizeArgOrNil sizeUnit:sizeUnit encoding:encoding
  7566 
  7566 
  7567     "try to get the specified font, if not available, try next smaller
  7567     "try to get the specified font, if not available, try next smaller
  7568      font. Access to X-fonts by name is possible, by passing the X font name
  7568      font. Access to X-fonts by name is possible, by passing the X font name
  7569      as family and the other parameters as nil. For example, the cursor font
  7569      as family and the other parameters as nil. For example, the cursor font
  7570      can be aquired that way."
  7570      can be acquired that way."
  7571 
  7571 
  7572     |styleString theName theId xlatedStyle
  7572     |styleString theName theId xlatedStyle
  7573      id spacing encodingMatch idx roundedSize pixelSize pointSize|
  7573      id spacing encodingMatch idx roundedSize pixelSize pointSize|
  7574 
  7574 
  7575     styleString := styleArgString.
  7575     styleString := styleArgString.
  7576 
  7576 
  7577     sizeArgOrNil notNil ifTrue:[
  7577     sizeArgOrNil notNil ifTrue:[
  7578 	roundedSize := sizeArgOrNil rounded asInteger.
  7578         roundedSize := sizeArgOrNil rounded asInteger.
  7579 	sizeUnit == #px ifTrue:[
  7579         sizeUnit == #px ifTrue:[
  7580 	    pixelSize := roundedSize.
  7580             pixelSize := roundedSize.
  7581 	] ifFalse:[
  7581         ] ifFalse:[
  7582 	    pointSize := roundedSize.
  7582             pointSize := roundedSize.
  7583 	].
  7583         ].
  7584     ].
  7584     ].
  7585 
  7585 
  7586     "special: if face is nil, allow access to X-fonts"
  7586     "special: if face is nil, allow access to X-fonts"
  7587     faceString isNil ifTrue:[
  7587     faceString isNil ifTrue:[
  7588 	roundedSize notNil ifTrue:[
  7588         roundedSize notNil ifTrue:[
  7589 	    theName := familyString , '-' , roundedSize printString
  7589             theName := familyString , '-' , roundedSize printString
  7590 	] ifFalse:[
  7590         ] ifFalse:[
  7591 	    theName := familyString
  7591             theName := familyString
  7592 	].
  7592         ].
  7593 	theName notNil ifTrue:[
  7593         theName notNil ifTrue:[
  7594 	    theId := self createFontFor:theName.
  7594             theId := self createFontFor:theName.
  7595 	].
  7595         ].
  7596 	theId isNil ifTrue:[
  7596         theId isNil ifTrue:[
  7597 	    theId := self getDefaultFontWithEncoding:encoding
  7597             theId := self getDefaultFontWithEncoding:encoding
  7598 	].
  7598         ].
  7599 	^ theId
  7599         ^ theId
  7600     ].
  7600     ].
  7601 
  7601 
  7602     "/ spacing other than 'normal' is contained as last component
  7602     "/ spacing other than 'normal' is contained as last component
  7603     "/ in style
  7603     "/ in style
  7604 
  7604 
  7605     (styleString notNil
  7605     (styleString notNil
  7606      and:[(styleString endsWith:'-narrow')
  7606      and:[(styleString endsWith:'-narrow')
  7607 	  or:[styleString endsWith:'-semicondensed']]) ifTrue:[
  7607           or:[styleString endsWith:'-semicondensed']]) ifTrue:[
  7608 	|i|
  7608         |i|
  7609 	i := styleString lastIndexOf:$-.
  7609         i := styleString lastIndexOf:$-.
  7610 	spacing := styleString copyFrom:(i+1).
  7610         spacing := styleString copyFrom:(i+1).
  7611 	styleString := styleString copyTo:(i-1).
  7611         styleString := styleString copyTo:(i-1).
  7612     ] ifFalse:[
  7612     ] ifFalse:[
  7613 	spacing := 'normal'.
  7613         spacing := 'normal'.
  7614     ].
  7614     ].
  7615 
  7615 
  7616     xlatedStyle := styleString.
  7616     xlatedStyle := styleString.
  7617     xlatedStyle notNil ifTrue:[
  7617     xlatedStyle notNil ifTrue:[
  7618 	xlatedStyle := xlatedStyle first asString
  7618         xlatedStyle := xlatedStyle first asString
  7619     ].
  7619     ].
  7620 
  7620 
  7621     encoding isNil ifTrue:[
  7621     encoding isNil ifTrue:[
  7622 	encodingMatch := '*-*'.
  7622         encodingMatch := '*-*'.
  7623     ] ifFalse:[
  7623     ] ifFalse:[
  7624 	idx := encoding indexOf:$-.
  7624         idx := encoding indexOf:$-.
  7625 	idx ~~ 0 ifTrue:[
  7625         idx ~~ 0 ifTrue:[
  7626 	    encodingMatch := encoding
  7626             encodingMatch := encoding
  7627 	] ifFalse:[
  7627         ] ifFalse:[
  7628 	    encodingMatch := encoding , '-*'.
  7628             encodingMatch := encoding , '-*'.
  7629 	].
  7629         ].
  7630     ].
  7630     ].
  7631 
  7631 
  7632     id := self
  7632     id := self
  7633 	    getFontWithFoundry:'*'
  7633             getFontWithFoundry:'*'
  7634 	    family:familyString asLowercase
  7634             family:familyString asLowercase
  7635 	    weight:faceString
  7635             weight:faceString
  7636 	    slant:xlatedStyle
  7636             slant:xlatedStyle
  7637 	    spacing:spacing
  7637             spacing:spacing
  7638 	    pixelSize:pixelSize
  7638             pixelSize:pixelSize
  7639 	    size:pointSize
  7639             size:pointSize
  7640 	    encoding:encodingMatch.
  7640             encoding:encodingMatch.
  7641 
  7641 
  7642     id isNil ifTrue:[
  7642     id isNil ifTrue:[
  7643 	(encodingMatch notNil and:[encodingMatch ~= '*']) ifTrue:[
  7643         (encodingMatch notNil and:[encodingMatch ~= '*']) ifTrue:[
  7644 	    "/ too stupid: registries come in both cases
  7644             "/ too stupid: registries come in both cases
  7645 	    "/ and X does not ignore case
  7645             "/ and X does not ignore case
  7646 	    "/
  7646             "/
  7647 	    id := self
  7647             id := self
  7648 		    getFontWithFoundry:'*'
  7648                     getFontWithFoundry:'*'
  7649 		    family:familyString asLowercase
  7649                     family:familyString asLowercase
  7650 		    weight:faceString
  7650                     weight:faceString
  7651 		    slant:xlatedStyle
  7651                     slant:xlatedStyle
  7652 		    spacing:spacing
  7652                     spacing:spacing
  7653 		    pixelSize:nil
  7653                     pixelSize:nil
  7654 		    size:roundedSize
  7654                     size:roundedSize
  7655 		    encoding:encodingMatch asUppercase.
  7655                     encoding:encodingMatch asUppercase.
  7656 	    id isNil ifTrue:[
  7656             id isNil ifTrue:[
  7657 		id := self
  7657                 id := self
  7658 			getFontWithFoundry:'*'
  7658                         getFontWithFoundry:'*'
  7659 			family:familyString asLowercase
  7659                         family:familyString asLowercase
  7660 			weight:faceString
  7660                         weight:faceString
  7661 			slant:xlatedStyle
  7661                         slant:xlatedStyle
  7662 			spacing:spacing
  7662                         spacing:spacing
  7663 			pixelSize:nil
  7663                         pixelSize:nil
  7664 			size:roundedSize
  7664                         size:roundedSize
  7665 			encoding:encodingMatch asLowercase.
  7665                         encoding:encodingMatch asLowercase.
  7666 	    ]
  7666             ]
  7667 	]
  7667         ]
  7668     ].
  7668     ].
  7669     ^ id
  7669     ^ id
  7670 
  7670 
  7671     "Modified: 4.7.1996 / 11:38:47 / stefan"
  7671     "Modified: 4.7.1996 / 11:38:47 / stefan"
  7672     "Modified: 10.4.1997 / 19:20:06 / cg"
  7672     "Modified: 10.4.1997 / 19:20:06 / cg"