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

git-svn-id: trunk@6221 -

components/codetools/memcheck.pas

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

lcl/interfaces/gtk/gtkfontcache.pas

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

lcl/interfaces/gtk/gtkobject.inc

@@ -1511,8 +1511,8 @@ end;
  ------------------------------------------------------------------------------}
 procedure TGtkWidgetSet.AppInit(var ScreenInfo: TScreenInfo);
 begin
-  If Assigned(Screen) then
+  // MG: TODO: call FillScreenFonts on demand, not for every application
-    FillScreenFonts(Screen.Fonts);
+  //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
 

lcl/interfaces/gtk/gtkproc.inc

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

lcl/interfaces/gtk/gtkwinapi.inc

@@ -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)
+    ' Long="',LongFontName,'" IsXLFD=',dbgs(IsFontNameXLogicalFontDesc(LongFontName))
-    ,' ',ord(LogFont.lfFaceName[0]));
+    ,' ',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]))
+    then DebugLn(Format('WARNING: [TGtkWidgetSet.CreateFontIndirectEx] NOT found XLFD: <%s>', [LongFontName]))
-    else Assert(False, Format('Trace:  [TGtkWidgetSet.CreateFontIndirectEx] found XLFD: <%s>', [S]));
+    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
 

lcl/interfaces/gtk2/gtk2winapi.inc

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

lcl/xmlpropstorage.pas

@@ -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 GetXMLFileName: string; virtual;
-    Function RootSection : String; Override;
+    Function RootSection: String; Override;
-    Function FixPath(const APath : String) : String; virtual;
+    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 FileName: String Read FFileName Write FFileName;
-    property RootNodePath : String Read FRootNode Write FRootNodePath;
+    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
+function TCustomXMLPropStorage.DoReadString(const Section, Ident,
-  ): string;
+  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}