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

Adds a mechanism for widgetsets to override DebugLn/DebugOut

Browse Source 
git-svn-id: trunk@33817 -
This commit is contained in:
sekelsenmat 2011-11-28 10:10:48 +00:00
parent baa4004c59
commit 147eb696f1
1 changed files with 20 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

20
lcl/lclproc.pas
View File

@ -357,11 +357,17 @@ procedure LCLGetLanguageIDs(var Lang, FallbackLang: String);
function CreateFirstIdentifier(const Identifier: string): string;
function CreateNextIdentifier(const Identifier: string): string;
type
TDebugLnProc = procedure (s: string) of object;
var
DebugLnMaxNestPrefixLen: Integer = 15;
DebugLnNestLvlIndent: Integer = 2;
DebugText: ^Text;
DebugLnProc: TDebugLnProc = nil;
DebugOutProc: TDebugLnProc = nil;
implementation
uses gettext;
@ -1482,6 +1488,14 @@ begin
else
DbgAppendToFile(ExtractFilePath(ParamStr(0)) + Str_LCL_Debug_File, s);
{$else}
// First of all verify if a widgetset has override DebugLn
if DebugLnProc <> nil then
begin
DebugLnProc(s);
Exit;
end;
// Now the default code
if not Assigned(DebugText) then exit;
if DebugNestAtBOL and (s <> '') then
write(DebugText^, DebugNestPrefix);
@ -1714,6 +1728,12 @@ begin
DbgAppendToFileWithoutLn(ExtractFilePath(ParamStr(0)) + Str_LCL_Debug_File, DebugNestPrefix);
DbgAppendToFileWithoutLn(ExtractFilePath(ParamStr(0)) + Str_LCL_Debug_File, s);
{$else}
if DebugOutProc <> nil then
begin
DebugOutProc(s);
Exit;
end;
if Assigned(DebugText) then begin
if DebugNestAtBOL and (s <> '') then
write(DebugText^, DebugNestPrefix);