Patch from Giuliano Colla for improved non-native CustomDrawn font support + many changes from myself to make the patch more generic and usable in any CustomDrawn backend

git-svn-id: trunk@35879 -
This commit is contained in:
sekelsenmat 2012-03-11 10:02:15 +00:00
parent fdbe3b2eef
commit 4e9f3123b1
10 changed files with 334 additions and 57 deletions

View File

@ -32,10 +32,11 @@
{$endif}
// Default options for various backends
{$if defined(CD_Android) or defined(CD_Windows)}
{$define CD_UseNativeText}
{$endif}
{$if defined(CD_Android)}
{$define CD_UseNativeText}
{$define CD_HasNativeSelectItemDialog}
{$endif}
{$if defined(CD_WINDOWS)}
//{$define CD_UseNativeText}
{$endif}

View File

@ -45,7 +45,7 @@ uses
fileutil, lazutf8,
{$ifndef CD_UseNativeText}
// LazFreeType
LazFreeTypeIntfDrawer, LazFreeType, EasyLazFreeType,
LazFreeTypeIntfDrawer, LazFreeType, EasyLazFreeType, IniFiles,
{$endif}
// Widgetset
customdrawnproc,
@ -184,6 +184,15 @@ type
// For generic methods added in customdrawn
// They are used internally in LCL-CustomDrawn, LCL app should not use them
public
{$ifndef CD_UseNativeText}
// Font Path List
FFontPaths: TstringList;
FFontList: THashedStringList;
// default fonts availability
LiberationFont: Boolean;
LuxiFont: Boolean;
{$endif}
//
DefaultFontSize: Integer;
//
AccumulatedStr: string;
@ -212,6 +221,8 @@ type
//
procedure BackendCreate;
procedure BackendDestroy;
//
procedure GenericAppInit;
public
// ScreenDC and Image for doing Canvas operations outside the Paint event
// and also for text drawing operations

View File

