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

Separate a new unit etFPCMsgFilePool from etFpcMsgParser and move it to package IdeConfig.

Browse Source
This commit is contained in:
Juha 2024-04-06 13:22:25 +03:00
parent 68e341be20
commit 201af675d3
11 changed files with 559 additions and 525 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
ide/buildmanager.pas
View File

@ -56,7 +56,7 @@ uses
// IDE
LazarusIDEStrConsts, DialogProcs, EditDefineTree, ProjectResources,
MiscOptions, ParsedCompilerOpts, CompilerOptions,
ExtTools, etFPCMsgParser, etPas2jsMsgParser, Compiler,
ExtTools, etFPCMsgFilePool, etFPCMsgParser, etPas2jsMsgParser, Compiler,
FPCSrcScan, PackageDefs, PackageSystem, Project, ProjectIcon, BaseBuildManager,
ApplicationBundle, RunParamsOpts, IdeTransferMacros, SearchPathProcs;

2
ide/compileroptions.pp
View File

@ -55,7 +55,7 @@ uses
LazConf, EnvironmentOpts, SearchPathProcs, IdeXmlConfigProcs, TransferMacros,
IDEProcs, ModeMatrixOpts, CompOptsModes,
// IDE
etFPCMsgParser, ParsedCompilerOpts;
etFPCMsgFilePool, ParsedCompilerOpts;
const
DefaultCompilerPath = '$(CompPath)';

601
ide/etfpcmsgparser.pas
View File

