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

disabled hardly used gtk FillScreenFont, this should be only done on demand, improved getting default font family for gtk

Browse Source 
git-svn-id: trunk@6221 -
This commit is contained in:
mattias 2004-11-08 19:11:55 +00:00
parent 005b18e798
commit 891b8aa58a
7 changed files with 85 additions and 34 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

11
components/codetools/memcheck.pas
View File

@ -69,14 +69,14 @@ const
{ tracing level
splitted in two if memory is released !! }
{$ifdef EXTRA}
tracesize = 16; // normal: 16
tracesize = 64; // normal: 16
{$else EXTRA}
tracesize = 32; // normal: 8
{$endif EXTRA}
{ install heaptrc memorymanager }
useheaptrace : boolean=true;
useheaptrace : boolean = true;
{ less checking }
quicktrace : boolean=true;
quicktrace : boolean = true;
{ calls halt() on error }
HaltOnError : boolean = false;
{ ExceptOnError: raise gdb catchable exception on error }
@ -359,7 +359,7 @@ begin
is_in_getmem_list:=true;
// MG: changes for codetools:
inc(i);
if i>getmem_cnt-freemem_cnt then begin
if (i>getmem_cnt-freemem_cnt) and (not keepreleased) then begin
writeln(ptext^,'error in linked list of heap_mem_info',
' FreedCnt=',getmem_cnt-freemem_cnt,' RealCnt=',i);
runerror(204);
@ -2318,6 +2318,9 @@ end.
{
$Log$
Revision 1.35 2004/11/08 19:11:55 mattias
disabled hardly used gtk FillScreenFont, this should be only done on demand, improved getting default font family for gtk
Revision 1.34 2004/10/25 17:59:29 vincents
fpc 1.9.5 has no saveregisters calling convention anymore.

7
lcl/interfaces/gtk/gtkfontcache.pas
View File

@ -112,7 +112,8 @@ end;
{ TGdkFontCache }
function CompareGdkFontWithResItem(Font: PGDKFont; Item: TGdkFontCacheItem): integer;
function CompareGdkFontWithResItem(Font: PGDKFont;
Item: TGdkFontCacheItem): integer;
begin
Result := ComparePointers(Font, Item.GdkFont);
end;
@ -121,10 +122,10 @@ function CompareLogFontAndNameWithResDesc(Key: PLogFontAndName;
Desc: TGdkFontCacheDescriptor): integer;
begin
Result:=CompareStr(Key^.LongFontName,Desc.LongFontName);
//writeln('CompareLogFontAndNameWithResDesc A ',Key^.LongFontName,' ',Desc.LongFontName,' ',HexStr(Cardinal(Desc),8),' Result=',Result);
//debugln('CompareLogFontAndNameWithResDesc A ',Key^.LongFontName,' ',Desc.LongFontName,' ',HexStr(Cardinal(Desc),8),' Result=',Result);
if Result=0 then
Result:=CompareMemRange(@Key^.LogFont,@Desc.LogFont,SizeOf(Desc.LogFont));
//writeln('CompareLogFontAndNameWithResDesc END Result=',Result);
//debugln('CompareLogFontAndNameWithResDesc END Result=',Result);
end;
procedure TGdkFontCache.RemoveItem(Item: TResourceCacheItem);

7
lcl/interfaces/gtk/gtkobject.inc
View File

@ -1511,8 +1511,8 @@ end;
------------------------------------------------------------------------------}
procedure TGtkWidgetSet.AppInit(var ScreenInfo: TScreenInfo);
begin
If Assigned(Screen) then
FillScreenFonts(Screen.Fonts);
// MG: TODO: call FillScreenFonts on demand, not for every application
//FillScreenFonts(Screen.Fonts);
InitKeyboardTables;
{ Compute pixels per inch variable }
ScreenInfo.PixelsPerInchX :=
@ -6942,6 +6942,9 @@ end;
{ =============================================================================
$Log$
Revision 1.608 2004/11/08 19:11:55 mattias
disabled hardly used gtk FillScreenFont, this should be only done on demand, improved getting default font family for gtk
Revision 1.607 2004/11/03 14:18:36 mattias
implemented preferred size for controls for theme depending AutoSizing

6
lcl/interfaces/gtk/gtkproc.inc
View File

@ -7738,9 +7738,10 @@ begin
{$IFDEF GTK1}
{$IFDEF UNIX}
theFonts := XListFonts(X11Display,PChar('-*-*-*-*-*-*-*-*-*-*-*-*-*-*'), 10000, @N);
debugln('FillScreenFonts N=',dbgs(N));
for I := 0 to N - 1 do
if theFonts[I] <> nil then begin
Tmp := ExtractFamilyFromXLFDName(AnsiString(theFonts[I]));
Tmp := ExtractFamilyFromXLFDName(theFonts[I]);
if Tmp <> '' then
if ScreenFonts.IndexOf(Tmp) < 0 then
ScreenFonts.Append(Tmp);
@ -7791,6 +7792,9 @@ end;
{ =============================================================================
$Log$
Revision 1.317 2004/11/08 19:11:55 mattias
disabled hardly used gtk FillScreenFont, this should be only done on demand, improved getting default font family for gtk
Revision 1.316 2004/11/03 14:18:36 mattias
implemented preferred size for controls for theme depending AutoSizing

50
lcl/interfaces/gtk/gtkwinapi.inc
View File

@ -1306,7 +1306,6 @@ end;
{$Else}
var
GdiObject: PGdiObject;
S: String;
FontNameRegistry, Foundry, FamilyName, WeightName,
Slant, SetwidthName, AddStyleName, PixelSize,
PointSize, ResolutionX, ResolutionY, Spacing, AverageWidth,
@ -1315,13 +1314,27 @@ var
CachedFont: TGdkFontCacheDescriptor;
function LoadFont: boolean;
var
S: string;
begin
S:=FontNameRegistry+'-'+Foundry+'-'+FamilyName+'-'+WeightName
+'-'+Slant+'-'+SetwidthName+'-'+AddStyleName+'-'+PixelSize
+'-'+PointSize+'-'+ResolutionX+'-'+ResolutionY+'-'+Spacing+'-'+AverageWidth
+'-'+CharSetRegistry+'-'+CharSetCoding;
{ MG: heaptrc gets corrupted heap using the construction below:
S := Format('%s-%s-%s-%s-%s-%s-%s-%s-%s-%s-%s-%s-%s-%s-%s',
[FontNameRegistry, Foundry, FamilyName, WeightName,
Slant, SetwidthName, AddStyleName, PixelSize,
PointSize, ResolutionX, ResolutionY, Spacing, AverageWidth,
CharSetRegistry, CharSetCoding
]);
]);}
//DebugLn(' Trying "',S,'"');
{S:=FontNameRegistry+','+Foundry+','+FamilyName+','+WeightName
+','+Slant+','+SetwidthName+','+AddStyleName+','+PixelSize
+','+PointSize+','+ResolutionX+','+ResolutionY+','+Spacing+','+AverageWidth
+','+CharSetRegistry+','+CharSetCoding;
DebugLn(' Trying B "',S,'"');}
GdiObject^.GDIFontObject := gdk_font_load(PChar(s));
Result:=GdiObject^.GDIFontObject<>nil;
@ -1331,7 +1344,7 @@ var
end;
{$IFDEF VerboseFonts}
DebugLn(' Trying "',S,'" Success=',dbgs(GdiObject^.GDIFontObject<>nil));
DebugLn(' Tried "',S,'" Success=',dbgs(GdiObject^.GDIFontObject<>nil));
{$ENDIF}
end;
@ -1347,18 +1360,36 @@ var
function GetDefaultFontFamilyName: string;
begin
Result:=GetDefaultFontName;
if IsFontNameXLogicalFontDesc(Result) then
Result := ExtractXLFDItem(LongFontName,2);
if Result='' then Result:='*';
end;
function FamilyNameExists: boolean;
var
AFont: PGdkFont;
S: String;
begin
S := '*-*-'+FamilyName+'*-*-*-*-*-*-*-*-*-*-*-*-*';
AFont:=gdk_font_load(PChar(s));
Result:=AFont<>nil;
if Result then gdk_font_unref(AFont);
end;
function CheckFontNameIsMangledXLogicalFontDesc(const ALongFontName: string
): boolean;
var
c: Integer;
i: Integer;
begin
c:=0;
for i:=1 to length(ALongFontName) do
if ALongFontName[i]='-' then inc(c);
Result:=(c>5) and (c<>14);
if Result then
debugln('WARNING: Fontnamt "',ALongFontName,'" seems to be a XLFD fontname, but has 14<>',dbgs(c),' minus signs');
end;
begin
// For info about xlfd see:
@ -1404,10 +1435,9 @@ begin
{$IFDEF VerboseFonts}
DebugLn('TGtkWidgetSet.CreateFontIndirectEx Name="',LogFont.lfFaceName,'"',
' Long="',LongFontName,'" IsXLFD=',IsFontNameXLogicalFontDesc(LongFontName)
,' ',ord(LogFont.lfFaceName[0]));
' Long="',LongFontName,'" IsXLFD=',dbgs(IsFontNameXLogicalFontDesc(LongFontName))
,' ',dbgs(ord(LogFont.lfFaceName[0])));
{$ENDIF}
S:=LongFontName;
if IsFontNameXLogicalFontDesc(LongFontName) then begin
FontNameRegistry := ExtractXLFDItem(LongFontName,0);
Foundry := ExtractXLFDItem(LongFontName,1);
@ -1424,6 +1454,7 @@ begin
AverageWidth := ExtractXLFDItem(LongFontName,12);
CharSetRegistry := ExtractXLFDItem(LongFontName,13);
CharSetCoding := ExtractXLFDItem(LongFontName,14);
end else if CheckFontNameIsMangledXLogicalFontDesc(LongFontName) then begin
end;
with LogFont do
@ -1625,8 +1656,8 @@ begin
end;
if Result = 0
then DebugLn(Format('WARNING: [TGtkWidgetSet.CreateFontIndirectEx] NOT found XLFD: <%s>', [S]))
else Assert(False, Format('Trace: [TGtkWidgetSet.CreateFontIndirectEx] found XLFD: <%s>', [S]));
then DebugLn(Format('WARNING: [TGtkWidgetSet.CreateFontIndirectEx] NOT found XLFD: <%s>', [LongFontName]))
else Assert(False, Format('Trace: [TGtkWidgetSet.CreateFontIndirectEx] found XLFD: <%s>', [LongFontName]));
end;
end;
{$EndIf}
@ -8695,6 +8726,9 @@ end;
{ =============================================================================
$Log$
Revision 1.371 2004/11/08 19:11:55 mattias
disabled hardly used gtk FillScreenFont, this should be only done on demand, improved getting default font family for gtk
Revision 1.370 2004/10/15 13:28:22 mattias
codeexplorer: using lower recursive depth

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

@ -113,7 +113,7 @@ begin
CharSetRegistry := ExtractXLFDItem(LongFontName,13);
CharSetCoding := ExtractXLFDItem(LongFontName,14);
end else
if (LongFontName <> '') and (Screen.Fonts.IndexOf(LongFontName) > 0) then
if (LongFontName <> '') {and (Screen.Fonts.IndexOf(LongFontName) > 0) }then
FamilyName := LongFontName;
with LogFont do begin
@ -830,6 +830,9 @@ end;
{ =============================================================================
$Log$
Revision 1.11 2004/11/08 19:11:55 mattias
disabled hardly used gtk FillScreenFont, this should be only done on demand, improved getting default font family for gtk
Revision 1.10 2004/08/04 15:48:44 mazen
* fix UTF8 text display in source note book

33
lcl/xmlpropstorage.pas
View File

@ -25,19 +25,19 @@ interface
{$IFNDEF VER1_0}
uses
Classes, SysUtils, Forms, PropertyStorage, XMLCfg, DOM;
Classes, SysUtils, LCLProc, Forms, PropertyStorage, XMLCfg, DOM;
type
{ TXMLPropStorage }
TPropStorageXMLConfig = class(TXMLConfig)
Public
Procedure DeleteSubNodes (const ARootNode : String);
Procedure DeleteSubNodes (const ARootNode: String);
end;
TCustomXMLPropStorage = class(TFormPropertyStorage)
private
FCount : Integer;
FCount: Integer;
FFileName: String;
FXML: TPropStorageXMLConfig;
FRootNode: String;
@ -45,17 +45,17 @@ type
protected
procedure StorageNeeded(ReadOnly: Boolean);override;
procedure FreeStorage; override;
Function GetXMLFileName : string; virtual;
Function RootSection : String; Override;
Function FixPath(const APath : String) : String; virtual;
Function GetXMLFileName: string; virtual;
Function RootSection: String; Override;
Function FixPath(const APath: String): String; virtual;
Property XMLConfig: TPropStorageXMLConfig Read FXML;
public
function DoReadString(const Section, Ident, Default: string): string; override;
function DoReadString(const Section, Ident, TheDefault: string): string; override;
procedure DoWriteString(const Section, Ident, Value: string); override;
Procedure DoEraseSections(const ARootSection: String);override;
public
property FileName : String Read FFileName Write FFileName;
property RootNodePath : String Read FRootNode Write FRootNodePath;
property FileName: String Read FFileName Write FFileName;
property RootNodePath: String Read FRootNode Write FRootNodePath;
end;
TXMLPropStorage = class(TCustomXMLPropStorage)
@ -116,7 +116,7 @@ begin
{$endif}
end;
function TCustomXMLPropStorage.FixPath(const APath : String) : String;
function TCustomXMLPropStorage.FixPath(const APath: String): String;
begin
Result:=StringReplace(APath,'.','/',[rfReplaceAll]);
@ -131,14 +131,15 @@ begin
Result:=FixPath(Result);
end;
function TCustomXMLPropStorage.DoReadString(const Section, Ident, Default: string
): string;
function TCustomXMLPropStorage.DoReadString(const Section, Ident,
TheDefault: string): string;
begin
Result:=FXML.GetValue(FixPath(Section)+'/'+Ident, Default);
Result:=FXML.GetValue(FixPath(Section)+'/'+Ident, TheDefault);
//debugln('TCustomXMLPropStorage.DoReadString Section=',Section,' Ident=',Ident,' Result=',Result);
end;
procedure TCustomXMLPropStorage.DoWriteString(const Section, Ident, Value: string);
procedure TCustomXMLPropStorage.DoWriteString(const Section, Ident,
Value: string);
begin
//debugln('TCustomXMLPropStorage.DoWriteString Section=',Section,' Ident=',Ident,' Value=',Value);
FXML.SetValue(FixPath(Section)+'/'+Ident, Value);
@ -169,8 +170,10 @@ begin
System.Delete(NodePath,1,I);
Node := Child;
end;
If Assigned(Node) then
If Assigned(Node) then begin
//debugln('TPropStorageXMLConfig.DeleteSubNodes ',ARootNode);
Node.Free;
end;
end;
{$ENDIF not VER1_0}