1 {
2  ***************************************************************************
3  *                                                                         *
4  *   This source is free software; you can redistribute it and/or modify   *
5  *   it under the terms of the GNU General Public License as published by  *
6  *   the Free Software Foundation; either version 2 of the License, or     *
7  *   (at your option) any later version.                                   *
8  *                                                                         *
9  *   This code is distributed in the hope that it will be useful, but      *
10  *   WITHOUT ANY WARRANTY; without even the implied warranty of            *
11  *   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU     *
12  *   General Public License for more details.                              *
13  *                                                                         *
14  *   A copy of the GNU General Public License is available on the World    *
15  *   Wide Web at <http://www.gnu.org/copyleft/gpl.html>. You can also      *
16  *   obtain it by writing to the Free Software Foundation,                 *
17  *   Inc., 51 Franklin Street - Fifth Floor, Boston, MA 02110-1335, USA.   *
18  *                                                                         *
19  ***************************************************************************
20 
21   Author: Mattias Gaertner
22 
23   Abstract:
24     Procedures and dialogs to check environment. The IDE uses these procedures
25     at startup to check for example the lazarus directory and warns if it looks
26     suspicious and choose another.
27 }
28 unit InitialSetupProc;
29 
30 {$mode objfpc}{$H+}
31 
32 interface
33 
34 uses
35   // RTL + FCL + LCL
36   Classes, SysUtils, strutils, contnrs,
37   // CodeTools
38   DefineTemplates, CodeToolManager, FileProcs,
39   // LazUtils
40   LazFileCache, LazUTF8, LazFileUtils, FileUtil, LazLoggerBase, Laz2_XMLCfg,
41   // IDE
42   LazarusIDEStrConsts, LazConf, EnvironmentOpts, FppkgHelper;
43 
44 type
45   TSDFilenameQuality = (
46     sddqInvalid,
47     sddqWrongMinorVersion,
48     sddqWrongVersion,
49     sddqIncomplete,
50     sddqCompatible,
51     sddqMakeNotWithFpc  // Make not in the same directory as compiler
52     );
53 
54   TSDFileInfo = class
55   public
56     Filename: string; // macros resolved, trimmed, expanded
57     Caption: string; // filename with macros
58     Note: string;
59     Quality: TSDFilenameQuality;
60   end;
61 
62   TSDFileInfoList = class (TObjectList)
63   public
AddNewItemnull64     function AddNewItem(aFilename, aCaption: string): TSDFileInfo;
CaptionExistsnull65     function CaptionExists(aCaption: string): boolean;
BestDirnull66     function BestDir: TSDFileInfo;
67   end;
68 
69   TSDFilenameType = (
70     sddtLazarusSrcDir,
71     sddtCompilerFilename,
72     sddtFPCSrcDir,
73     sddtMakeExeFilename,
74     sddtDebuggerFilename,
75     sddtFppkgFpcPrefix
76     );
77 
78   TSDFlag = (
79     sdfCompilerFilenameNeedsUpdate,
80     sdfFPCSrcDirNeedsUpdate,
81     sdfMakeExeFilenameNeedsUpdate,
82     sdfDebuggerFilenameNeedsUpdate,
83     sdfFppkgConfigFileNeedsUpdate
84     );
85   TSDFlags = set of TSDFlag;
86 
87 // Lazarus Directory
CheckLazarusDirectoryQualitynull88 function CheckLazarusDirectoryQuality(ADirectory: string; out Note: string): TSDFilenameQuality;
SearchLazarusDirectoryCandidatesnull89 function SearchLazarusDirectoryCandidates(StopIfFits: boolean): TSDFileInfoList;
90 procedure SetupLazarusDirectory;
91 
92 // FreePascal Compiler
CheckFPCExeQualitynull93 function CheckFPCExeQuality(AFilename: string; out Note: string;
94   TestSrcFilename: string): TSDFilenameQuality;
SearchFPCExeCandidatesnull95 function SearchFPCExeCandidates(StopIfFits: boolean;
96   const TestSrcFilename: string): TSDFileInfoList;
97 procedure SetupFPCExeFilename;
98 
99 // Pas2js compiler
CheckPas2jsQualitynull100 function CheckPas2jsQuality(AFilename: string; out Note: string;
101   TestSrcFilename: string): TSDFilenameQuality;
102 
103 // FPC Source
CheckFPCSrcDirQualitynull104 function CheckFPCSrcDirQuality(ADirectory: string; out Note: string;
105   const FPCVer: String; aUseFileCache: Boolean = True): TSDFilenameQuality;
SearchFPCSrcDirCandidatesnull106 function SearchFPCSrcDirCandidates(StopIfFits: boolean;
107   const FPCVer: string): TSDFileInfoList;
108 
109 // Fppkg
CheckFppkgConfigurationnull110 function CheckFppkgConfiguration(var ConfigFile: string; out Msg: string): TSDFilenameQuality;
CheckFppkgConfigFilenull111 function CheckFppkgConfigFile(const AFilename: string; out Note: string): TSDFilenameQuality;
112 
113 // Make
114 // Checks a given file to see if it is a valid make executable
CheckMakeExeQualitynull115 function CheckMakeExeQuality(AFilename: string; out Note: string): TSDFilenameQuality;
116 // Search make candidates and add them to the list, including quality level
SearchMakeExeCandidatesnull117 function SearchMakeExeCandidates(StopIfFits: boolean): TSDFileInfoList;
118 
GetValueFromPrimaryConfignull119 function GetValueFromPrimaryConfig(OptionFilename, Path: string): string;
GetValueFromSecondaryConfignull120 function GetValueFromSecondaryConfig(OptionFilename, Path: string): string;
GetValueFromIDEConfignull121 function GetValueFromIDEConfig(OptionFilename, Path: string): string;
122 
SafeFormatnull123 function SafeFormat(const Fmt: String; const Args: Array of const): String;
124 
125 implementation
126 
CheckLazarusDirectoryQualitynull127 function CheckLazarusDirectoryQuality(ADirectory: string;
128   out Note: string): TSDFilenameQuality;
129 
SubDirExistsnull130   function SubDirExists(SubDir: string; var q: TSDFilenameQuality): boolean;
131   begin
132     SubDir:=GetForcedPathDelims(SubDir);
133     if DirPathExistsCached(ADirectory+SubDir) then exit(true);
134     Result:=false;
135     Note:=Format(lisDirectoryNotFound2, [SubDir]);
136     q:=sddqIncomplete;
137   end;
138 
SubFileExistsnull139   function SubFileExists(SubFile: string; var q: TSDFilenameQuality): boolean;
140   begin
141     SubFile:=GetForcedPathDelims(SubFile);
142     if FileExistsCached(ADirectory+SubFile) then exit(true);
143     Result:=false;
144     Note:=Format(lisFileNotFound3, [SubFile]);
145     q:=sddqIncomplete;
146   end;
147 
148 var
149   sl: TStringList;
150   VersionIncFile: String;
151   Version: String;
152 begin
153   Result:=sddqInvalid;
154   ADirectory:=TrimFilename(ADirectory);
155   if not DirPathExistsCached(ADirectory) then
156   begin
157     Note:=lisISDDirectoryNotFound;
158     exit;
159   end;
160   ADirectory:=AppendPathDelim(ADirectory);
161   if not SubDirExists('lcl',Result) then exit;
162   if not SubDirExists('packager/globallinks',Result) then exit;
163   if not SubDirExists('ide',Result) then exit;
164   if not SubDirExists('components',Result) then exit;
165   if not SubFileExists('ide/lazarus.lpi',Result) then exit;
166   VersionIncFile:=GetForcedPathDelims('ide/version.inc');
167   if not SubFileExists(VersionIncFile,Result) then exit;
168   sl:=TStringList.Create;
169   try
170     try
171       sl.LoadFromFile(ADirectory+VersionIncFile);
172       if (sl.Count=0) or (sl[0]='') or (sl[0][1]<>'''') then
173       begin
174         Note:=Format(lisInvalidVersionIn, [VersionIncFile]);
175         exit;
176       end;
177       Version:=copy(sl[0],2,length(sl[0])-2);
178       if Version<>LazarusVersionStr then
179       begin
180         Note:=Format(lisWrongVersionIn, [VersionIncFile, Version]);
181         Result:=sddqWrongVersion;
182         exit;
183       end;
184       Note:=lisOk;
185       Result:=sddqCompatible;
186     except
187       on E: Exception do begin
188         Note:=Format(lisUnableToLoadFile2, [VersionIncFile, E.Message]);
189         exit;
190       end;
191     end;
192   finally
193     sl.Free;
194   end;
195 end;
196 
SearchLazarusDirectoryCandidatesnull197 function SearchLazarusDirectoryCandidates(StopIfFits: boolean): TSDFileInfoList;
198 
CheckDirnull199   function CheckDir(Dir: string; var List: TSDFileInfoList): boolean;
200   var
201     Item: TSDFileInfo;
202     RealDir: String;
203   begin
204     Result:=false;
205     if Dir='' then Dir:='.';
206     ForcePathDelims(Dir);
207     Dir:=ChompPathDelim(Dir);
208     // check if already checked
209     if Assigned(List) and List.CaptionExists(Dir) then exit;
210     EnvironmentOptions.LazarusDirectory:=Dir;
211     RealDir:=ChompPathDelim(EnvironmentOptions.GetParsedLazarusDirectory);
212     DebugLn(['SearchLazarusDirectoryCandidates Value=',Dir,' File=',RealDir]);
213     // check if exists
214     if not DirPathExistsCached(RealDir) then exit;
215     // add to list and check quality
216     if List=nil then
217       List:=TSDFileInfoList.create(true);
218     Item:=List.AddNewItem(RealDir, Dir);
219     Item.Quality:=CheckLazarusDirectoryQuality(RealDir, Item.Note);
220     Result:=(Item.Quality=sddqCompatible) and StopIfFits;
221   end;
222 
CheckViaExenull223   function CheckViaExe(Filename: string; var List: TSDFileInfoList): boolean;
224   begin
225     Result:=false;
226     Filename:=FindDefaultExecutablePath(Filename);
227     if Filename='' then exit;
228     Filename:=GetPhysicalFilenameCached(Filename,true);
229     if Filename='' then exit;
230     Result:=CheckDir(ExtractFilePath(Filename),List);
231   end;
232 
233 var
234   Dir: String;
235   ResolvedDir: String;
236   Dirs: TStringList;
237   i: Integer;
238   OldLazarusDir: String;
239 begin
240   Result:=nil;
241 
242   OldLazarusDir:=EnvironmentOptions.LazarusDirectory;
243   try
244     // first check the value in the options
245     if CheckDir(EnvironmentOptions.LazarusDirectory,Result) then exit;
246 
247     // then check the directory of the executable
248     Dir:=ProgramDirectoryWithBundle;
249     if CheckDir(Dir,Result) then exit;
250     ResolvedDir:=GetPhysicalFilenameCached(Dir,false);
251     if (ResolvedDir<>Dir) and (CheckDir(ResolvedDir,Result)) then exit;
252 
253     // check the primary options
254     Dir:=GetValueFromPrimaryConfig(EnvOptsConfFileName,
255                                      'EnvironmentOptions/LazarusDirectory/Value');
256     if CheckDir(Dir,Result) then exit;
257 
258     // check the secondary options
259     Dir:=GetValueFromSecondaryConfig(EnvOptsConfFileName,
260                                      'EnvironmentOptions/LazarusDirectory/Value');
261     if CheckDir(Dir,Result) then exit;
262 
263     // check common directories
264     Dirs:=GetDefaultLazarusSrcDirectories;
265     try
266       for i:=0 to Dirs.Count-1 do
267         if CheckDir(Dirs[i],Result) then exit;
268     finally
269       Dirs.Free;
270     end;
271 
272     // check history
273     Dirs:=EnvironmentOptions.LazarusDirHistory;
274     if Dirs<>nil then
275       for i:=0 to Dirs.Count-1 do
276         if CheckDir(Dirs[i],Result) then exit;
277 
278     // search lazarus-ide and lazarus in PATH, then follow the links,
279     // which will lead to the lazarus directory
280     if CheckViaExe('lazarus-ide'+GetExecutableExt,Result) then exit;
281     if CheckViaExe('lazarus'+GetExecutableExt,Result) then exit;
282 
283   finally
284     EnvironmentOptions.LazarusDirectory:=OldLazarusDir;
285   end;
286 end;
287 
288 procedure SetupLazarusDirectory;
289 var
290   Dir, Note: String;
291   Quality: TSDFilenameQuality;
292   List: TSDFileInfoList;
293 begin
294   Dir:=EnvironmentOptions.GetParsedLazarusDirectory;
295   Quality:=CheckLazarusDirectoryQuality(Dir,Note);
296   if Quality<>sddqInvalid then exit;
297   // bad lazarus directory => searching a good one
298   dbgout('SetupLazarusDirectory:');
299   if EnvironmentOptions.LazarusDirectory<>'' then
300   begin
301     dbgout(' The Lazarus directory "',EnvironmentOptions.LazarusDirectory,'"');
302     if EnvironmentOptions.LazarusDirectory<>Dir then
303       dbgout(' => "',Dir,'"');
304     dbgout(' is invalid (Error: ',Note,')');
305     debugln(' Searching a proper one ...');
306   end else begin
307     debugln(' Searching ...');
308   end;
309   List:=SearchLazarusDirectoryCandidates(true);
310   try
311     if (List=nil) or (List.BestDir.Quality=sddqInvalid) then begin
312       debugln(['SetupLazarusDirectory: no proper Lazarus directory found.']);
313       exit;
314     end;
315     EnvironmentOptions.LazarusDirectory:=List.BestDir.Filename;
316     debugln(['SetupLazarusDirectory: using ',EnvironmentOptions.LazarusDirectory]);
317   finally
318     List.Free;
319   end;
320 end;
321 
CheckFPCExeQualitynull322 function CheckFPCExeQuality(AFilename: string; out Note: string;
323   TestSrcFilename: string): TSDFilenameQuality;
324 var
325   CfgCache: TPCTargetConfigCache;
326 
CheckPPUnull327   function CheckPPU(const AnUnitName: string): boolean;
328   begin
329     if (CfgCache.Units=nil)
330     or not FilenameExtIs(CfgCache.Units[AnUnitName],'ppu',true) then
331     begin
332       Note:=Format(lisPpuNotFoundCheckYourFpcCfg, [AnUnitName]);
333       Result:=false;
334     end else
335       Result:=true;
336   end;
337 
338 var
339   i: LongInt;
340   ShortFilename: String;
341 begin
342   Result:=sddqInvalid;
343   AFilename:=TrimFilename(AFilename);
344   if not FileExistsCached(AFilename) then
345   begin
346     Note:=lisFileNotFound4;
347     exit;
348   end;
349   if DirPathExistsCached(AFilename) then
350   begin
351     Note:=lisFileIsDirectory;
352     exit;
353   end;
354   if not FileIsExecutableCached(AFilename) then
355   begin
356     Note:=lisFileIsNotAnExecutable;
357     exit;
358   end;
359 
360   // do not execute unusual exe files
361   ShortFilename:=ExtractFileNameOnly(AFilename);
362   if (CompareFilenames(ShortFilename,'fpc')<>0)
363   and (CompareFilenames(LeftStr(ShortFilename,3),'ppc')<>0)
364   then begin
365     Note:=lisUnusualCompilerFileNameUsuallyItStartsWithFpcPpcOr;
366     exit(sddqIncomplete);
367   end;
368 
369   if TestSrcFilename<>'' then
370   begin
371     CfgCache:=CodeToolBoss.CompilerDefinesCache.ConfigCaches.Find(
372                                                        AFilename,'','','',true);
373     if CfgCache.NeedsUpdate then
374       CfgCache.Update(TestSrcFilename);
375     i:=CfgCache.IndexOfUsedCfgFile;
376     if i<0 then
377     begin
378       Note:=SafeFormat(lisCompilerCfgIsMissing,['fpc.cfg']);
379       exit;
380     end;
381     if not CfgCache.HasPPUs then
382     begin
383       Note:=lisSystemPpuNotFoundCheckYourFpcCfg;
384       exit;
385     end;
386     if (CfgCache.RealTargetCPU='jvm') then
387     begin
388       if not CheckPPU('uuchar') then exit;
389     end else begin
390       if not CheckPPU('classes') then exit;
391     end;
392   end;
393 
394   Note:=lisOk;
395   Result:=sddqCompatible;
396 end;
397 
SearchFPCExeCandidatesnull398 function SearchFPCExeCandidates(StopIfFits: boolean;
399   const TestSrcFilename: string): TSDFileInfoList;
400 var
401   ShortCompFile: String;
402 
CheckFilenull403   function CheckFile(AFilename: string; var List: TSDFileInfoList): boolean;
404   var
405     Item: TSDFileInfo;
406     RealFilename: String;
407   begin
408     Result:=false;
409     if AFilename='' then exit;
410     ForcePathDelims(AFilename);
411     // check if already checked
412     if Assigned(List) and List.CaptionExists(AFilename) then exit;
413     EnvironmentOptions.CompilerFilename:=AFilename;
414     RealFilename:=EnvironmentOptions.GetParsedCompilerFilename;
415     debugln(['SearchCompilerCandidates Value=',AFilename,' File=',RealFilename]);
416     if RealFilename='' then exit;
417     // check if exists
418     if not FileExistsCached(RealFilename) then exit;
419     // add to list and check quality
420     if List=nil then
421       List:=TSDFileInfoList.create(true);
422     Item:=List.AddNewItem(RealFilename, AFilename);
423     Item.Quality:=CheckFPCExeQuality(RealFilename, Item.Note, TestSrcFilename);
424     Result:=(Item.Quality=sddqCompatible) and StopIfFits;
425   end;
426 
CheckSubDirsnull427   function CheckSubDirs(ADir: string; var List: TSDFileInfoList): boolean;
428   // search for ADir\bin\i386-win32\fpc.exe
429   // and for ADir\*\bin\i386-win32\fpc.exe
430   var
431     FileInfo: TSearchRec;
432     SubFile: String;
433   begin
434     Result:=true;
435     ADir:=AppendPathDelim(TrimFilename(ExpandFileNameUTF8(TrimFilename(ADir))));
436     SubFile:='bin/$(TargetCPU)-$(TargetOS)/'+ShortCompFile;
437     if CheckFile(ADir+SubFile,List) then
438       exit;
439     try
440       if FindFirstUTF8(ADir+AllFilesMask,faAnyFile,FileInfo)=0 then begin
441         repeat
442           // check if special file
443           if (FileInfo.Name='.') or (FileInfo.Name='..') or (FileInfo.Name='') then
444             continue;
445           if ((FileInfo.Attr and faDirectory)>0)
446           and CheckFile(ADir+FileInfo.Name+PathDelim+SubFile,List) then
447             exit;
448         until FindNextUTF8(FileInfo)<>0;
449       end;
450     finally
451       FindCloseUTF8(FileInfo);
452     end;
453     Result:=false;
454   end;
455 
456 var
457   AFilename: String;
458   Files: TStringList;
459   i: Integer;
460   SysDrive: String;
461   ProgDir: String;
462   OldCompilerFilename: String;
463 begin
464   Result:=nil;
465 
466   OldCompilerFilename:=EnvironmentOptions.CompilerFilename;
467   try
468     // check current setting
469     if CheckFile(EnvironmentOptions.CompilerFilename,Result) then exit;
470 
471     // check the primary options
472     AFilename:=GetValueFromPrimaryConfig(EnvOptsConfFileName,
473                                     'EnvironmentOptions/CompilerFilename/Value');
474     if CheckFile(AFilename,Result) then exit;
475 
476     // check the secondary options
477     AFilename:=GetValueFromSecondaryConfig(EnvOptsConfFileName,
478                                     'EnvironmentOptions/CompilerFilename/Value');
479     if CheckFile(AFilename,Result) then exit;
480 
481     // check environment variable PP
482     AFileName := GetEnvironmentVariableUTF8('PP');
483     if CheckFile(AFilename,Result) then exit;
484 
485     // search fpc(.exe) in PATH
486     if CheckFile('fpc'+ExeExt,Result) then exit;
487 
488     // search ppccpu(.exe) in PATH
489     if CheckFile(GetDefaultCompilerFilename(GetCompiledTargetCPU),Result) then exit;
490 
491     // check history
492     Files:=EnvironmentOptions.CompilerFileHistory;
493     if Files<>nil then
494       for i:=0 to Files.Count-1 do
495         if CheckFile(Files[i],Result) then exit;
496 
497     // check paths with versions
498     ShortCompFile:='fpc'+ExeExt;
499 
500     // check $(LazarusDir)\fpc\3.0.0\bin\i386-win32\fpc.exe
501     if CheckFile(GetForcedPathDelims('$(LazarusDir)/fpc/'+{$I %FPCVERSION%}+'/bin/'+GetCompiledTargetCPU+'-'+GetCompiledTargetOS+'/')+ShortCompFile,Result)
502       then exit;
503 
504     // check $(LazarusDir)\fpc\bin\i386-win32\fpc.exe
505     if CheckFile(GetForcedPathDelims('$(LazarusDir)/fpc/bin/'+GetCompiledTargetCPU+'-'+GetCompiledTargetOS+'/')+ShortCompFile,Result)
506       then exit;
507 
508     // check common directories
509     Files:=TStringList.Create;
510     try
511       GetDefaultCompilerFilenames(Files);
512       for i:=0 to Files.Count-1 do
513         if CheckFile(Files[i],Result) then exit;
514     finally
515       Files.Free;
516     end;
517 
518     // Windows-only locations:
519     if (GetDefaultSrcOSForTargetOS(GetCompiledTargetOS)='win') then begin
520       SysDrive:=GetEnvironmentVariableUTF8('SYSTEMDRIVE');
521       if SysDrive='' then SysDrive:='C:';
522       SysDrive:=AppendPathDelim(SysDrive);
523       // %SYSTEMDRIVE%\fpc\
524       if CheckSubDirs(SysDrive+'FPC',Result) then exit;
525       // %SYSTEMDRIVE%\pp\
526       if CheckSubDirs(SysDrive+'pp',Result) then exit;
527       // %PROGRAMFILES%\FPC\*
528       ProgDir:=AppendPathDelim(GetEnvironmentVariableUTF8('PROGRAMFILES'));
529       if (ProgDir<>'')
530       and CheckSubDirs(ProgDir+'FPC',Result) then exit;
531     end;
532 
533   finally
534     EnvironmentOptions.CompilerFilename:=OldCompilerFilename;
535   end;
536 end;
537 
538 procedure SetupFPCExeFilename;
539 var
540   Filename, Note: String;
541   Quality: TSDFilenameQuality;
542   List: TSDFileInfoList;
543 begin
544   Filename:=EnvironmentOptions.GetParsedCompilerFilename;
545   Quality:=CheckFPCExeQuality(Filename,Note,'');
546   if Quality<>sddqInvalid then exit;
547   // bad compiler
548   dbgout('SetupCompilerFilename:');
549   if EnvironmentOptions.CompilerFilename<>'' then
550   begin
551     dbgout(' The compiler path "',EnvironmentOptions.CompilerFilename,'"');
552     if EnvironmentOptions.CompilerFilename<>Filename then
553       dbgout(' => "',Filename,'"');
554     dbgout(' is invalid (Error: ',Note,')');
555     debugln(' Searching a proper one ...');
556   end else begin
557     debugln(' Searching compiler ...');
558   end;
559   List:=SearchFPCExeCandidates(true, CodeToolBoss.CompilerDefinesCache.TestFilename);
560   try
561     if (List=nil) or (List.BestDir.Quality=sddqInvalid) then begin
562       debugln(['SetupCompilerFilename: no proper compiler found.']);
563       exit;
564     end;
565     EnvironmentOptions.CompilerFilename:=List.BestDir.Filename;
566     debugln(['SetupCompilerFilename: using ',EnvironmentOptions.CompilerFilename]);
567   finally
568     List.Free;
569   end;
570 end;
571 
ValueOfKeynull572 function ValueOfKey(const aLine, aKey: string; var aValue: string): boolean;
573 // If aKey is found in aLine, separate a quoted number following "aKey =",
574 //  save it to aValue and return True. Return False if aKey is not found.
575 // Example line:     version_nr = '2';
576 var
577   i,j: Integer;
578 begin
579   Result:=False;
580   i:=Pos(aKey, aLine);
581   if i>0 then begin            // aKey found
582     i:=PosEx('=', aLine, i+Length(aKey));
583     if i>0 then begin          // '=' found
584       i:=PosEx('''', aLine, i+1);
585       if i>0 then begin        // Opening quote found
586         j:=PosEx('''', aLine, i+1);
587         if j>0 then begin      // Closing quote found
588           aValue:=Copy(aLine, i+1, j-i-1);
589           Result:=True;
590         end;
591       end;
592     end;
593   end;
594 end;
595 
CheckPas2jsQualitynull596 function CheckPas2jsQuality(AFilename: string; out Note: string;
597   TestSrcFilename: string): TSDFilenameQuality;
598 var
599   i: LongInt;
600   ShortFilename: String;
601   CfgCache: TPCTargetConfigCache;
602 begin
603   Result:=sddqInvalid;
604   AFilename:=TrimFilename(AFilename);
605   if not FileExistsCached(AFilename) then
606   begin
607     Note:=lisFileNotFound4;
608     exit;
609   end;
610   if DirPathExistsCached(AFilename) then
611   begin
612     Note:=lisFileIsDirectory;
613     exit;
614   end;
615   if not FileIsExecutableCached(AFilename) then
616   begin
617     Note:=lisFileIsNotAnExecutable;
618     exit;
619   end;
620 
621   // do not execute unusual exe files
622   ShortFilename:=ExtractFileNameOnly(AFilename);
623   if (CompareText(LeftStr(ShortFilename,6),'pas2js')<>0)
624   then begin
625     Note:=lisUnusualPas2jsCompilerFileNameUsuallyItStartsWithPa;
626     exit(sddqIncomplete);
627   end;
628 
629   if TestSrcFilename<>'' then
630   begin
631     CfgCache:=CodeToolBoss.CompilerDefinesCache.ConfigCaches.Find(
632                                                        AFilename,'','','',true);
633     if CfgCache.NeedsUpdate then
634       CfgCache.Update(TestSrcFilename);
635     i:=CfgCache.IndexOfUsedCfgFile;
636     if i<0 then
637     begin
638       Note:=SafeFormat(lisCompilerCfgIsMissing,['pas2js.cfg']);
639       exit;
640     end;
641     //if not CheckPas('classes') then exit;
642   end;
643 
644   Note:=lisOk;
645   Result:=sddqCompatible;
646 end;
647 
CheckFPCSrcDirQualitynull648 function CheckFPCSrcDirQuality(ADirectory: string; out Note: string;
649   const FPCVer: String; aUseFileCache: Boolean = True): TSDFilenameQuality;
isnull650 // aUseFileCache = False when this function is called from a thread.
651 // File Cache is not thread safe.
652 
653   function DirPathExistsInternal(const FileName: String): Boolean;
654   begin
655     if aUseFileCache then
656       Result:=DirPathExistsCached(FileName)
657     else
658       Result:=DirPathExists(FileName)
659   end;
660 
FileExistsInternalnull661   function FileExistsInternal(const Filename: string): boolean;
662   begin
663     if aUseFileCache then
664       Result:=FileExistsCached(FileName)
665     else
666       Result:=FileExistsUTF8(FileName)
667   end;
668 
SubDirExistsnull669   function SubDirExists(SubDir: string): boolean;
670   begin
671     SubDir:=GetForcedPathDelims(SubDir);
672     if DirPathExistsInternal(ADirectory+SubDir) then exit(true);
673     Result:=false;
674     Note:=Format(lisDirectoryNotFound2, [SubDir]);
675   end;
676 
SubFileExistsnull677   function SubFileExists(SubFile: string): boolean;
678   begin
679     SubFile:=GetForcedPathDelims(SubFile);
680     if FileExistsInternal(ADirectory+SubFile) then exit(true);
681     Result:=false;
682     Note:=Format(lisFileNotFound3, [SubFile]);
683   end;
684 
685 var
686   VersionFile: String;
687   sl: TStringList;
688   i: Integer;
689   VersionNr: String;
690   ReleaseNr: String;
691   PatchNr: String;
692   SrcVer: String;
693   Line: String;
694 begin
695   Result:=sddqInvalid;
696   Note:='';
697   ADirectory:=TrimFilename(ADirectory);
698   if not DirPathExistsInternal(ADirectory) then
699   begin
700     Note:=lisISDDirectoryNotFound;
701     exit;
702   end;
703   ADirectory:=AppendPathDelim(ADirectory);
704   if not SubDirExists('rtl') then exit;
705   if not SubDirExists('packages') then exit;
706   Result:=sddqIncomplete;
707   if not SubFileExists('rtl/linux/system.pp') then exit;
708   // check version
709   if (FPCVer<>'') then
710   begin
711     VersionFile:=ADirectory+'compiler'+PathDelim+'version.pas';
712     if FileExistsInternal(VersionFile) then
713     begin
714       sl:=TStringList.Create;
715       try
716         try
717           sl.LoadFromFile(VersionFile);
718           VersionNr:='';
719           ReleaseNr:='';
720           PatchNr:='';
721           for i:=0 to sl.Count-1 do
722           begin
723             Line:=sl[i];
724             if ValueOfKey(Line,'version_nr', VersionNr) then begin end
725             else if ValueOfKey(Line,'release_nr', ReleaseNr) then begin end
726             else if ValueOfKey(Line,'patch_nr',   PatchNr) then
727               break;
728           end;
729           SrcVer:=VersionNr+'.'+ReleaseNr+'.'+PatchNr;
730           if SrcVer<>FPCVer then
731           begin
732             Note:=Format(lisFoundVersionExpected, [SrcVer, FPCVer]);
733             SrcVer:=VersionNr+'.'+ReleaseNr+'.';
734             if LeftStr(FPCVer,length(SrcVer))=SrcVer then
735               Result:=sddqWrongMinorVersion
736             else
737               Result:=sddqWrongVersion;
738             exit;
739           end;
740         except
741         end;
742       finally
743         sl.Free;
744       end;
745     end;
746   end;
747   Note:=lisOk;
748   Result:=sddqCompatible;
749 end;
750 
SearchFPCSrcDirCandidatesnull751 function SearchFPCSrcDirCandidates(StopIfFits: boolean; const FPCVer: string): TSDFileInfoList;
752 
Checknull753   function Check(Dir: string; var List: TSDFileInfoList): boolean;
754   var
755     Item: TSDFileInfo;
756     RealDir: String;
757   begin
758     Result:=false;
759     Dir:=ChompPathDelim(GetForcedPathDelims(Dir));
760     if Dir='' then exit;
761     // check if already checked
762     if Assigned(List) and List.CaptionExists(Dir) then exit;
763     EnvironmentOptions.FPCSourceDirectory:=Dir;
764     RealDir:=EnvironmentOptions.GetParsedFPCSourceDirectory;
765     debugln(['SearchFPCSrcDirCandidates Value=',Dir,' File=',RealDir]);
766     if RealDir='' then exit;
767     // check if exists
768     if not DirPathExistsCached(RealDir) then exit;
769     // add to list and check quality
770     if List=nil then
771       List:=TSDFileInfoList.Create(true);
772     Item:=List.AddNewItem(RealDir, Dir);
773     Item.Quality:=CheckFPCSrcDirQuality(RealDir, Item.Note, FPCVer);
774     Result:=(Item.Quality=sddqCompatible) and StopIfFits;
775   end;
776 
777 var
778   AFilename: String;
779   Dirs: TStringList;
780   i: Integer;
781   OldFPCSrcDir: String;
782 begin
783   Result:=nil;
784 
785   OldFPCSrcDir:=EnvironmentOptions.FPCSourceDirectory;
786   try
787     // check current setting
788     if Check(EnvironmentOptions.FPCSourceDirectory,Result) then exit;
789 
790     // check the primary options
791     AFilename:=GetValueFromPrimaryConfig(EnvOptsConfFileName,
792                                  'EnvironmentOptions/FPCSourceDirectory/Value');
793     if Check(AFilename,Result) then exit;
794 
795     // check the secondary options
796     AFilename:=GetValueFromSecondaryConfig(EnvOptsConfFileName,
797                                  'EnvironmentOptions/FPCSourceDirectory/Value');
798     if Check(AFilename,Result) then exit;
799 
800     // check environment variable FPCDIR
801     AFileName := GetEnvironmentVariableUTF8('FPCDIR');
802     if Check(AFilename,Result) then exit;
803 
804     // check relative to FPCDIR
805     if AFileName <> '' then
806       if Check(AFilename + '/../fpcsrc', Result) then exit;
807 
808     // check history
809     Dirs:=EnvironmentOptions.FPCSourceDirHistory;
810     if Dirs<>nil then
811       for i:=0 to Dirs.Count-1 do
812         if Check(Dirs[i],Result) then exit;
813 
814     // $(LazarusDir)/fpc/$(FPCVer)/source
815     AFilename:='$(LazarusDir)/fpc/$(FPCVer)/source';
816     if Check(AFilename,Result) then exit;
817 
818     // check relative to fpc.exe
819     AFilename:='$Path($(CompPath))/../../source';
820     if Check(AFilename,Result) then exit;
821 
822     // check common directories
823     Dirs:=GetDefaultFPCSrcDirectories;
824     try
825       if Dirs<>nil then
826         for i:=0 to Dirs.Count-1 do
827           if Check(Dirs[i],Result) then exit;
828     finally
829       Dirs.Free;
830     end;
831   finally
832     EnvironmentOptions.FPCSourceDirectory:=OldFPCSrcDir;
833   end;
834 end;
835 
CheckFppkgConfigurationnull836 function CheckFppkgConfiguration(var ConfigFile: string; out Msg: string): TSDFilenameQuality;
837 var
838   Fppkg: TFppkgHelper;
839 begin
840   Fppkg := TFppkgHelper.Instance;
841   Fppkg.OverrideConfigurationFilename := ConfigFile;
842 
843   if Fppkg.IsProperlyConfigured(Msg) then
844     Result := sddqCompatible
845   else
846     Result := sddqInvalid;
847   ConfigFile := Fppkg.GetConfigurationFileName;
848 end;
849 
CheckFppkgConfigFilenull850 function CheckFppkgConfigFile(const AFilename: string; out Note: string): TSDFilenameQuality;
851 begin
852   Note := '';
853   if AFilename='' then
854   begin
855     Result := sddqCompatible;
856   end
857   else
858   begin
859     if not FileExistsCached(AFilename) then
860     begin
861       Result := sddqIncomplete;
862       Note:=lisFileNotFound;
863     end
864     else
865     begin
866       if DirectoryExists(AFilename) then
867       begin
868         Result := sddqInvalid;
869         Note:=lisFileIsDirectory;
870       end
871       else
872         Result := sddqCompatible;
873     end;
874   end;
875 end;
876 
CheckMakeExeQualitynull877 function CheckMakeExeQuality(AFilename: string; out Note: string
878   ): TSDFilenameQuality;
879 begin
880   Result:=sddqInvalid;
881   AFilename:=TrimFilename(AFilename);
882   if not FileExistsCached(AFilename) then
883   begin
884     Note:=lisFileNotFound4;
885     exit;
886   end;
887   if DirPathExistsCached(AFilename) then
888   begin
889     Note:=lisFileIsDirectory;
890     exit;
891   end;
892   if not FileIsExecutableCached(AFilename) then
893   begin
894     Note:=lisFileIsNotAnExecutable;
895     exit;
896   end;
897 
898   // Windows-only locations:
899   if (GetDefaultSrcOSForTargetOS(GetCompiledTargetOS)='win') then begin
900     // under Windows, make.exe is in the same directory as fpc.exe
901     // other make.exe are often incompatible
902     if not FileExistsCached(ExtractFilePath(AFilename)+'fpc.exe') then begin
903       Note:=Format(lisThereIsNoFpcExeInTheDirectoryOfUsuallyTheMakeExecu, [
904         ExtractFilename(AFilename)]);
905       Result:=sddqMakeNotWithFpc;
906       exit;
907     end;
908   end;
909 
910   Note:=lisOk;
911   Result:=sddqCompatible;
912 end;
913 
SearchMakeExeCandidatesnull914 function SearchMakeExeCandidates(StopIfFits: boolean): TSDFileInfoList;
915 
CheckFilenull916   function CheckFile(AFilename: string; var List: TSDFileInfoList): boolean;
917   var
918     Item: TSDFileInfo;
919     RealFilename: String;
920   begin
921     Result:=false;
922     if AFilename='' then exit;
923     ForcePathDelims(AFilename);
924     // check if already checked
925     if Assigned(List) and List.CaptionExists(AFilename) then exit;
926     EnvironmentOptions.MakeFilename:=AFilename;
927     RealFilename:=EnvironmentOptions.GetParsedMakeFilename;
928     debugln(['SearchMakeExeCandidates Value=',AFilename,' File=',RealFilename]);
929     if RealFilename='' then exit;
930     // check if exists
931     if not FileExistsCached(RealFilename) then exit;
932     // add to list and check quality
933     if List=nil then
934       List:=TSDFileInfoList.create(true);
935     Item:=List.AddNewItem(RealFilename, AFilename);
936     Item.Quality:=CheckMakeExeQuality(RealFilename, Item.Note);
937     Result:=(Item.Quality=sddqCompatible) or ((Item.Quality=sddqMakeNotWithFpc) and StopIfFits);
938   end;
939 
940 var
941   OldMakeFilename: String;
942   AFilename: String;
943   Files: TStringList;
944   i: Integer;
945 begin
946   Result:=nil;
947 
948   OldMakeFilename:=EnvironmentOptions.MakeFilename;
949   try
950     // check current setting
951     if CheckFile(EnvironmentOptions.MakeFilename,Result) then exit;
952 
953     // check the primary options
954     AFilename:=GetValueFromPrimaryConfig(EnvOptsConfFileName,
955                                     'EnvironmentOptions/MakeFilename/Value');
956     if CheckFile(AFilename,Result) then exit;
957 
958     // check the secondary options
959     AFilename:=GetValueFromSecondaryConfig(EnvOptsConfFileName,
960                                     'EnvironmentOptions/MakeFilename/Value');
961     if CheckFile(AFilename,Result) then exit;
962 
963     // Windows-only locations:
964     if (GetDefaultSrcOSForTargetOS(GetCompiledTargetOS)='win') then begin
965       // check make in fpc.exe directory
966       if CheckFile(GetForcedPathDelims('$Path($(CompPath))\make.exe'),Result)
967       then exit;
968       // check $(LazarusDir)\fpc\bin\i386-win32\fpc.exe
969       if CheckFile(GetForcedPathDelims('$(LazarusDir)\fpc\bin\$(TargetCPU)-$(TargetOS)\make.exe'),Result)
970         then exit;
971     end;
972 
973     // check history
974     Files:=EnvironmentOptions.MakeFileHistory;
975     if Files<>nil then
976       for i:=0 to Files.Count-1 do
977         if CheckFile(Files[i],Result) then exit;
978 
979     // check PATH
980     {$IFDEF FreeBSD}
981     AFilename:='gmake';
982     {$ELSE}
983     AFilename:='make';
984     {$ENDIF}
985     {$IFDEF dragonfly}
986     AFilename:='gmake';
987     {$ENDIF}
988     AFilename+=GetExecutableExt;
989     if CheckFile(FindDefaultExecutablePath(AFilename),Result) then exit;
990 
991     // check common directories
992     Files:=TStringList.Create;
993     try
994       GetDefaultMakeFilenames(Files);
995       for i:=0 to Files.Count-1 do
996         if CheckFile(Files[i],Result) then exit;
997     finally
998       Files.Free;
999     end;
1000   finally
1001     EnvironmentOptions.MakeFilename:=OldMakeFilename;
1002   end;
1003 end;
1004 
GetValueFromPrimaryConfignull1005 function GetValueFromPrimaryConfig(OptionFilename, Path: string): string;
1006 begin
1007   if not FilenameIsAbsolute(OptionFilename) then
1008     OptionFilename:=AppendPathDelim(GetPrimaryConfigPath)+OptionFilename;
1009   Result:=GetValueFromIDEConfig(OptionFilename,Path);
1010 end;
1011 
GetValueFromSecondaryConfignull1012 function GetValueFromSecondaryConfig(OptionFilename, Path: string): string;
1013 begin
1014   if not FilenameIsAbsolute(OptionFilename) then
1015     OptionFilename:=AppendPathDelim(GetSecondaryConfigPath)+OptionFilename;
1016   Result:=GetValueFromIDEConfig(OptionFilename,Path);
1017 end;
1018 
GetValueFromIDEConfignull1019 function GetValueFromIDEConfig(OptionFilename, Path: string): string;
1020 var
1021   XMLConfig: TXMLConfig;
1022 begin
1023   Result:='';
1024   if FileExistsCached(OptionFilename) then
1025   begin
1026     try
1027       XMLConfig:=TXMLConfig.Create(OptionFilename);
1028       try
1029         Result:=XMLConfig.GetValue(Path,'');
1030       finally
1031         XMLConfig.Free;
1032       end;
1033     except
1034       on E: Exception do begin
1035         debugln(['GetValueFromIDEConfig File='+OptionFilename+': '+E.Message]);
1036       end;
1037     end;
1038   end;
1039 end;
1040 
SafeFormatnull1041 function SafeFormat(const Fmt: String; const Args: array of const): String;
1042 begin
1043   // try with translated resourcestring
1044   try
1045     Result:=Format(Fmt,Args);
1046     exit;
1047   except
1048     on E: Exception do
1049       debugln(['ERROR: SafeFormat: ',E.Message]);
1050   end;
1051   // translation didn't work
1052   // ToDo: find out how to get the resourcestring default value
1053   //ResetResourceTables;
1054 
1055   // use a safe fallback
1056   Result:=SimpleFormat(Fmt,Args);
1057 end;
1058 
1059 { TSDFileInfoList }
1060 
AddNewItemnull1061 function TSDFileInfoList.AddNewItem(aFilename, aCaption: string): TSDFileInfo;
1062 begin
1063   Result:=TSDFileInfo.Create;
1064   Result.Filename:=aFilename;
1065   Result.Caption:=aCaption;
1066   Add(Result);
1067 end;
1068 
CaptionExistsnull1069 function TSDFileInfoList.CaptionExists(aCaption: string): boolean;
1070 var
1071   i: Integer;
1072 begin
1073   Result:=false;
1074   for i:=0 to Count-1 do
1075     if CompareFilenames(aCaption,TSDFileInfo(Items[i]).Caption)=0 then
1076       exit(true);
1077 end;
1078 
BestDirnull1079 function TSDFileInfoList.BestDir: TSDFileInfo;
1080 begin
1081   if Count > 0 then
1082     Result:=TSDFileInfo(Items[Count-1])
1083   else
1084     Result:=Nil;
1085 end;
1086 
1087 end.
1088 
1089