@ -45,9 +45,9 @@ uses
// IDEIntf
LazIDEIntf, IDEUtils,
// IdeConfig
EnvironmentOpts, LazConf, TransferMacros, IDECmdLine, SearchPathProcs, etMakeMsgParser,
EnvironmentOpts, LazConf, IDECmdLine, SearchPathProcs, etMakeMsgParser,
// IDE
LazarusIDEStrConsts;
etFPCMsgFilePool, LazarusIDEStrConsts;
const
FPCMsgIDCompiling = 3104;
@ -73,65 +73,8 @@ const
FPCMsgAttrWorkerDirectory = 'WD';
FPCMsgAttrMissingUnit = 'MissingUnit';
FPCMsgAttrUsedByUnit = 'UsedByUnit';
type
TFPCMsgFilePool = class;
{ TFPCMsgFilePoolItem }
TFPCMsgFilePoolItem = class
private
FMsgFile: TFPCMsgFile;
FFilename: string;
FPool: TFPCMsgFilePool;
FLoadedFileAge: integer;
fUseCount: integer;
public
constructor Create(aPool: TFPCMsgFilePool; const aFilename: string);
destructor Destroy; override;
property Pool: TFPCMsgFilePool read FPool;
property Filename: string read FFilename;
property LoadedFileAge: integer read FLoadedFileAge;
function GetMsg(ID: integer): TFPCMsgItem;
property MsgFile: TFPCMsgFile read FMsgFile;
property UseCount: integer read fUseCount;
end;
TETLoadFileEvent = procedure(aFilename: string; out s: string) of object;
{ TFPCMsgFilePool }
TFPCMsgFilePool = class(TComponent)
private
fCritSec: TRTLCriticalSection;
FDefaultEnglishFile: string;
FDefaultTranslationFile: string;
FFiles: TFPList; // list of TFPCMsgFilePoolItem sorted for loaded
FOnLoadFile: TETLoadFileEvent;
fPendingLog: TStrings;
fMsgFileStamp: integer;
fCurrentEnglishFile: string; // valid only if fMsgFileStamp=CompilerParseStamp
fCurrentTranslationFile: string; // valid only if fMsgFileStamp=CompilerParseStamp
procedure Log(Msg: string; AThread: TThread);
procedure LogSync;
procedure SetDefaultEnglishFile(AValue: string);
procedure SetDefaultTranslationFile(AValue: string);
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
function LoadCurrentEnglishFile(UpdateFromDisk: boolean;
AThread: TThread): TFPCMsgFilePoolItem; virtual; // don't forget UnloadFile
function LoadFile(aFilename: string; UpdateFromDisk: boolean;
AThread: TThread): TFPCMsgFilePoolItem; // don't forget UnloadFile
procedure UnloadFile(var aFile: TFPCMsgFilePoolItem);
procedure EnterCriticalsection;
procedure LeaveCriticalSection;
procedure GetMsgFileNames(CompilerFilename, TargetOS, TargetCPU: string;
out anEnglishFile, aTranslationFile: string); virtual; // (main thread)
property DefaultEnglishFile: string read FDefaultEnglishFile write SetDefaultEnglishFile;
property DefaulTranslationFile: string read FDefaultTranslationFile write SetDefaultTranslationFile;
property OnLoadFile: TETLoadFileEvent read FOnLoadFile write FOnLoadFile; // (main or workerthread)
end;
{ TPatternToMsgID }
TPatternToMsgID = class
@ -270,18 +213,13 @@ type
class function MsgFilePool: TFPCMsgFilePool; virtual;
end;
var
FPCMsgFilePool: TFPCMsgFilePool = nil;
// thread safe
function FPCMsgToMsgUrgency(Msg: TFPCMsgItem): TMessageLineUrgency;
function FPCMsgTypeToUrgency(const Typ: string): TMessageLineUrgency;
function TranslateFPCMsg(const Src, SrcPattern, TargetPattern: string): string;
function FPCMsgFits(const Msg, Pattern: string;
VarStarts: PPChar = nil; VarEnds: PPChar = nil // 10 PChars
): boolean;
function GetFPCMsgValue1(const Src, Pattern: string; out Value1: string): boolean;
function GetFPCMsgValues2(Src, Pattern: string; out Value1, Value2: string): boolean;
//function FPCMsgFits(const Msg, Pattern: string;
//function TranslateFPCMsg(const Src, SrcPattern, TargetPattern: string): string;
// VarStarts: PPChar = nil; VarEnds: PPChar = nil // 10 PChars
// ): boolean;
function GetFPCMsgValueOne(const Src, Pattern: string; out Value1: string): boolean;
function GetFPCMsgValuesTwo(Src, Pattern: string; out Value1, Value2: string): boolean;
// not thread safe
function IsFileInIDESrcDir(Filename: string): boolean; // (main thread)
@ -290,42 +228,6 @@ procedure RegisterFPCParser;
implementation
function FPCMsgTypeToUrgency(const Typ: string): TMessageLineUrgency;
begin
Result:=mluNone;
if (Typ='') or (length(Typ)<>1) then exit;
case UpChars[Typ[1]] of
'F': Result:=mluFatal;
'E': Result:=mluError;
'W': Result:=mluWarning;
'N': Result:=mluNote;
'H': Result:=mluHint;
'I': Result:=mluVerbose; // info
'L': Result:=mluProgress; // line number
'C': Result:=mluVerbose; // conditional: like IFDEFs
'U': Result:=mluVerbose2; // used: found files
'T': Result:=mluVerbose3; // tried: tried paths, general information
'D': Result:=mluDebug;
'X': Result:=mluProgress; // e.g. Size of Code
'O': Result:=mluProgress; // e.g., "press enter to continue"
else
Result:=mluNone;
end;
end;
function FPCMsgToMsgUrgency(Msg: TFPCMsgItem): TMessageLineUrgency;
begin
Result:=mluNone;
if Msg=nil then exit;
Result:=FPCMsgTypeToUrgency(Msg.ShownTyp);
if Result<>mluNone then exit;
Result:=FPCMsgTypeToUrgency(Msg.Typ);
if Result=mluNone then begin
//debugln(['FPCMsgToMsgUrgency Msg.ShownTyp="',Msg.ShownTyp,'" Msg.Typ="',Msg.Typ,'"']);
Result:=mluVerbose3;
end;
end;
function IsFPCMsgVar(p: PChar): boolean; inline;
begin
Result:=(p^='$') and (p[1] in ['0'..'9']);
@ -336,76 +238,6 @@ begin
Result:=(p^=#0) or IsFPCMsgVar(p);
end;
function TranslateFPCMsg(const Src, SrcPattern, TargetPattern: string): string;
{ for example:
Src='A lines compiled, B sec C'
SrcPattern='$1 lines compiled, $2 sec $3'
TargetPattern='$1 Zeilen uebersetzt, $2 Sekunden $3'
Result='A Zeilen uebersetzt, B Sekunden C'
}
var
SrcPos: PChar;
TargetPatPos: PChar;
TargetPos: PChar;
SrcVarStarts, SrcVarEnds: array[0..9] of PChar;
VarUsed: array[0..9] of integer;
i: Integer;
begin
Result:='';
{$IFDEF VerboseFPCTranslate}
debugln(['TranslateFPCMsg Src="',Src,'" SrcPattern="',SrcPattern,'" TargetPattern="',TargetPattern,'"']);
{$ENDIF}
if (Src='') or (SrcPattern='') or (TargetPattern='') then exit;
if not FPCMsgFits(Src,SrcPattern,@SrcVarStarts[0],@SrcVarEnds[0]) then
exit;
for i:=Low(SrcVarStarts) to high(SrcVarStarts) do
VarUsed[i]:=0;
// create Target
SetLength(Result,length(TargetPattern)+length(Src));
TargetPatPos:=PChar(TargetPattern);
TargetPos:=PChar(Result);
while TargetPatPos^<>#0 do begin
//debugln(['TranslateFPCMsg Target ',dbgs(Pointer(TargetPatPos)),' ',ord(TargetPatPos^),' TargetPatPos="',TargetPatPos,'"']);
if IsFPCMsgVar(TargetPatPos) then begin
// insert variable
inc(TargetPatPos);
i:=ord(TargetPatPos^)-ord('0');
inc(TargetPatPos);
if SrcVarStarts[i]<>nil then begin
inc(VarUsed[i]);
if VarUsed[i]>1 then begin
// variable is used more than once => realloc result
dec(TargetPos,{%H-}PtrUInt(PChar(Result)));
SetLength(Result,length(Result)+SrcVarEnds[i]-SrcVarStarts[i]);
inc(TargetPos,{%H-}PtrUInt(PChar(Result)));
end;
SrcPos:=SrcVarStarts[i];
while SrcPos<SrcVarEnds[i] do begin
TargetPos^:=SrcPos^;
inc(TargetPos);
inc(SrcPos);
end;
end;
end else begin
// copy text from TargetPattern
TargetPos^:=TargetPatPos^;
inc(TargetPatPos);
inc(TargetPos);
end;
end;
SetLength(Result,TargetPos-PChar(Result));
if Result<>'' then
UTF8FixBroken(PChar(Result));
{$IFDEF VerboseFPCTranslate}
debugln(['TranslateFPCMsg Result="',Result,'"']);
{$ENDIF}
end;
function FPCMsgFits(const Msg, Pattern: string; VarStarts: PPChar;
VarEnds: PPChar): boolean;
{ for example:
@ -506,8 +338,77 @@ begin
Result:=true;
end;
function GetFPCMsgValue1(const Src, Pattern: string; out Value1: string
): boolean;
function TranslateFPCMsg(const Src, SrcPattern, TargetPattern: string): string;
{ for example:
Src='A lines compiled, B sec C'
SrcPattern='$1 lines compiled, $2 sec $3'
TargetPattern='$1 Zeilen uebersetzt, $2 Sekunden $3'
Result='A Zeilen uebersetzt, B Sekunden C'
}
var
SrcPos: PChar;
TargetPatPos: PChar;
TargetPos: PChar;
SrcVarStarts, SrcVarEnds: array[0..9] of PChar;
VarUsed: array[0..9] of integer;
i: Integer;
begin
Result:='';
{$IFDEF VerboseFPCTranslate}
debugln(['TranslateFPCMsg Src="',Src,'" SrcPattern="',SrcPattern,'" TargetPattern="',TargetPattern,'"']);
{$ENDIF}
if (Src='') or (SrcPattern='') or (TargetPattern='') then exit;
if not FPCMsgFits(Src,SrcPattern,@SrcVarStarts[0],@SrcVarEnds[0]) then
exit;
for i:=Low(SrcVarStarts) to high(SrcVarStarts) do
VarUsed[i]:=0;
// create Target
SetLength(Result,length(TargetPattern)+length(Src));
TargetPatPos:=PChar(TargetPattern);
TargetPos:=PChar(Result);
while TargetPatPos^<>#0 do begin
//debugln(['TranslateFPCMsg Target ',dbgs(Pointer(TargetPatPos)),' ',ord(TargetPatPos^),' TargetPatPos="',TargetPatPos,'"']);
if IsFPCMsgVar(TargetPatPos) then begin
// insert variable
inc(TargetPatPos);
i:=ord(TargetPatPos^)-ord('0');
inc(TargetPatPos);
if SrcVarStarts[i]<>nil then begin
inc(VarUsed[i]);
if VarUsed[i]>1 then begin
// variable is used more than once => realloc result
dec(TargetPos,{%H-}PtrUInt(PChar(Result)));
SetLength(Result,length(Result)+SrcVarEnds[i]-SrcVarStarts[i]);
inc(TargetPos,{%H-}PtrUInt(PChar(Result)));
end;
SrcPos:=SrcVarStarts[i];
while SrcPos<SrcVarEnds[i] do begin
TargetPos^:=SrcPos^;
inc(TargetPos);
inc(SrcPos);
end;
end;
end else begin
// copy text from TargetPattern
TargetPos^:=TargetPatPos^;
inc(TargetPatPos);
inc(TargetPos);
end;
end;
SetLength(Result,TargetPos-PChar(Result));
if Result<>'' then
UTF8FixBroken(PChar(Result));
{$IFDEF VerboseFPCTranslate}
debugln(['TranslateFPCMsg Result="',Result,'"']);
{$ENDIF}
end;
function GetFPCMsgValueOne(const Src, Pattern: string; out Value1: string): boolean;
{ Pattern: 'Compiling $1'
Src: 'Compiling fcllaz.pas'
Value1: 'fcllaz.pas'
@ -531,8 +432,7 @@ begin
Result:=true;
end;
function GetFPCMsgValues2(Src, Pattern: string; out Value1, Value2: string
): boolean;
function GetFPCMsgValuesTwo(Src, Pattern: string; out Value1, Value2: string): boolean;
{ Pattern: 'Unit $1 was not found but $2 exists'
Src: 'Unit dialogprocs was not found but dialogpr exists'
Value1: 'dialogprocs'
@ -757,334 +657,6 @@ begin
end;
end;
{ TFPCMsgFilePool }
procedure TFPCMsgFilePool.Log(Msg: string; AThread: TThread);
begin
EnterCriticalsection;
try
fPendingLog.Add(Msg);
finally
LeaveCriticalSection;
end;
if AThread<>nil then
LogSync
else
TThread.Synchronize(AThread,@LogSync);
end;
procedure TFPCMsgFilePool.LogSync;
begin
EnterCriticalsection;
try
dbgout(fPendingLog.Text);
finally
LeaveCriticalSection;
end;
end;
procedure TFPCMsgFilePool.SetDefaultEnglishFile(AValue: string);
begin
if FDefaultEnglishFile=AValue then Exit;
FDefaultEnglishFile:=AValue;
fMsgFileStamp:=-1;
end;
procedure TFPCMsgFilePool.SetDefaultTranslationFile(AValue: string);
begin
if FDefaultTranslationFile=AValue then Exit;
FDefaultTranslationFile:=AValue;
fMsgFileStamp:=-1;
end;
constructor TFPCMsgFilePool.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
InitCriticalSection(fCritSec);
FFiles:=TFPList.Create;
fPendingLog:=TStringList.Create;
fMsgFileStamp:=-1;
end;
destructor TFPCMsgFilePool.Destroy;
var
i: Integer;
Item: TFPCMsgFilePoolItem;
begin
EnterCriticalsection;
try
// free unused files
for i:=FFiles.Count-1 downto 0 do begin
Item:=TFPCMsgFilePoolItem(FFiles[i]);
if Item.fUseCount=0 then begin
Item.Free;
FFiles.Delete(i);
end else begin
if ExitCode=0 then
debugln(['TFPCMsgFilePool.Destroy file still used: ',Item.Filename]);
end;
end;
if FFiles.Count>0 then begin
if ExitCode<>0 then
exit;
raise Exception.Create('TFPCMsgFilePool.Destroy some files are still used');
end;
FreeAndNil(FFiles);
if FPCMsgFilePool=Self then
FPCMsgFilePool:=nil;
inherited Destroy;
FreeAndNil(fPendingLog);
finally
LeaveCriticalSection;
end;
DoneCriticalsection(fCritSec);
end;
function TFPCMsgFilePool.LoadCurrentEnglishFile(UpdateFromDisk: boolean;
AThread: TThread): TFPCMsgFilePoolItem;
var
anEnglishFile: string;
aTranslationFile: string;
begin
Result:=nil;
GetMsgFileNames(EnvironmentOptions.GetParsedCompilerFilename,'','',
anEnglishFile,aTranslationFile);
//writeln('TFPCMsgFilePool.LoadCurrentEnglishFile ',anEnglishFile);
if not FilenameIsAbsolute(anEnglishFile) then exit;
Result:=LoadFile(anEnglishFile,UpdateFromDisk,AThread);
end;
function TFPCMsgFilePool.LoadFile(aFilename: string; UpdateFromDisk: boolean;
AThread: TThread): TFPCMsgFilePoolItem;
var
IsMainThread: Boolean;
procedure ResultOutdated;
begin
// cached file needs update
if Result.fUseCount=0 then begin
FFiles.Remove(Result);
Result.Free;
end;
Result:=nil;
end;
function FileExists: boolean;
begin
if IsMainThread then
Result:=FileExistsCached(aFilename)
else
Result:=FileExistsUTF8(aFilename);
end;
function FileAge: longint;
begin
if IsMainThread then
Result:=FileAgeCached(aFilename)
else
Result:=FileAgeUTF8(aFilename);
end;
var
Item: TFPCMsgFilePoolItem;
i: Integer;
NewItem: TFPCMsgFilePoolItem;
FileTxt: string;
ms: TMemoryStream;
Encoding: String;
begin
Result:=nil;
if aFilename='' then exit;
aFilename:=TrimAndExpandFilename(aFilename);
//Log('TFPCMsgFilePool.LoadFile '+aFilename,aThread);
IsMainThread:=GetThreadID=MainThreadID;
if UpdateFromDisk then begin
if not FileExists then begin
Log('TFPCMsgFilePool.LoadFile file not found: '+aFilename,AThread);
exit;
end;
end;
NewItem:=nil;
ms:=nil;
EnterCriticalsection;
try
// search the newest version in cache
for i:=FFiles.Count-1 downto 0 do begin
Item:=TFPCMsgFilePoolItem(FFiles[i]);
if CompareFilenames(Item.Filename,aFilename)<>0 then continue;
Result:=Item;
break;
end;
if UpdateFromDisk then begin
if (Result<>nil)
and (FileAge<>Result.LoadedFileAge) then
ResultOutdated;
end else if Result=nil then begin
// not yet loaded, not yet checked if file exists -> check now
if not FileExists then
exit;
end;
if Result<>nil then begin
// share
inc(Result.fUseCount);
end else begin
// load for the first time
NewItem:=TFPCMsgFilePoolItem.Create(Self,aFilename);
//Log('TFPCMsgFilePool.LoadFile '+dbgs(NewItem.FMsgFile<>nil)+' '+aFilename,aThread);
if Assigned(OnLoadFile) then begin
OnLoadFile(aFilename,FileTxt);
end else begin
ms:=TMemoryStream.Create;
ms.LoadFromFile(aFilename);
SetLength(FileTxt,ms.Size);
ms.Position:=0;
if FileTxt<>'' then
ms.Read(FileTxt[1],length(FileTxt));
end;
// convert encoding
Encoding:=GetDefaultFPCErrorMsgFileEncoding(aFilename);
FileTxt:=ConvertEncoding(FileTxt,Encoding,EncodingUTF8);
// parse
NewItem.FMsgFile.LoadFromText(FileTxt);
NewItem.FLoadedFileAge:=FileAge;
// load successful
Result:=NewItem;
NewItem:=nil;
FFiles.Add(Result);
inc(Result.fUseCount);
//log('TFPCMsgFilePool.LoadFile '+Result.Filename+' '+dbgs(Result.fUseCount),aThread);
end;
finally
ms.Free;
FreeAndNil(NewItem);
LeaveCriticalSection;
end;
end;
procedure TFPCMsgFilePool.UnloadFile(var aFile: TFPCMsgFilePoolItem);
var
i: Integer;
Item: TFPCMsgFilePoolItem;
Keep: Boolean;
begin
EnterCriticalsection;
try
if aFile.fUseCount<=0 then
raise Exception.Create('TFPCMsgFilePool.UnloadFile already freed');
if FFiles.IndexOf(aFile)<0 then
raise Exception.Create('TFPCMsgFilePool.UnloadFile unknown, maybe already freed');
dec(aFile.fUseCount);
//log('TFPCMsgFilePool.UnloadFile '+aFile.Filename+' UseCount='+dbgs(aFile.fUseCount),aThread);
if aFile.fUseCount>0 then exit;
// not used anymore
if not FileExistsUTF8(aFile.Filename) then begin
Keep:=false;
end else begin
// file still exist on disk
// => check if it is the newest version
Keep:=true;
for i:=FFiles.Count-1 downto 0 do begin
Item:=TFPCMsgFilePoolItem(FFiles[i]);
if Item=aFile then break;
if CompareFilenames(Item.Filename,aFile.Filename)<>0 then continue;
// there is already a newer version
Keep:=false;
break;
end;
end;
if Keep then begin
// this file is the newest version => keep it in cache
end else begin
//log('TFPCMsgFilePool.UnloadFile free: '+aFile.Filename,aThread);
FFiles.Remove(aFile);
aFile.Free;
end;
finally
aFile:=nil;
LeaveCriticalSection;
end;
end;
procedure TFPCMsgFilePool.EnterCriticalsection;
begin
System.EnterCriticalsection(fCritSec);
end;
procedure TFPCMsgFilePool.LeaveCriticalSection;
begin
System.LeaveCriticalsection(fCritSec);
end;
procedure TFPCMsgFilePool.GetMsgFileNames(CompilerFilename, TargetOS,
TargetCPU: string; out anEnglishFile, aTranslationFile: string);
var
FPCVer: String;
FPCSrcDir: String;
aFilename: String;
CompilerKind: TPascalCompiler;
begin
if fMsgFileStamp<>CompilerParseStamp then begin
fCurrentEnglishFile:=DefaultEnglishFile;
fCurrentTranslationFile:=DefaulTranslationFile;
// English msg file
// => use fpcsrcdir/compiler/msg/errore.msg
// the fpcsrcdir might depend on the FPC version
FPCVer:=CodeToolBoss.CompilerDefinesCache.GetPCVersion(
CompilerFilename,TargetOS,TargetCPU,false,CompilerKind);
if CompilerKind<>pcFPC then
;// ToDo
FPCSrcDir:=EnvironmentOptions.GetParsedFPCSourceDirectory(FPCVer);
if FilenameIsAbsolute(FPCSrcDir) then begin
// FPCSrcDir exists => use the errore.msg
aFilename:=AppendPathDelim(FPCSrcDir)+GetForcedPathDelims('compiler/msg/errore.msg');
if FileExistsCached(aFilename) then
fCurrentEnglishFile:=aFilename;
end;
if not FileExistsCached(fCurrentEnglishFile) then begin
// as fallback use the copy in the Codetools directory
aFilename:=EnvironmentOptions.GetParsedLazarusDirectory;
if FilenameIsAbsolute(aFilename) then begin
aFilename:=AppendPathDelim(aFilename)+GetForcedPathDelims('components/codetools/fpc.errore.msg');
if FileExistsCached(aFilename) then
fCurrentEnglishFile:=aFilename;
end;
end;
// translation msg file
aFilename:=EnvironmentOptions.GetParsedCompilerMessagesFilename;
if FilenameIsAbsolute(aFilename) and FileExistsCached(aFilename)
and (CompareFilenames(aFilename,fCurrentEnglishFile)<>0) then
fCurrentTranslationFile:=aFilename;
fMsgFileStamp:=CompilerParseStamp;
end;
anEnglishFile:=fCurrentEnglishFile;
aTranslationFile:=fCurrentTranslationFile;
end;
{ TFPCMsgFilePoolItem }
constructor TFPCMsgFilePoolItem.Create(aPool: TFPCMsgFilePool;
const aFilename: string);
begin
inherited Create;
FPool:=aPool;
FFilename:=aFilename;
FMsgFile:=TFPCMsgFile.Create;
end;
destructor TFPCMsgFilePoolItem.Destroy;
begin
FreeAndNil(FMsgFile);
FFilename:='';
inherited Destroy;
end;
function TFPCMsgFilePoolItem.GetMsg(ID: integer): TFPCMsgItem;
begin
Result:=FMsgFile.FindWithID(ID);
end;
{ TIDEFPCParser }
destructor TIDEFPCParser.Destroy;
@ -2454,8 +2026,7 @@ procedure TIDEFPCParser.ImproveMsgLinkerUndefinedReference(
Result:=false;
if MsgLine.HasSourcePosition then exit;
// check for ' "_FPC-Mangled-Identifier", referenced from:
if not etFPCMsgParser.GetFPCMsgValue1(MsgLine.Msg,' "_$1", referenced from:',
MangledName)
if not GetFPCMsgValueOne(MsgLine.Msg,' "_$1", referenced from:',MangledName)
then exit;
Result:=true;
case aPhase of
@ -2491,7 +2062,7 @@ procedure TIDEFPCParser.ImproveMsgLinkerUndefinedReference(
begin
Result:=false;
if MsgLine.HasSourcePosition then exit;
if not etFPCMsgParser.GetFPCMsgValues2(MsgLine.Msg,' _$1 in $2.o',
if not etFPCMsgParser.GetFPCMsgValuesTwo(MsgLine.Msg,' _$1 in $2.o',
MangledName,aUnitName)
then exit;
Result:=true;
@ -3532,7 +3103,7 @@ begin
Result:='';
if Msg.MsgID<=0 then exit;
if Msg.SubTool<>DefaultSubTool then exit;
if not etFPCMsgParser.GetFPCMsgValue1(Msg.Msg,GetFPCMsgPattern(Msg),Result) then
if not GetFPCMsgValueOne(Msg.Msg,GetFPCMsgPattern(Msg),Result) then
Result:='';
end;
@ -3542,7 +3113,7 @@ begin
Result:=false;
if Msg.MsgID<=0 then exit;
if Msg.SubTool<>DefaultSubTool then exit;
Result:=etFPCMsgParser.GetFPCMsgValues2(Msg.Msg,GetFPCMsgPattern(Msg),Value1,Value2);
Result:=etFPCMsgParser.GetFPCMsgValuesTwo(Msg.Msg,GetFPCMsgPattern(Msg),Value1,Value2);
end;
class function TIDEFPCParser.MsgFilePool: TFPCMsgFilePool;
@ -3553,7 +3124,7 @@ end;
initialization
IDEFPCParser:=TIDEFPCParser;
finalization
FreeAndNil(FPCMsgFilePool);
FreeAndNil(FpcMsgFilePool);
end.

2
ide/etpas2jsmsgparser.pas
View File

@ -32,7 +32,7 @@ interface
uses
Classes, SysUtils,
IDEExternToolIntf, LazFileUtils,
etFPCMsgParser, EnvironmentOpts;
etFPCMsgFilePool, etFPCMsgParser, EnvironmentOpts;
type

2
ide/etquickfixes.pas
View File

@ -570,7 +570,7 @@ begin
end;
ReplaceSubstring(Pattern,p,2,'$2');
if not GetFPCMsgValues2(Msg.Msg,Pattern,PkgName,Dir) then exit;
if not GetFPCMsgValuesTwo(Msg.Msg,Pattern,PkgName,Dir) then exit;
if PkgName='' then exit;
PkgName:=GetIdentifier(PChar(PkgName));
Result:=IsValidIdent(PkgName);

2
ide/frames/compiler_messages_options.pas
View File

@ -19,7 +19,7 @@ uses
// IdeIntf
IDEOptEditorIntf, IDEDialogs,
// IDE
CompilerOptions, LazarusIDEStrConsts, etFPCMsgParser;
CompilerOptions, etFPCMsgFilePool, LazarusIDEStrConsts;
type

5
ide/lazarus.lpi
View File

@ -1507,6 +1507,11 @@
<ResourceBaseClass Value="Frame"/>
<UnitName Value="Project_DisplayFormat_Options"/>
</Unit>
<Unit>
<Filename Value="etfpcmsgfilepool.pas"/>
<IsPartOfProject Value="True"/>
<UnitName Value="etFPCMsgFilePool"/>
</Unit>
</Units>
</ProjectOptions>
<CompilerOptions>

452
ide/packages/ideconfig/etfpcmsgfilepool.pas Normal file
View File

@ -0,0 +1,452 @@
unit etFPCMsgFilePool;
{$mode ObjFPC}{$H+}
interface
uses
Classes, SysUtils,
// LazUtils
LazFileUtils, LazFileCache, LConvEncoding,
// CodeTools
KeywordFuncLists, CodeToolsFPCMsgs, FileProcs, LinkScanner, CodeToolManager,
// BuildIntf
IDEExternToolIntf,
// IdeConfig
EnvironmentOpts, TransferMacros;
type
TFPCMsgFilePool = class;
{ TFPCMsgFilePoolItem }
TFPCMsgFilePoolItem = class
private
FMsgFile: TFPCMsgFile;
FFilename: string;
FPool: TFPCMsgFilePool;
FLoadedFileAge: integer;
fUseCount: integer;
public
constructor Create(aPool: TFPCMsgFilePool; const aFilename: string);
destructor Destroy; override;
property Pool: TFPCMsgFilePool read FPool;
property Filename: string read FFilename;
property LoadedFileAge: integer read FLoadedFileAge;
function GetMsg(ID: integer): TFPCMsgItem;
property MsgFile: TFPCMsgFile read FMsgFile;
property UseCount: integer read fUseCount;
end;
TETLoadFileEvent = procedure(aFilename: string; out s: string) of object;
{ TFPCMsgFilePool }
TFPCMsgFilePool = class(TComponent)
private
fCritSec: TRTLCriticalSection;
FDefaultEnglishFile: string;
FDefaultTranslationFile: string;
FFiles: TFPList; // list of TFPCMsgFilePoolItem sorted for loaded
FOnLoadFile: TETLoadFileEvent;
fPendingLog: TStrings;
fMsgFileStamp: integer;
fCurrentEnglishFile: string; // valid only if fMsgFileStamp=CompilerParseStamp
fCurrentTranslationFile: string; // valid only if fMsgFileStamp=CompilerParseStamp
procedure Log(Msg: string; AThread: TThread);
procedure LogSync;
procedure SetDefaultEnglishFile(AValue: string);
procedure SetDefaultTranslationFile(AValue: string);
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
function LoadCurrentEnglishFile(UpdateFromDisk: boolean;
AThread: TThread): TFPCMsgFilePoolItem; virtual; // don't forget UnloadFile
function LoadFile(aFilename: string; UpdateFromDisk: boolean;
AThread: TThread): TFPCMsgFilePoolItem; // don't forget UnloadFile
procedure UnloadFile(var aFile: TFPCMsgFilePoolItem);
procedure EnterCriticalsection;
procedure LeaveCriticalSection;
procedure GetMsgFileNames(CompilerFilename, TargetOS, TargetCPU: string;
out anEnglishFile, aTranslationFile: string); virtual; // (main thread)
property DefaultEnglishFile: string read FDefaultEnglishFile write SetDefaultEnglishFile;
property DefaulTranslationFile: string read FDefaultTranslationFile write SetDefaultTranslationFile;
property OnLoadFile: TETLoadFileEvent read FOnLoadFile write FOnLoadFile; // (main or workerthread)
end;
var
FPCMsgFilePool: TFPCMsgFilePool = nil;
function FPCMsgToMsgUrgency(Msg: TFPCMsgItem): TMessageLineUrgency;
function FPCMsgTypeToUrgency(const Typ: string): TMessageLineUrgency;
implementation
function FPCMsgToMsgUrgency(Msg: TFPCMsgItem): TMessageLineUrgency;
begin
Result:=mluNone;
if Msg=nil then exit;
Result:=FPCMsgTypeToUrgency(Msg.ShownTyp);
if Result<>mluNone then exit;
Result:=FPCMsgTypeToUrgency(Msg.Typ);
if Result=mluNone then begin
//debugln(['FPCMsgToMsgUrgency Msg.ShownTyp="',Msg.ShownTyp,'" Msg.Typ="',Msg.Typ,'"']);
Result:=mluVerbose3;
end;
end;
function FPCMsgTypeToUrgency(const Typ: string): TMessageLineUrgency;
begin
Result:=mluNone;
if (Typ='') or (length(Typ)<>1) then exit;
case UpChars[Typ[1]] of
'F': Result:=mluFatal;
'E': Result:=mluError;
'W': Result:=mluWarning;
'N': Result:=mluNote;
'H': Result:=mluHint;
'I': Result:=mluVerbose; // info
'L': Result:=mluProgress; // line number
'C': Result:=mluVerbose; // conditional: like IFDEFs
'U': Result:=mluVerbose2; // used: found files
'T': Result:=mluVerbose3; // tried: tried paths, general information
'D': Result:=mluDebug;
'X': Result:=mluProgress; // e.g. Size of Code
'O': Result:=mluProgress; // e.g., "press enter to continue"
else
Result:=mluNone;
end;
end;
{ TFPCMsgFilePoolItem }
constructor TFPCMsgFilePoolItem.Create(aPool: TFPCMsgFilePool;
const aFilename: string);
begin
inherited Create;
FPool:=aPool;
FFilename:=aFilename;
FMsgFile:=TFPCMsgFile.Create;
end;
destructor TFPCMsgFilePoolItem.Destroy;
begin
FreeAndNil(FMsgFile);
FFilename:='';
inherited Destroy;
end;
function TFPCMsgFilePoolItem.GetMsg(ID: integer): TFPCMsgItem;
begin
Result:=FMsgFile.FindWithID(ID);
end;
{ TFPCMsgFilePool }
procedure TFPCMsgFilePool.Log(Msg: string; AThread: TThread);
begin
EnterCriticalsection;
try
fPendingLog.Add(Msg);
finally
LeaveCriticalSection;
end;
if AThread<>nil then
LogSync
else
TThread.Synchronize(AThread,@LogSync);
end;
procedure TFPCMsgFilePool.LogSync;
begin
EnterCriticalsection;
try
dbgout(fPendingLog.Text);
finally
LeaveCriticalSection;
end;
end;
procedure TFPCMsgFilePool.SetDefaultEnglishFile(AValue: string);
begin
if FDefaultEnglishFile=AValue then Exit;
FDefaultEnglishFile:=AValue;
fMsgFileStamp:=-1;
end;
procedure TFPCMsgFilePool.SetDefaultTranslationFile(AValue: string);
begin
if FDefaultTranslationFile=AValue then Exit;
FDefaultTranslationFile:=AValue;
fMsgFileStamp:=-1;
end;
constructor TFPCMsgFilePool.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
InitCriticalSection(fCritSec);
FFiles:=TFPList.Create;
fPendingLog:=TStringList.Create;
fMsgFileStamp:=-1;
end;
destructor TFPCMsgFilePool.Destroy;
var
i: Integer;
Item: TFPCMsgFilePoolItem;
begin
EnterCriticalsection;
try
// free unused files
for i:=FFiles.Count-1 downto 0 do begin
Item:=TFPCMsgFilePoolItem(FFiles[i]);
if Item.fUseCount=0 then begin
Item.Free;
FFiles.Delete(i);
end else begin
if ExitCode=0 then
debugln(['TFPCMsgFilePool.Destroy file still used: ',Item.Filename]);
end;
end;
if FFiles.Count>0 then begin
if ExitCode<>0 then
exit;
raise Exception.Create('TFPCMsgFilePool.Destroy some files are still used');
end;
FreeAndNil(FFiles);
if FPCMsgFilePool=Self then
FPCMsgFilePool:=nil;
inherited Destroy;
FreeAndNil(fPendingLog);
finally
LeaveCriticalSection;
end;
DoneCriticalsection(fCritSec);
end;
function TFPCMsgFilePool.LoadCurrentEnglishFile(UpdateFromDisk: boolean;
AThread: TThread): TFPCMsgFilePoolItem;
var
anEnglishFile: string;
aTranslationFile: string;
begin
Result:=nil;
GetMsgFileNames(EnvironmentOptions.GetParsedCompilerFilename,'','',
anEnglishFile,aTranslationFile);
//writeln('TFPCMsgFilePool.LoadCurrentEnglishFile ',anEnglishFile);
if not FilenameIsAbsolute(anEnglishFile) then exit;
Result:=LoadFile(anEnglishFile,UpdateFromDisk,AThread);
end;
function TFPCMsgFilePool.LoadFile(aFilename: string; UpdateFromDisk: boolean;
AThread: TThread): TFPCMsgFilePoolItem;
var
IsMainThread: Boolean;
procedure ResultOutdated;
begin
// cached file needs update
if Result.fUseCount=0 then begin
FFiles.Remove(Result);
Result.Free;
end;
Result:=nil;
end;
function FileExists: boolean;
begin
if IsMainThread then
Result:=FileExistsCached(aFilename)
else
Result:=FileExistsUTF8(aFilename);
end;
function FileAge: longint;
begin
if IsMainThread then
Result:=FileAgeCached(aFilename)
else
Result:=FileAgeUTF8(aFilename);
end;
var
Item: TFPCMsgFilePoolItem;
i: Integer;
NewItem: TFPCMsgFilePoolItem;
FileTxt: string;
ms: TMemoryStream;
Encoding: String;
begin
Result:=nil;
if aFilename='' then exit;
aFilename:=TrimAndExpandFilename(aFilename);
//Log('TFPCMsgFilePool.LoadFile '+aFilename,aThread);
IsMainThread:=GetThreadID=MainThreadID;
if UpdateFromDisk then begin
if not FileExists then begin
Log('TFPCMsgFilePool.LoadFile file not found: '+aFilename,AThread);
exit;
end;
end;
NewItem:=nil;
ms:=nil;
EnterCriticalsection;
try
// search the newest version in cache
for i:=FFiles.Count-1 downto 0 do begin
Item:=TFPCMsgFilePoolItem(FFiles[i]);
if CompareFilenames(Item.Filename,aFilename)<>0 then continue;
Result:=Item;
break;
end;
if UpdateFromDisk then begin
if (Result<>nil)
and (FileAge<>Result.LoadedFileAge) then
ResultOutdated;
end else if Result=nil then begin
// not yet loaded, not yet checked if file exists -> check now
if not FileExists then
exit;
end;
if Result<>nil then begin
// share
inc(Result.fUseCount);
end else begin
// load for the first time
NewItem:=TFPCMsgFilePoolItem.Create(Self,aFilename);
//Log('TFPCMsgFilePool.LoadFile '+dbgs(NewItem.FMsgFile<>nil)+' '+aFilename,aThread);
if Assigned(OnLoadFile) then begin
OnLoadFile(aFilename,FileTxt);
end else begin
ms:=TMemoryStream.Create;
ms.LoadFromFile(aFilename);
SetLength(FileTxt,ms.Size);
ms.Position:=0;
if FileTxt<>'' then
ms.Read(FileTxt[1],length(FileTxt));
end;
// convert encoding
Encoding:=GetDefaultFPCErrorMsgFileEncoding(aFilename);
FileTxt:=ConvertEncoding(FileTxt,Encoding,EncodingUTF8);
// parse
NewItem.FMsgFile.LoadFromText(FileTxt);
NewItem.FLoadedFileAge:=FileAge;
// load successful
Result:=NewItem;
NewItem:=nil;
FFiles.Add(Result);
inc(Result.fUseCount);
//log('TFPCMsgFilePool.LoadFile '+Result.Filename+' '+dbgs(Result.fUseCount),aThread);
end;
finally
ms.Free;
FreeAndNil(NewItem);
LeaveCriticalSection;
end;
end;
procedure TFPCMsgFilePool.UnloadFile(var aFile: TFPCMsgFilePoolItem);
var
i: Integer;
Item: TFPCMsgFilePoolItem;
Keep: Boolean;
begin
EnterCriticalsection;
try
if aFile.fUseCount<=0 then
raise Exception.Create('TFPCMsgFilePool.UnloadFile already freed');
if FFiles.IndexOf(aFile)<0 then
raise Exception.Create('TFPCMsgFilePool.UnloadFile unknown, maybe already freed');
dec(aFile.fUseCount);
//log('TFPCMsgFilePool.UnloadFile '+aFile.Filename+' UseCount='+dbgs(aFile.fUseCount),aThread);
if aFile.fUseCount>0 then exit;
// not used anymore
if not FileExistsUTF8(aFile.Filename) then begin
Keep:=false;
end else begin
// file still exist on disk
// => check if it is the newest version
Keep:=true;
for i:=FFiles.Count-1 downto 0 do begin
Item:=TFPCMsgFilePoolItem(FFiles[i]);
if Item=aFile then break;
if CompareFilenames(Item.Filename,aFile.Filename)<>0 then continue;
// there is already a newer version
Keep:=false;
break;
end;
end;
if Keep then begin
// this file is the newest version => keep it in cache
end else begin
//log('TFPCMsgFilePool.UnloadFile free: '+aFile.Filename,aThread);
FFiles.Remove(aFile);
aFile.Free;
end;
finally
aFile:=nil;
LeaveCriticalSection;
end;
end;
procedure TFPCMsgFilePool.EnterCriticalsection;
begin
System.EnterCriticalsection(fCritSec);
end;
procedure TFPCMsgFilePool.LeaveCriticalSection;
begin
System.LeaveCriticalsection(fCritSec);
end;
procedure TFPCMsgFilePool.GetMsgFileNames(CompilerFilename, TargetOS,
TargetCPU: string; out anEnglishFile, aTranslationFile: string);
var
FPCVer: String;
FPCSrcDir: String;
aFilename: String;
CompilerKind: TPascalCompiler;
begin
if fMsgFileStamp<>CompilerParseStamp then begin
fCurrentEnglishFile:=DefaultEnglishFile;
fCurrentTranslationFile:=DefaulTranslationFile;
// English msg file
// => use fpcsrcdir/compiler/msg/errore.msg
// the fpcsrcdir might depend on the FPC version
FPCVer:=CodeToolBoss.CompilerDefinesCache.GetPCVersion(
CompilerFilename,TargetOS,TargetCPU,false,CompilerKind);
if CompilerKind<>pcFPC then
;// ToDo
FPCSrcDir:=EnvironmentOptions.GetParsedFPCSourceDirectory(FPCVer);
if FilenameIsAbsolute(FPCSrcDir) then begin
// FPCSrcDir exists => use the errore.msg
aFilename:=AppendPathDelim(FPCSrcDir)+GetForcedPathDelims('compiler/msg/errore.msg');
if FileExistsCached(aFilename) then
fCurrentEnglishFile:=aFilename;
end;
if not FileExistsCached(fCurrentEnglishFile) then begin
// as fallback use the copy in the Codetools directory
aFilename:=EnvironmentOptions.GetParsedLazarusDirectory;
if FilenameIsAbsolute(aFilename) then begin
aFilename:=AppendPathDelim(aFilename)+GetForcedPathDelims('components/codetools/fpc.errore.msg');
if FileExistsCached(aFilename) then
fCurrentEnglishFile:=aFilename;
end;
end;
// translation msg file
aFilename:=EnvironmentOptions.GetParsedCompilerMessagesFilename;
if FilenameIsAbsolute(aFilename) and FileExistsCached(aFilename)
and (CompareFilenames(aFilename,fCurrentEnglishFile)<>0) then
fCurrentTranslationFile:=aFilename;
fMsgFileStamp:=CompilerParseStamp;
end;
anEnglishFile:=fCurrentEnglishFile;
aTranslationFile:=fCurrentTranslationFile;
end;
end.

4
ide/packages/ideconfig/fpmake.pp
View File

@ -55,6 +55,7 @@ begin
t.Dependencies.AddUnit('diffpatch');
t.Dependencies.AddUnit('editortoolbaroptions');
t.Dependencies.AddUnit('environmentopts');
t.Dependencies.AddUnit('etfpcmsgfilepool');
t.Dependencies.AddUnit('etmakemsgparser');
t.Dependencies.AddUnit('idecmdline');
t.Dependencies.AddUnit('ideconfstrconsts');
@ -74,7 +75,8 @@ begin
T:=P.Targets.AddUnit('diffpatch.pas');
T:=P.Targets.AddUnit('editortoolbaroptions.pas');
T:=P.Targets.AddUnit('environmentopts.pp');
P.Targets.AddImplicitUnit('etmakemsgparser.pas');
P.Targets.AddImplicitUnit('etfpcmsgfilepool.pas');
T:=P.Targets.AddUnit('etmakemsgparser.pas');
T:=P.Targets.AddUnit('idecmdline.pas');
T:=P.Targets.AddUnit('ideconfstrconsts.pas');
T:=P.Targets.AddUnit('ideguicmdline.pas');

4
ide/packages/ideconfig/ideconfig.lpk
View File

@ -43,6 +43,10 @@ Files in this package are for the main configuration of the IDE."/>
<Filename Value="environmentopts.pp"/>
<UnitName Value="EnvironmentOpts"/>
</Item>
<Item>
<Filename Value="etfpcmsgfilepool.pas"/>
<UnitName Value="etFPCMsgFilePool"/>
</Item>
<Item>
<Filename Value="etmakemsgparser.pas"/>
<UnitName Value="etMakeMsgParser"/>

8
ide/packages/ideconfig/ideconfig.pas
View File

@ -9,10 +9,10 @@ interface
uses
CompOptsModes, CoolBarOptions, DiffPatch, EditorToolBarOptions,
EnvironmentOpts, etMakeMsgParser, IDECmdLine, IdeConfStrConsts,
IDEGuiCmdLine, IDEOptionDefs, IDEProcs, IdeXmlConfigProcs, LazConf,
ModeMatrixOpts, RecentListProcs, SearchPathProcs, ToolBarOptionsBase,
TransferMacros, LazarusPackageIntf;
EnvironmentOpts, etFPCMsgFilePool, etMakeMsgParser, IDECmdLine,
IdeConfStrConsts, IDEGuiCmdLine, IDEOptionDefs, IDEProcs, IdeXmlConfigProcs,
LazConf, ModeMatrixOpts, RecentListProcs, SearchPathProcs,
ToolBarOptionsBase, TransferMacros, LazarusPackageIntf;
implementation