@ -81,8 +81,16 @@ begin
end;
end;
procedure TCDWidgetSet.GenericAppInit;
begin
{$ifndef CD_UseNativeText}
// if it's the first time, we must create the list
if FFontPaths.Count = 0 then BackendListFontPaths(FFontPaths, FFontList);
{$endif}
end;
{------------------------------------------------------------------------------
Method: TQtWidgetSet.Create
Method: TCDWidgetSet.Create
Params: None
Returns: Nothing
@ -96,6 +104,12 @@ begin
FTerminating := False;
DefaultFontSize := 10;
{$ifndef CD_UseNativeText}
FFontPaths:= TStringList.Create;
FFontList := THashedStringList.Create;
FFontList.CaseSensitive:= False;
{$endif}
BackendCreate;
end;
@ -110,6 +124,11 @@ destructor TCDWidgetSet.Destroy;
begin
BackendDestroy;
{$ifndef CD_UseNativeText}
FFontPaths.Free;
FFontList.Free;
{$endif}
CDWidgetSet := nil;
inherited Destroy;
end;

View File

@ -258,6 +258,8 @@ begin
// Thread.Synchronize support
//WakeMainThread := @HandleWakeMainThread;
GenericAppInit();
end;
procedure TCDWidgetSet.AppRun(const ALoop: TApplicationMainLoop);

View File

@ -99,7 +99,7 @@ begin
end;
{------------------------------------------------------------------------------
Method: TWinCEWidgetSet.AppInit
Method: TCDWidgetSet.AppInit
Params: None
Returns: Nothing
@ -136,7 +136,10 @@ begin
if InputContext = nil then DebugLn('[TCDWidgetSet.BackendInit] Failed to initialize the Keyboard handling!');
//
// Initialize ScreenInfo
ScreenInfo.PixelsPerInchX:= 96;
ScreenInfo.PixelsPerInchY:= 96;
ScreenInfo.Initialized:= True;
//if (not (woX11SkipWMHints in WindowOptions)) and (woWindow in WindowOptions) then
//begin
@ -152,6 +155,9 @@ begin
// Add watches to the XConnection
XAddConnectionWatch(FDisplay, @MyXConnectionWatchProc, nil);
// Generic code
GenericAppInit();
end;
procedure TCDWidgetSet.AppRun(const ALoop: TApplicationMainLoop);
@ -539,6 +545,7 @@ procedure TCDWidgetSet.AppSetMainFormOnTaskBar(const DoSet: Boolean);
begin
end;
{------------------------------------------------------------------------------
function: CreateTimer
Params: Interval:

View File

@ -10,6 +10,10 @@ uses
fpimage, fpcanvas, Math,
// LazUtils
fileutil,
{$ifndef CD_UseNativeText}
// LazFreeType
LazFreeTypeIntfDrawer, LazFreeType, EasyLazFreeType, IniFiles,
{$endif}
// Custom Drawn Canvas
IntfGraphics, lazcanvas, lazregions,
// LCL
@ -158,7 +162,11 @@ function FindTimerWithNativeHandle(ANativeHandle: PtrInt): TCDTimer;
// Font choosing routines
{$ifndef CD_UseNativeText}
procedure VerifyAndCleanUpFontDirectories(AFontDirectories: TStringList);
procedure FontsScanForTTF(APath: string; var AFontTable: THashedStringList);
procedure FontsScanDir(APath: string; var AFontPaths: TStringList; var AFontList: THashedStringList);
{$endif}
implementation
@ -697,6 +705,7 @@ begin
end;
end;
{$ifndef CD_UseNativeText}
procedure VerifyAndCleanUpFontDirectories(AFontDirectories: TStringList);
var
i, j: Integer;
@ -735,6 +744,128 @@ begin
raise Exception.Create('[VerifyAndCleanUpFontDirectories] After cleaning up no font directories were found.');
end;
{------------------------------------------------------------------------------
Procedure: BackendScanForTTF - Scope=local
Params: APath - path for a font directory
AFontTable - Font name to Font path Hashed List
Scan a directory for ttf fonts and updates the FontTable
------------------------------------------------------------------------------}
procedure FontsScanForTTF(APath: string; var AFontTable: THashedStringList);
var
Rslt: TSearchRec;
AFace: TT_Face;
ErrNum: TT_Error;
I,J: Integer;
FontPath: String;
NameCount: Integer;
NameString: Pchar;
NameLen: Integer;
Platform,Encoding,Language: Integer;
NameID: Integer;
AName: String;
{$ifdef CD_Debug_TTF}
DebugList: TstringList;
{$endif}
begin
I:= FindFirstUTF8(APath+'*.ttf',faAnyFile,Rslt);
{$ifdef CD_Debug_TTF}
DebugList:= TStringList.Create;
{$endif}
while I >= 0 do
begin
FontPath:= APath+Rslt.Name;
ErrNum:= TT_Open_Face(FontPath,AFace);
if ErrNum = TT_Err_Ok then
begin
NameCount:= TT_Get_Name_Count(AFace);
for J:= 0 to NameCount-1 do
begin
ErrNum:= TT_Get_Name_ID(AFace,J,Platform,Encoding,Language,NameID);
{ -------------------------------------------------------------------
NameID: 0= Copyright
1= Font Family (e.g. Arial, Times, Liberation )
2= Font Subfamily (e.g. Bold, Italic, Condensed)
3= Unique Font Identifier
4= Full Name - Human readable - the one used by the IDE
-----------------------------------------------------------------------}
{$ifdef CD_Debug_TTF}
if ErrNum = TT_Err_Ok then
begin
ErrNum:= TT_Get_Name_String(AFace,J,NameString,NameLen);
AName:= NameString;
if NameString <> '' then //DBG
begin
SetLength(AName,NameLen);
DebugList.Add('ID='+IntToStr(NameID)+' '+AName);
end
else DebugList.Add('ID='+IntToStr(NameID)+' '+'<Empty String>');
end;
{$endif}
if (ErrNum = TT_Err_Ok) and (NameID = 4) then begin
ErrNum:= TT_Get_Name_String(AFace,J,NameString,NameLen);
AName:= NameString;
// Skip empty entries
if NameString <> '' then begin
SetLength(AName,NameLen);
AFontTable.Add(AName+'='+FontPath);
end;
end;
end;
TT_Close_Face(AFace);
end;
{$ifdef CD_Debug_TTF}
DebugList.Add('------');
{$endif}
ErrNum:= TT_Close_Face(AFace);
I:= FindNextUTF8(Rslt);
end;
FindCloseUTF8(Rslt);
{$ifdef CD_Debug_TTF}
AName:= ExtractFileDir(Apath);
AName:= ExtractFileName(AName) + '.txt';
DebugList.SaveToFile('/tmp/'+AName);
DebugList.Free;
{$endif}
end;
{------------------------------------------------------------------------------
Procedure: BackendScanDir - Scope=Local
Params: APath - path for a font directory
AFontPaths - Font path List
Recursively scans font directories to find the ones populated only
by fonts
------------------------------------------------------------------------------}
procedure FontsScanDir(APath: string; var AFontPaths: TStringList; var AFontList: THashedStringList);
var
NextPath: string;
Rslt: TSearchRec;
I: Integer;
DirFound,DirEmpty: Boolean;
TmpList: THashedStringList;
begin
DirFound:= False;
DirEmpty:= True;
I:= FindFirstUTF8(APath+'*',faAnyFile,Rslt);
while I >= 0 do begin
if (Rslt.Name <> '.') and (Rslt.Name <> '..') then begin
DirEmpty:= False;
if (Rslt.Attr and faDirectory) <> 0 then begin
NextPath:= APath + Rslt.Name + PathDelim;
DirFound:= true;
FontsScanDir(NextPath,AFontPaths,AFontList);
end;
end;
I:= FindNextUTF8(Rslt);
end;
FindCloseUTF8(Rslt);
if (not DirFound) and (not DirEmpty) then begin
AFontPaths.Add(APath);
end;
end;
{$endif}
{ TCDBitmap }
destructor TCDBitmap.Destroy;

View File

@ -2212,6 +2212,8 @@ begin
FreeFTFont := True;
end;
try
ftFont.SizeInPoints:= lFontSize;
lFontSize:= MulDiv(lFontSize,72,ftFont.DPI); // convert points to pixels
RealX := X + lDestCanvas.WindowOrg.X + lDestCanvas.BaseWindowOrg.X;
RealY := Y + lDestCanvas.WindowOrg.Y + lDestCanvas.BaseWindowOrg.Y + lFontSize;
FTDrawer.DrawText(Str, ftFont, RealX, RealY, colBlack, 255);

View File

@ -881,9 +881,49 @@ begin
{$else}
Result := Windows.CreateFontIndirect(@TempLogFont);
{$endif}
end;*)
{$ifndef CD_UseNativeText}
procedure TCDWidgetSet.BackendListFontPaths(var AFontPaths: TStringList; var AFontList: THashedStringList);
var
lWinFontPath: array[0..MAX_PATH] of WideChar;
lPasWinFontPath: string;
begin
// First C:\Windows\Fonts
Windows.GetWindowsDirectoryW(@lWinFontPath[0], MAX_PATH);
lPasWinFontPath := lWinFontPath;
lPasWinFontPath := IncludeTrailingPathDelimiter(lPasWinFontPath) + 'Fonts';
FontsScanDir(lPasWinFontPath, AFontPaths, AFontList);
end;
{------------------------------------------------------------------------------
function TCDWidgetSet.BackendGetFontPath(const LogFont: TLogFont; const LongFontName: string): string;
var
i: Integer;
Str: String;
AFontName: String;
begin
// First look if font name matches a stored name
// but replace generic with reasonable default
AFontName:= '';
if LowerCase(LongFontName) = 'default' then AFontName:= 'Arial'
else if LowerCase(LongFontName) = 'sans' then AFontName:= 'Arial'
else if LowerCase(LongFontName) = 'serif' then AFontName:= 'Times New Roman'
else AFontName:= LongFontName;
str := FFontList.Values[AFontName];
if str <> '' then begin
Result:= str;
exit;
end;
// Here font name wasn't found - Carry on educated guesses
// No luck - Nothing was found
raise Exception.Create('[BackendGetFontPath] Unable to find a suitable font to replace '+LongFontName);
end;
{$endif}
(*{------------------------------------------------------------------------------
Method: CreateIconIndirect
Params: IconInfo - pointer to Icon/Cursor Information record
Returns: handle to a created icon/cursor

View File

@ -631,12 +631,13 @@ begin
end;*)
{$ifndef CD_UseNativeText}
procedure TCDWidgetSet.BackendListFontPaths(var AFontPaths: TStringList);
procedure TCDWidgetSet.BackendListFontPaths(var AFontPaths: TStringList; var AFontList: THashedStringList);
var
Doc: TXMLDocument;
lFontDirectories: TStringList;
i, FontsCount: cint;
i,j, FontsCount: cint;
lXFontPath: PPChar;
APath,strTmp: string;
XMLFontConfig, XMLDir: TDOMNode;
XMLFontConfigChilds: TDOMNodeList;
const
@ -644,8 +645,13 @@ const
begin
// First paths from X11
lXFontPath := XGetFontPath(FDisplay, @FontsCount);
for i := 0 to FontsCount-1 do
AFontPaths.Add(lXFontPath[i]);
for i:= 0 to FontsCount-1 do begin
if Copy(lXFontPath[i],1,10) = 'catalogue:' then
APath:= PathDelim + Copy(lXFontPath[0],12,strlen(lXFontPath[0]))+ PathDelim
else
APath:= lXFontPath[i] + PathDelim;
FontsScanDir(APath,AFontPaths,AFontList);
end;
XFreeFontPath(lXFontPath);
// Paths from the global config file
@ -659,51 +665,104 @@ begin
XMLFontConfigChilds := XMLFontConfig.ChildNodes;
for i := 0 to XMLFontConfigChilds.Count-1 do
if UTF8CompareText(XMLFontConfigChilds.Item[i].NodeName, 'dir') = 0 then
AFontPaths.Add(XMLFontConfigChilds.Item[i].FirstChild.NodeValue);
FontsScanDir(XMLFontConfigChilds.Item[i].FirstChild.NodeValue,AFontPaths,AFontList);
end;
finally
XMLFontConfig.Free;
Doc.Free;
end;
end;
// Add a good standards too in case the list is empty
AFontPaths.Add('/usr/share/fonts/');
AFontPaths.Add('/usr/lib/X11/fonts/');
AFontPaths.Add('/usr/X11R6/lib/X11/fonts/');
AFontPaths.Add('/opt/ttfonts/');
AFontPaths.Add('/usr/share/fonts/TTF/liberation/');
// Add a good standards too in case the X server is remote, or something is missing
FontsScandir('/usr/share/fonts/',AFontPaths,AFontList);
FontsScandir('/usr/share/X11/fonts/',AFontPaths,AFontList);
FontsScandir('/usr/lib/X11/fonts/',AFontPaths,AFontList);
FontsScandir('/usr/X11R6/lib/X11/fonts/',AFontPaths,AFontList);
FontsScandir('/opt/ttfonts/',AFontPaths,AFontList);
FontsScandir(GetEnvironmentVariable('HOME')+'/.fonts/',AFontPaths,AFontList);
// Now clear up the list, make sure all paths end with a path delim, etc
VerifyAndCleanUpFontDirectories(AFontPaths);
// We have populated FontPaths, now we may build the font list
if AFontPaths.Count <> 0 then for i:= 0 to AFontPaths.Count -1 do begin;
APath:= AFontPaths[i];
FontsScandirScanForTTF(APath,AFontList);
end;
// default for recent distros
if lFontList.Values['Liberation Sans'] <> '' then LiberationFont:= True
else LiberationFont:= False;
// default for older distros
if lFontList.Values['Luxi Sans Regular'] <> '' then LuxiFont:= True
else LuxiFont:= False;
{$ifdef Debug_TTF}
AFontPaths.SaveToFile('/tmp/lxfontpaths.txt');
AFontList.Sort;
AFontList.SaveToFile('/tmp/lxfontlist.txt');
{$endif}
end;
function TCDWidgetSet.BackendGetFontPath(const LogFont: TLogFont; const LongFontName: string): string;
var
lFontPaths: TStringList;
i: Integer;
Str: String;
AFontName: String;
begin
lFontPaths := TStringList.Create;
try
BackendListFontPaths(lFontPaths);
// Classify and choose the fonts
// ToDo
// Fallback: Search for known fallback fonts
for i := 0 to lFontPaths.Count -1 do
begin
Str := lFontPaths.Strings[i] + 'LiberationSans-Regular.ttf';
if FileExistsUTF8(Str) then
begin
Result := Str;
Break;
end;
end;
finally
lFontPaths.Free;
// First look if font name matches a stored name
// but replace generic with reasonable default
AFontName:= '';
if LiberationFont then begin
if LowerCase(LongFontName) = 'default' then AFontName:= 'Liberation Sans'
else if LowerCase(LongFontName) = 'sans' then AFontName:= 'Liberation Sans'
else if LowerCase(LongFontName) = 'serif' then AFontName:= 'Liberation Serif'
else AFontName:= LongFontName;
end
else if LuxiFont then begin
if LowerCase(LongFontName) = 'default' then AFontName:= 'Luxi Sans Regular'
else if LowerCase(LongFontName) = 'sans' then AFontName:= 'Luxi Sans Regular'
else if LowerCase(LongFontName) = 'serif' then AFontName:= 'Luxi Serif Regular'
else AFontName:= LongFontName;
end;
If AFontName = '' then AFontName:= LongFontName; // neither Liberation nor Luxi, but maybe we're lucky
str := lFontList.Values[AFontName];
if str <> '' then begin
Result:= str;
exit;
end;
// Here font name wasn't found - Carry on educated guesses
// Classify and choose the fonts
// ToDo
// Fallback: Search for known fallback fonts
AFontName:= '';
If LiberationFont then begin
if pos('sans',LowerCase(LongFontName)) <> 0 then AFontName:='Liberation Sans'
else if pos('serif',LowerCase(LongFontName)) <> 0 then AFontName:='Liberation Serif'
else if pos('mono',LowerCase(LongFontName)) <> 0 then AFontName:='Liberation Mono'
else if pos('bold',LowerCase(LongFontName)) <> 0 then AFontName:='Liberation Sans Bold'
else AFontName:= 'Liberation Sans';
end
else if LuxiFont then begin
if pos('sans',LowerCase(LongFontName)) <> 0 then AFontName:='Luxi Sans Regular'
else if pos('serif',LowerCase(LongFontName)) <> 0 then AFontName:='Luxi Serif Regular'
else if pos('mono',LowerCase(LongFontName)) <> 0 then AFontName:='Luxi Mono Regular'
else if pos('bold',LowerCase(LongFontName)) <> 0 then AFontName:='Luxi Sans Bold'
else AFontName:= 'Luxi Sans Regular';
end;
str := lFontList.Values[AFontName];
if str <> '' then begin
Result:= str;
exit;
end;
// No luck - Nothing was found
raise Exception.Create('[BackendGetFontPath] Unable to find a suitable font to replace '+LongFontName);
end;
{$endif}
@ -3640,7 +3699,7 @@ begin
WriteLn(Format('Trace:> [TQtWidgetSet.GetSystemMetrics] %d', [nIndex]));
{$endif}
Result := 0;
(* case nIndex of
case nIndex of
SM_ARRANGE:
begin
{$ifdef VerboseQtWinAPI}
@ -3654,7 +3713,7 @@ begin
{$endif}
end;
SM_CMONITORS:
Result := QDesktopWidget_numScreens(QApplication_desktop());
Result := 1; //QDesktopWidget_numScreens(QApplication_desktop());
SM_CMOUSEBUTTONS:
begin
//DebugLn('Trace:TODO: [TQtWidgetSet.GetSystemMetrics] --> SM_CMOUSEBUTTONS ');
@ -3662,8 +3721,9 @@ begin
SM_CXBORDER, SM_CYBORDER:
begin
// size of frame around controls
Result := QStyle_pixelMetric(QApplication_style(),
QStylePM_DefaultFrameWidth, nil, nil);
Result:= 1;
{Result := QStyle_pixelMetric(QApplication_style(),
QStylePM_DefaultFrameWidth, nil, nil);}
end;
SM_CXCURSOR:
begin
@ -3756,11 +3816,11 @@ begin
end;
SM_CXMENUSIZE:
begin
Result := QStyle_pixelMetric(QApplication_style(), QStylePM_IndicatorWidth, nil, nil);
//Result := QStyle_pixelMetric(QApplication_style(), QStylePM_IndicatorWidth, nil, nil);
end;
SM_CYMENUSIZE:
begin
Result := QStyle_pixelMetric(QApplication_style(), QStylePM_IndicatorHeight, nil, nil);
//Result := QStyle_pixelMetric(QApplication_style(), QStylePM_IndicatorHeight, nil, nil);
end;
SM_CXMIN:
begin
@ -3796,13 +3856,15 @@ begin
end;
SM_CXSCREEN:
begin
QDesktopWidget_screenGeometry(QApplication_desktop(), @R, QDesktopWidget_primaryScreen(QApplication_desktop()));
Result := R.Right - R.Left;
//QDesktopWidget_screenGeometry(QApplication_desktop(), @R, QDesktopWidget_primaryScreen(QApplication_desktop()));
//Result := R.Right - R.Left;
Result := XDisplayWidth(FDisplay,0);
end;
SM_CYSCREEN:
begin
QDesktopWidget_screenGeometry(QApplication_desktop(), @R, QDesktopWidget_primaryScreen(QApplication_desktop()));
Result := R.Bottom - R.Top;
//QDesktopWidget_screenGeometry(QApplication_desktop(), @R, QDesktopWidget_primaryScreen(QApplication_desktop()));
//Result := R.Bottom - R.Top;
Result := XDisplayHeight(FDisplay,0);
end;
SM_CXSIZE:
begin
@ -3815,7 +3877,7 @@ begin
SM_CXSIZEFRAME,
SM_CYSIZEFRAME:
begin
Result := QStyle_pixelMetric(QApplication_style(), QStylePM_MDIFrameWidth, nil, nil);
//Result := QStyle_pixelMetric(QApplication_style(), QStylePM_MDIFrameWidth, nil, nil);
end;
SM_CXSMICON,
SM_CYSMICON:
@ -3832,22 +3894,24 @@ begin
end;
SM_CXVIRTUALSCREEN:
begin
Result := QWidget_width(QApplication_desktop);
//Result := QWidget_width(QApplication_desktop);
Result := XDisplayWidth(FDisplay,0);
end;
SM_CYVIRTUALSCREEN:
begin
Result := QWidget_height(QApplication_desktop);
//Result := QWidget_height(QApplication_desktop);
Result := XDisplayHeight(FDisplay,0);
end;
SM_CXVSCROLL,
SM_CYVSCROLL,
SM_CXHSCROLL,
SM_CYHSCROLL:
begin
Result := QStyle_pixelMetric(QApplication_Style, QStylePM_ScrollBarExtent, nil, nil);
//Result := QStyle_pixelMetric(QApplication_Style, QStylePM_ScrollBarExtent, nil, nil);
end;
SM_CYCAPTION:
begin
Result := QStyle_pixelMetric(QApplication_Style, QStylePM_TitleBarHeight, nil, nil);
//Result := QStyle_pixelMetric(QApplication_Style, QStylePM_TitleBarHeight, nil, nil);
end;
SM_CYKANJIWINDOW:
begin
@ -3913,7 +3977,7 @@ begin
begin
//DebugLn('Trace:TODO: [TQtWidgetSet.GetSystemMetrics] --> SM_SWAPBUTTON ');
end;
end;*)
end;
end;
(*{------------------------------------------------------------------------------

View File

@ -64,7 +64,7 @@ function CreateCompatibleDC(DC: HDC): HDC; override;
function CreateFontIndirect(const LogFont: TLogFont): HFONT; override;
function CreateFontIndirectEx(const LogFont: TLogFont; const LongFontName: string): HFONT; override;
{$ifndef CD_UseNativeText}
procedure BackendListFontPaths(var AFontPaths: TStringList);
procedure BackendListFontPaths(var AFontPaths: TStringList; var AFontList: THashedStringList);
function BackendGetFontPath(const LogFont: TLogFont; const LongFontName: string): string;
{$endif}
function CreateIconIndirect(IconInfo: PIconInfo): HICON; override;