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

lcl/interfaces/gtk2/gtk2int.pas

@@ -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
 
 {------------------------------------------------------------------------------

lcl/interfaces/gtk2/gtk2winapi.inc

@@ -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)
+      if (pango_font_description_get_weight(PangoDesc) = PANGO_WEIGHT_NORMAL) then
-        and (lfWeight <> FW_DONTCARE) then
+      begin
-        pango_font_description_set_weight(PangoDesc, lfWeight);
+        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);

lcl/interfaces/gtk2/gtk2wsdialogs.pp

@@ -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);

lcl/interfaces/gtk3/gtk3objects.pas

@@ -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);
 

lcl/interfaces/gtk3/gtk3procs.pas

@@ -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)

lcl/interfaces/gtk3/gtk3widgets.pas

@@ -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));
+    Family := AFont.Name;
-    {%H-}AGtkFont^.set_family(PgChar(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;
+    family := pfd^.get_family();
-    fnt.Name:=sfamily;
+    fnt.Name:=AppendPangoFontFaceSuffixes(family, pfd^.get_stretch, pfd^.get_weight);
-    fnt.Size:=sz;
+    fnt.Size:=pch^.get_font_size() div PANGO_SCALE;
+
     fnts:=[];
-    if (pos('bold',sface)>0) then
+    if pfd^.get_weight >= PANGO_WEIGHT_SEMIBOLD then
-      include(fnts,fsBold);
+     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;

lcl/lclproc.pas

@@ -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;

lcl/lcltype.pp

@@ -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);