paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-04-05 09:18:02 +02:00
Code Issues Packages Projects Releases Wiki Activity

LCL-GTK2&3: Improve handling of font stretch and weight in font name. Issue #29596, patch by Juliette.

Browse Source
This commit is contained in:
Juha 2025-02-23 12:42:07 +02:00
parent 95fe7a07c2
commit 049fedf34a
8 changed files with 503 additions and 35 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

68
lcl/interfaces/gtk2/gtk2int.pas
View File

@ -392,6 +392,10 @@ type
var
GTK2WidgetSet: TGTK2WidgetSet;
procedure ExtractPangoFontFaceSuffixes(var AFontName: string; out AStretch: TPangoStretch; out AWeight: TPangoWeight);
function AppendPangoFontFaceSuffixes(AFamilyName: string; AStretch: TPangoStretch; AWeight: TPangoWeight): string;
function PangoFontHasItalicFace(context: PPangoContext; const familyName: String): Boolean;
function GetPangoFontFamilyDefaultStretch(const AFamilyName: string): TPangoStretch;
// Gtk2FileDialogUtils
@ -950,6 +954,70 @@ end;
{$I gtk2listsl.inc}
procedure ExtractPangoFontFaceSuffixes(var AFontName: string; out AStretch: TPangoStretch; out AWeight: TPangoWeight);
var
stretch, weight: integer;
begin
ExtractFontFaceSuffixes(AFontName, stretch, weight);
AStretch := TPangoStretch(stretch);
AWeight := TPangoWeight(weight);
end;
function AppendPangoFontFaceSuffixes(AFamilyName: string; AStretch: TPangoStretch;
AWeight: TPangoWeight): string;
var
stretch: integer;
begin
if AStretch < PANGO_STRETCH_ULTRA_CONDENSED then
stretch := FONT_STRETCH_ULTRA_CONDENSED
else if AStretch > PANGO_STRETCH_ULTRA_EXPANDED then
stretch := FONT_STRETCH_ULTRA_EXPANDED
else
stretch := integer(AStretch);
result := AppendFontFaceSuffixes(AFamilyName, stretch, integer(AWeight));
end;
function PangoFontHasItalicFace(context: PPangoContext; const familyName: String): Boolean;
var
families: PPPangoFontFamily;
faces: PPPangoFontFace;
num_families, num_faces, i, j: Integer;
fontFamily: PPangoFontFamily;
hasOblique, hasItalic: boolean;
desc: PPangoFontDescription;
begin
Result := False;
pango_context_list_families(context, @families, @num_families);
for i := 0 to num_families - 1 do
begin
fontFamily := families[i];
if StrComp(pango_font_family_get_name(fontFamily), PChar(familyName)) = 0 then
begin
pango_font_family_list_faces(fontFamily, @faces, @num_faces);
for j := 0 to num_faces - 1 do
begin
desc := pango_font_face_describe(faces[j]);
if pango_font_description_get_style(desc) = PANGO_STYLE_ITALIC then
begin
Result := True;
Break;
end;
end;
g_free(faces);
end;
if Result then Break;
end;
g_free(families);
end;
function GetPangoFontFamilyDefaultStretch(const AFamilyName: string): TPangoStretch;
begin
result := TPangoStretch(GetFontFamilyDefaultStretch(AFamilyName));
end;
// Gtk2FileDialogUtils
{------------------------------------------------------------------------------

27
lcl/interfaces/gtk2/gtk2winapi.inc
View File

@ -1344,7 +1344,8 @@ function TGtk2WidgetSet.CreateFontIndirectEx(const LogFont: TLogFont;
var
GdiObject: PGdiObject;
FullString, aFamily, aStyle, ALongFontName: String;
aSize: Integer;
aStretch: TPangoStretch;
aSize, aWeight: Integer;
aSizeInPixels: Boolean;
PangoDesc: PPangoFontDescription;
CachedFont: TGtkFontCacheDescriptor;
@ -1352,7 +1353,6 @@ var
AttrListTemporary: Boolean;
Attr: PPangoAttribute;
CurFont: PPangoLayout;
TmpStr: PChar;
begin
{$IFDEF VerboseFonts}
DebugLn('TGtk2WidgetSet.CreateFontIndirectEx A Name=',LogFont.lfFaceName,' Height=',dbgs(LogFont.lfHeight),' LongName=',LongFontName);
@ -1404,6 +1404,7 @@ begin
end;
FontNameToPangoFontDescStr(ALongFontname, aFamily, aStyle, aSize, aSizeInPixels);
ExtractPangoFontFaceSuffixes(aFamily, aStretch, aWeight);
// if font specified size, prefer this instead of 'possibly' inaccurate
// lfHeight note that lfHeight may actually have a most accurate value
@ -1456,17 +1457,25 @@ begin
else
FullString := AFamily + ', ' + aStyle + ' ' + FullString;
PangoDesc := pango_font_description_from_string(PChar(FullString));
if aStretch <> PANGO_STRETCH_NORMAL then
pango_font_description_set_stretch(PangoDesc, aStretch);
if (pango_font_description_get_weight(PangoDesc) = PANGO_WEIGHT_NORMAL)
and (lfWeight <> FW_DONTCARE) then
pango_font_description_set_weight(PangoDesc, lfWeight);
if (pango_font_description_get_weight(PangoDesc) = PANGO_WEIGHT_NORMAL) then
begin
if (lfWeight = FW_DONTCARE) or
{ handle non bold styles (lfWeight is set to "normal" by default) }
(lfWeight = PANGO_WEIGHT_NORMAL) or
{ handle bold styles (lfWeight is set to "bold" because TFont has fsBold style) }
((lfWeight = PANGO_WEIGHT_BOLD) and (aWeight >= FW_SEMIBOLD)) then
pango_font_description_set_weight(PangoDesc, aWeight)
else if (lfWeight <> FW_DONTCARE) then
pango_font_description_set_weight(PangoDesc, lfWeight);
end;
if (pango_font_description_get_style (PangoDesc) = PANGO_STYLE_NORMAL)
and (lfItalic <> 0) then
pango_font_description_set_style(PangoDesc, PANGO_STYLE_ITALIC);
TmpStr := pango_font_description_to_string(PangoDesc);
aStyle := TmpStr;
g_free(TmpStr);
if (aSize=0) and (lfHeight<>0) then
begin
// a size is not specified, try to calculate one based on lfHeight
@ -1480,7 +1489,7 @@ begin
aSize := lfHeight * PANGO_SCALE;
pango_font_description_set_absolute_size(PangoDesc, aSize);
end;
// create font
// TODO: use context widget (CreateFontIndirectEx needs a parameter for this: Context: HWnd)
GdiObject := NewGdiObject(gdiFont);

38
lcl/interfaces/gtk2/gtk2wsdialogs.pp
View File

@ -455,7 +455,10 @@ var
DirName : string;
FileName : string;
Files: TStringList;
CurFilename: string;
CurFilename, weightSuffix: string;
stretch: TPangoStretch;
weight: TPangoWeight;
family: PChar;
//SelectedFont: PGdkFont;
function CheckOpenedFilename(var AFilename: string): boolean;
@ -576,15 +579,20 @@ begin
begin
BeginUpdate;
Size := pango_font_description_get_size(FontDesc) div PANGO_SCALE;
if pango_font_description_get_weight(FontDesc) >= PANGO_WEIGHT_BOLD then
weight := pango_font_description_get_weight(FontDesc);
if weight >= FW_SEMIBOLD then
Style := Style + [fsBold]
else
Style := Style - [fsBold];
if pango_font_description_get_style(FontDesc) > PANGO_STYLE_NORMAL then
Style := Style + [fsItalic]
else
Style := Style - [fsItalic];
Name := pango_font_description_get_family(FontDesc);
family := pango_font_description_get_family(FontDesc);
Name := AppendPangoFontFaceSuffixes(family,
pango_font_description_get_stretch(FontDesc), weight);
EndUpdate;
end;
pango_font_description_free(FontDesc);
@ -1371,6 +1379,9 @@ var
Widget: PGtkWidget;
WidgetInfo: PWidgetInfo;
FontDialog: TFontDialog absolute ACommonDialog;
Family: string;
Stretch: TPangoStretch;
Weight: integer;
begin
Widget := gtk_font_selection_dialog_new(PChar(ACommonDialog.Title));
@ -1392,17 +1403,30 @@ begin
begin
pango_font_description_set_size(FontDesc, Size * PANGO_SCALE);
if fsBold in Style then
Family := Name;
ExtractPangoFontFaceSuffixes(Family, Stretch, Weight);
pango_font_description_set_family(FontDesc, PChar(Family));
if (fsBold in Style) and (Weight < FW_SEMIBOLD) then
// bold is specified by the fsBold flag only
pango_font_description_set_weight(FontDesc, PANGO_WEIGHT_BOLD)
else
pango_font_description_set_weight(FontDesc, PANGO_WEIGHT_NORMAL);
pango_font_description_set_weight(FontDesc, Weight);
if fsItalic in Style then
pango_font_description_set_style(FontDesc, PANGO_STYLE_ITALIC)
begin
if PangoFontHasItalicFace(gtk_widget_get_pango_context(Widget), family) then
pango_font_description_set_style(FontDesc, PANGO_STYLE_ITALIC)
else
pango_font_description_set_style(FontDesc, PANGO_STYLE_OBLIQUE);
end
else
pango_font_description_set_style(FontDesc, PANGO_STYLE_NORMAL);
pango_font_description_set_family(FontDesc, PChar(Name));
if Stretch = PANGO_STRETCH_NORMAL then
pango_font_description_set_stretch(FontDesc, GetPangoFontFamilyDefaultStretch(Family))
else
pango_font_description_set_stretch(FontDesc, Stretch);
end;
TmpStr := pango_font_description_to_string(FontDesc);
gtk_font_selection_dialog_set_font_name(PGtkFontSelectionDialog(Widget), TmpStr);

34
lcl/interfaces/gtk3/gtk3objects.pas
View File

@ -872,6 +872,8 @@ var
members:TPangoFontMask;
AStyle: TPangoStyle;
AGravity: TPangoGravity;
stretch: TPangoStretch;
weight: TPangoWeight;
begin
if not Assigned(fHandle) then exit;
fillchar(fLogFont,sizeof(fLogFont),0);
@ -879,6 +881,15 @@ begin
if PANGO_FONT_MASK_FAMILY in members then
begin
fLogFont.lfFaceName:=PChar(fHandle^.get_family);
end else
begin
if PANGO_FONT_MASK_STRETCH in members then
stretch := fHandle^.get_stretch
else
stretch := PANGO_STRETCH_NORMAL;
fLogFont.lfFaceName:=AppendPangoFontFaceSuffixes(
PChar(fHandle^.get_family), stretch, PANGO_WEIGHT_NORMAL);
end;
if PANGO_FONT_MASK_STYLE in members then
begin
@ -887,9 +898,7 @@ begin
fLogFont.lfItalic:=1;
end;
if PANGO_FONT_MASK_WEIGHT in members then
begin
fLogFont.lfWeight := Integer(fHandle^.get_weight());
end;
if PANGO_FONT_MASK_GRAVITY in members then
begin
AGravity := fHandle^.get_gravity;
@ -964,10 +973,17 @@ var
AContext: PPangoContext;
AttrList: PPangoAttrList;
Attr: PPangoAttribute;
Family: string;
Stretch: TPangoStretch;
Weight: TPangoWeight;
begin
inherited Create;
FLogFont := ALogFont;
FFontName := ALogFont.lfFaceName;
Family := FFontName;
ExtractPangoFontFaceSuffixes(Family, Stretch, Weight);
AContext := gdk_pango_context_get;
if IsFontNameDefault(FFontName) or (FFontName = '') then
begin
@ -976,13 +992,23 @@ begin
else
FHandle := pango_font_description_copy(pango_context_get_font_description(AContext));
end else
FHandle := pango_font_description_from_string(PgChar(FFontName));
begin
FHandle := TPangoFontDescription.new;
FHandle^.set_family(PgChar(Family));
end;
FFontName := FHandle^.get_family;
if ALogFont.lfHeight <> 0 then
FHandle^.set_absolute_size(Abs(ALogFont.lfHeight) * PANGO_SCALE);
if ALogFont.lfItalic > 0 then
FHandle^.set_style(PANGO_STYLE_ITALIC);
FHandle^.set_weight(TPangoWeight(ALogFont.lfWeight));
if Stretch <> PANGO_STRETCH_NORMAL then
FHandle^.set_stretch(Stretch);
if (ALogFont.lfWeight = FW_DONTCARE) or
(ALogFont.lfWeight = FW_NORMAL) or
((ALogFont.lfWeight = FW_BOLD) and (Weight >= PANGO_WEIGHT_SEMIBOLD)) then
FHandle^.set_weight(TPangoWeight(Weight))
else
FHandle^.set_weight(TPangoWeight(ALogFont.lfWeight));
FLayout := pango_layout_new(AContext);
FLayout^.set_font_description(FHandle);

69
lcl/interfaces/gtk3/gtk3procs.pas
View File

@ -350,6 +350,11 @@ function PANGO_PIXELS(d:integer):integer; inline;
function GetStyleWidget(aStyle: TLazGtkStyle): PGtkWidget;
procedure ReleaseAllStyles;
procedure ExtractPangoFontFaceSuffixes(var AFontName: string; out AStretch: TPangoStretch; out AWeight: TPangoWeight);
function AppendPangoFontFaceSuffixes(AFamilyName: string; AStretch: TPangoStretch; AWeight: TPangoWeight): string;
function PangoFontHasItalicFace(AContext: PPangoContext; const AFamilyName: String): Boolean;
function GetPangoFontDefaultStretch(const AFamilyName: string): TPangoStretch;
implementation
uses LCLProc, gtk3objects, LazLogger;
@ -358,6 +363,70 @@ begin
Result:=((d + 512) shr 10);
end;
procedure ExtractPangoFontFaceSuffixes(var AFontName: string; out AStretch: TPangoStretch; out AWeight: TPangoWeight);
var
stretch, weight: integer;
begin
ExtractFontFaceSuffixes(AFontName, stretch, weight);
AStretch := TPangoStretch(stretch);
AWeight := TPangoWeight(weight);
end;
function AppendPangoFontFaceSuffixes(AFamilyName: string; AStretch: TPangoStretch;
AWeight: TPangoWeight): string;
var
stretch: integer;
begin
if AStretch < PANGO_STRETCH_ULTRA_CONDENSED then
stretch := FONT_STRETCH_ULTRA_CONDENSED
else if AStretch > PANGO_STRETCH_ULTRA_EXPANDED then
stretch := FONT_STRETCH_ULTRA_EXPANDED
else
stretch := integer(AStretch);
result := AppendFontFaceSuffixes(AFamilyName, stretch, integer(AWeight));
end;
function PangoFontHasItalicFace(AContext: PPangoContext; const AFamilyName: String): Boolean;
var
families: PPPangoFontFamily;
faces: PPPangoFontFace;
num_families, num_faces, i, j: Integer;
fontFamily: PPangoFontFamily;
hasOblique, hasItalic: boolean;
desc: PPangoFontDescription;
begin
Result := False;
AContext^.list_families(@families, @num_families);
for i := 0 to num_families - 1 do
begin
fontFamily := families[i];
if StrComp(fontFamily^.get_name, PChar(AFamilyName)) = 0 then
begin
fontFamily^.list_faces(@faces, @num_faces);
for j := 0 to num_faces - 1 do
begin
desc := faces[j]^.describe;
if desc^.get_style = PANGO_STYLE_ITALIC then
begin
Result := True;
Break;
end;
end;
g_free(faces);
end;
if Result then Break;
end;
g_free(families);
end;
function GetPangoFontDefaultStretch(const AFamilyName: string): TPangoStretch;
begin
result := TPangoStretch(GetFontFamilyDefaultStretch(AFamilyName));
end;
function TGdkRGBAToTColor(const value: TGdkRGBA; IgnoreAlpha: Boolean): TColor;
begin
Result := Trunc(value.red * $FF)

89
lcl/interfaces/gtk3/gtk3widgets.pas
View File

@ -3149,27 +3149,42 @@ procedure TGtk3Widget.SetLclFont(const AFont:TFont);
var
AGtkFont: PPangoFontDescription;
APangoStyle: TPangoStyle;
Family: String;
Stretch: TPangoStretch;
Weight: TPangoWeight;
begin
if not IsWidgetOk then exit;
if IsFontNameDefault(AFont.Name) then
begin
AGtkFont := Self.Font;
Stretch := PANGO_STRETCH_NORMAL;
Weight := PANGO_WEIGHT_NORMAL;
end else
begin
AGtkFont := pango_font_description_from_string(PgChar(AFont.Name));
{%H-}AGtkFont^.set_family(PgChar(AFont.Name));
Family := AFont.Name;
ExtractPangoFontFaceSuffixes(Family, Stretch, Weight);
AGtkFont := TPangoFontDescription.new;
AGtkFont^.set_family(PgChar(Family));
end;
if Stretch <> PANGO_STRETCH_NORMAL then
AGtkFont^.set_stretch(Stretch);
if AFont.Size <> 0 then
AGtkFont^.set_size(Abs(AFont.Size) * PANGO_SCALE);
if (fsBold in AFont.Style) and (Weight < PANGO_WEIGHT_SEMIBOLD) then
// bold is specified by the fsBold flag only
AGtkFont^.set_weight(PANGO_WEIGHT_BOLD)
else if (Weight <> PANGO_WEIGHT_NORMAL) then
AGtkFont^.set_weight(Weight);
if fsItalic in AFont.Style then
APangoStyle := PANGO_STYLE_ITALIC
else
APangoStyle := PANGO_STYLE_NORMAL;
AGtkFont^.set_style(APangoStyle);
if fsBold in AFont.Style then
AGtkFont^.set_weight(PANGO_WEIGHT_BOLD);
Font := AGtkFont;
FontColor := AFont.Color;
end;
@ -9857,8 +9872,54 @@ end;
{ TGtk3FontSelectionDialog }
procedure TGtk3FontSelectionDialog.InitializeWidget;
var
fnt:TFont;
pch:PgtkFontChooser;
fontDesc: PPangoFontDescription;
family: String;
stretch: TPangoStretch;
weight: TPangoWeight;
begin
fWidget:=TGtkFontChooserDialog.new(PChar(CommonDialog.Title),nil);
fontDesc := TPangoFontDescription.new;
try
fnt:=TFontDialog(CommonDialog).Font;
if fnt.Size = 0 then
FontDesc^.set_size(10 * PANGO_SCALE)
else
FontDesc^.set_size(fnt.Size * PANGO_SCALE);
family := fnt.Name;
ExtractPangoFontFaceSuffixes(family, stretch, weight);
fontDesc^.set_family(PChar(family));
if (fsBold in fnt.Style) and (weight < PANGO_WEIGHT_SEMIBOLD) then
// bold is specified by the fsBold flag only
fontDesc^.set_weight(PANGO_WEIGHT_BOLD)
else
fontDesc^.set_weight(weight);
if fsItalic in fnt.Style then
begin
// we need to specify the exact style for the font dialog
if PangoFontHasItalicFace(fWidget^.get_pango_context, family) then
fontDesc^.set_style(PANGO_STYLE_ITALIC)
else
fontDesc^.set_style(PANGO_STYLE_OBLIQUE);
end
else
fontDesc^.set_style(PANGO_STYLE_NORMAL);
if (stretch = PANGO_STRETCH_NORMAL) then
fontDesc^.set_stretch(GetPangoFontDefaultStretch(family))
else
fontDesc^.set_stretch(stretch);
pch:=PGtkFontChooser(fWidget);
pch^.set_font_desc(fontDesc);
finally
fontDesc^.free;
end;
inherited InitializeWidget;
end;
@ -9868,9 +9929,8 @@ var
pch:PgtkFontChooser;
pfc:PPangoFontFace;
pfd:PPangoFontDescription;
sz:integer;
sface,sfamily:string;
fnts:TfontStyles;
family: Pgchar;
begin
if resp_id=GTK_RESPONSE_OK then
begin
@ -9880,20 +9940,19 @@ begin
pfd:=pfc^.describe;
{ this stuff is implemened in gtk3objects.Tgtk3Font.UpdateLogFont
so this is backward mapping of properties }
sfamily:=pfd^.get_family();
sface:=lowercase(pfc^.get_face_name());
sz:=pch^.get_font_size() div PANGO_SCALE;
fnt.Name:=sfamily;
fnt.Size:=sz;
family := pfd^.get_family();
fnt.Name:=AppendPangoFontFaceSuffixes(family, pfd^.get_stretch, pfd^.get_weight);
fnt.Size:=pch^.get_font_size() div PANGO_SCALE;
fnts:=[];
if (pos('bold',sface)>0) then
include(fnts,fsBold);
if pfd^.get_weight >= PANGO_WEIGHT_SEMIBOLD then
include(fnts,fsBold);
if (pos('italic',sface)>0) then
// do not differentiate oblique and italic
if (pfd^.get_style >= PANGO_STYLE_OBLIQUE) then
include(fnts,fsItalic);
fnt.Style:=fnts;
end;
Result:=inherited response_handler(resp_id);
end;

149
lcl/lclproc.pas
View File

@ -225,6 +225,10 @@ function ClassCase(const AClass: TClass; const ACase: array of TClass; const ADe
// Font
function IsFontNameDefault(const AName: string): boolean; inline;
procedure ExtractFontFaceSuffixes(var AFontName: string; out AStretch: integer; out AWeight: integer);
function ExtractFontWeightSuffix(var AFontName: string; out AWeight: integer): boolean;
function AppendFontFaceSuffixes(AFamilyName: string; AStretch: integer; AWeight: integer): string;
function GetFontFamilyDefaultStretch(const AFamilyName: string): integer;
// Help
procedure AddCmdLineParamDesc(var aText: TStringList; aParamOpts: array of string; aDescr: string);
@ -1510,6 +1514,151 @@ begin
Result := CompareText(AName, 'default') = 0;
end;
function PeekFontSuffix(AFontName: string; out ASuffix: string): boolean;
var
index: SizeInt;
begin
index := length(AFontName);
while index > 0 do
begin
if AFontName[index] in [#0..' '] then
begin
ASuffix := copy(AFontName, index+1, length(AFontName)-index);
exit(length(ASuffix) > 0);
end;
dec(index);
end;
ASuffix := '';
result := false;
end;
function ExtractFontSuffix(var AFontName: string; const ASuffix: string): boolean;
begin
if (length(AFontName) > length(ASuffix)) and
AFontName.EndsWith(ASuffix, true) and
(AFontName[length(AFontName) - length(ASuffix)] in [#0..' ']) then
begin
AFontName := copy(AFontName, 1, length(AFontName) - length(ASuffix) - 1).TrimRight;
exit(true);
end;
exit(false);
end;
function ExtractFontStrecthSuffix(var AFontName: string; out AStretch: integer): boolean;
var stretch, count: integer;
suffix: String;
begin
AFontName := AFontName.TrimRight;
for stretch := low(FontStretchNames) to high(FontStretchNames) do
if (stretch <> FONT_STRETCH_NORMAL) and
ExtractFontSuffix(AFontName, FontStretchNames[stretch]) then
begin
AStretch := stretch;
exit(true);
end;
if (length(AFontName) >= LF_FACESIZE - 1) and PeekFontSuffix(AFontName, suffix) then
begin
// try to guess from truncated suffix
count := 0;
for stretch := low(FontStretchNames) to high(FontStretchNames) do
begin
if FontStretchNames[stretch].StartsWith(suffix, true) then
begin
AStretch := stretch;
inc(count);
end;
end;
// if only one suffix matches
if (count = 1) and ExtractFontSuffix(AFontName, suffix) then
begin
exit(true);
end;
end;
AStretch := FONT_STRETCH_NORMAL;
exit(false);
end;
function ExtractFontWeightSuffix(var AFontName: string; out AWeight: integer): boolean;
var
i, count: Integer;
suffix: String;
begin
AFontName := AFontName.TrimRight;
for i := 0 to high(FontWeightValueNames) do
if ExtractFontSuffix(AFontName, FontWeightValueNames[i].Name) then
begin
AWeight := FontWeightValueNames[i].Value;
exit(true);
end;
if (length(AFontName) >= LF_FACESIZE - 1) and PeekFontSuffix(AFontName, suffix) then
begin
// try to guess from truncated suffix
count := 0;
for i := 0 to high(FontWeightValueNames) do
begin
if FontWeightValueNames[i].Name.StartsWith(suffix, true) then
begin
AWeight := FontWeightValueNames[i].Value;
inc(count);
end;
end;
// if only one suffix matches
if (count = 1) and ExtractFontSuffix(AFontName, suffix) then
begin
exit(true);
end;
end;
AWeight := FW_NORMAL;
exit(false);
end;
procedure ExtractFontFaceSuffixes(var AFontName: string; out AStretch: integer; out AWeight: integer);
var
foundWeight: Boolean;
begin
foundWeight := ExtractFontWeightSuffix(AFontName, AWeight);
if ExtractFontStrecthSuffix(AFontName, AStretch) then
begin
if not foundWeight then
begin
// accept weight after or before stretch specifier
ExtractFontWeightSuffix(AFontName, AWeight);
end;
end;
end;
function AppendFontFaceSuffixes(AFamilyName: string; AStretch: integer;
AWeight: integer): string;
var
weightSuffix: String;
begin
result := AFamilyName;
// stretch is generally specified before weight
if (AStretch <> FONT_STRETCH_NORMAL) and (AStretch >= low(FontStretchNames))
and (AStretch <= high(FontStretchNames)) then
begin
if (AStretch <> GetFontFamilyDefaultStretch(AFamilyName)) then
result := result + ' ' + FontStretchNames[AStretch];
end;
// bold is not added as a suffix in the font name because if is a font style
if (AWeight <> FW_NORMAL) and (AWeight <> FW_BOLD) then
begin
weightSuffix := FontWeightToStr(integer(AWeight), '');
if (weightSuffix <> '') and (weightSuffix <> FontWeightToStr(FW_BOLD)) then
result := result + ' ' + weightSuffix;
end;
end;
function GetFontFamilyDefaultStretch(const AFamilyName: string): integer;
begin
if AFamilyName.EndsWith(' Narrow', true) then
result := FONT_STRETCH_SEMI_CONDENSED
else
result := FONT_STRETCH_NORMAL;
end;
procedure AddCmdLineParamDesc(var aText: TStringList; aParamOpts: array of string; aDescr: string);
var
i: Integer;

64
lcl/lcltype.pp
View File

@ -1544,18 +1544,64 @@ const
FW_THIN = 100;
FW_EXTRALIGHT = 200;
FW_LIGHT = 300;
FW_SEMILIGHT = 350;
FW_NORMAL = 400;
FW_MEDIUM = 500;
FW_SEMIBOLD = 600;
FW_BOLD = 700;
FW_EXTRABOLD = 800;
FW_HEAVY = 900;
FW_HAIRLINE = FW_THIN;
FW_ULTRALIGHT = FW_EXTRALIGHT;
FW_REGULAR = FW_NORMAL;
FW_DEMIBOLD = FW_SEMIBOLD;
FW_ULTRABOLD = FW_EXTRABOLD;
FW_BLACK = FW_HEAVY;
FontWeightValueNames: array[0..13] of record
Value: integer;
Name: string;
end = (
(Value:FW_THIN; Name:'Thin'),
(Value:FW_HAIRLINE; Name:'HairLine'),
(Value:FW_EXTRALIGHT; Name:'ExtraLight'),
(Value:FW_ULTRALIGHT; Name:'UltraLight'),
(Value:FW_LIGHT; Name:'Light'),
(Value:FW_SEMILIGHT; Name:'SemiLight'),
(Value:FW_MEDIUM; Name:'Medium'),
(Value:FW_SEMIBOLD; Name:'SemiBold'),
(Value:FW_DEMIBOLD; Name:'DemiBold'),
(Value:FW_DEMIBOLD; Name:'Demi'),
(Value:FW_BOLD; Name:'Bold'),
(Value:FW_EXTRABOLD; Name:'ExtraBold'),
(Value:FW_ULTRABOLD; Name:'UltraBold'),
(Value:FW_HEAVY; Name:'Heavy')
// "black" is considered part of the font name rather than a weight
);
FONT_STRETCH_ULTRA_CONDENSED = 0;
FONT_STRETCH_EXTRA_CONDENSED = 1;
FONT_STRETCH_CONDENSED = 2;
FONT_STRETCH_SEMI_CONDENSED = 3;
FONT_STRETCH_NORMAL = 4;
FONT_STRETCH_SEMI_EXPANDED = 5;
FONT_STRETCH_EXPANDED = 6;
FONT_STRETCH_EXTRA_EXPANDED = 7;
FONT_STRETCH_ULTRA_EXPANDED = 8;
FontStretchNames: array[FONT_STRETCH_ULTRA_CONDENSED..FONT_STRETCH_ULTRA_EXPANDED] of string =
(
'UltraCondensed', // 0
'ExtraCondensed', // 1
'Condensed', // 2
'SemiCondensed', // 3
'Normal', // 4
'SemiExpanded', // 5
'Expanded', // 6
'ExtraExpanded', // 7
'UltraExpanded' // 8
);
FOUNDRYCHAR_OPEN = '['; // added for support foundry encoded in family name
FOUNDRYCHAR_CLOSE = ']'; // also needed to drop foundry when creating font in windows
@ -3007,6 +3053,7 @@ function MulDiv(nNumber, nNumerator, nDenominator: Integer): Integer;
function KeyToShortCut(const Key: Word; const Shift: TShiftState): TShortCut;
function CharSetToString(const Charset: Integer): String;
function StringToCharset(Charset: string): byte;
function FontWeightToStr(AWeight: integer; ADefault: string = ''): string;
implementation
@ -3289,6 +3336,23 @@ begin
end;
function FontWeightToStr(AWeight: integer; ADefault: string = ''): string;
var
i, minDistance, distance: Integer;
begin
minDistance := MaxLongInt;
result := ADefault;
for i := 0 to high(FontWeightValueNames) do
begin
distance := abs(AWeight - FontWeightValueNames[i].Value);
if distance < minDistance then
begin
minDistance := distance;
result := FontWeightValueNames[i].Name;
end;
end;
end;
{ TListWithEvent }
procedure TListWithEvent.Notify(Ptr: Pointer; AnAction: TListNotification);