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     This unit helps to setup and configure the codetools.
25 
26   Example:
27     Create an empty unit empty.pas and do
28 
29     Options:=TCodeToolsOptions.Create;
30     Options.LoadFromFile('config.xml');
31     Options.FPCPath:='/usr/bin/ppc386';
32     Options.FPCSrcDir:='/home/username/freepascal/fpc';
33     Options.LazarusSrcDir:='/home/username/pascal/lazarus';
34     Options.ProjectDir:='/home/username/pascal/project1/';
35     Options.TestPascalFile:=Options.ProjectDir+'empty.pas';
36     CodeToolBoss.Init(Options);
37     Options.SaveToFile('config.xml');
38     Options.Free;
39 
40     .. use CodeToolBoss ..
41 
42 }
43 unit CodeToolsConfig;
44 
45 {$mode objfpc}{$H+}
46 
47 {$I codetools.inc}
48 
49 interface
50 
51 uses
52   Classes, SysUtils, Laz2_XMLCfg, Laz2_XMLRead, Laz2_XMLWrite, Laz2_DOM,
53   FileProcs, LazFileUtils, LazFileCache, LazUTF8, CodeCache, DefineTemplates;
54 
55 type
56 
57   { TCodeBufXMLConfig }
58 
59   TCodeBufXMLConfig = class(TXMLConfig)
60   private
61     FCodeCache: TCodeCache;
62   protected
63     fKeepFileAttributes: boolean;
64     procedure ReadXMLFile(out ADoc: TXMLDocument; const AFilename: String); override;
65     procedure WriteXMLFile(ADoc: TXMLDocument; const AFileName: String); override;
GetCachenull66     function GetCache: TCodeCache;
67   public
68     constructor CreateWithCache(AFilename: string;
69       LoadContent: boolean = true;        // init/load from disk
70       LoadFileAttributes: boolean = true; // load lineending and encoding
71       ASource: string = '';               // init with this source
72       ACache: TCodeCache = nil);
73     property CodeCache: TCodeCache read FCodeCache write FCodeCache;
74     property KeepFileAttributes: boolean read fKeepFileAttributes write fKeepFileAttributes;
75   end;
76 
77 var
78   DefaultConfigCodeCache: TCodeCache = nil; // set by CodeToolBoss
79 
80 type
81 
82   { TCodeToolsOptions }
83 
84   TCodeToolsOptions = class
85   private
86     FConfigCaches: TPCTargetConfigCaches;
87     FFPCOptions: string;
88     FFPCPath: string;
89     FFPCSrcDir: string;
90     FFPCUnitPath: string;
91     FLazarusSrcDir: string;
92     FLazarusSrcOptions: string;
93     FLCLWidgetType: string;
94     FModified: boolean;
95     FPPUExt: string;
96     FProjectDir: string;
97     FSourceCaches: TFPCSourceCaches;
98     FTargetOS: string;
99     FTargetProcessor: string;
100     FTestPascalFile: string;
101     FUnitLinkList: string;
102     FUnitLinkListValid: boolean;
103     procedure SetFPCOptions(const AValue: string);
104     procedure SetFPCPath(const AValue: string);
105     procedure SetFPCSrcDir(const AValue: string);
106     procedure SetFPCUnitPath(const AValue: string);
107     procedure SetLazarusSrcDir(const AValue: string);
108     procedure SetLCLWidgetType(const AValue: string);
109     procedure SetLazarusSrcOptions(const AValue: string);
110     procedure SetModified(const AValue: boolean);
111     procedure SetPPUExt(const AValue: string);
112     procedure SetProjectDir(const AValue: string);
113     procedure SetTargetOS(const AValue: string);
114     procedure SetTargetProcessor(const AValue: string);
115     procedure SetTestPascalFile(const AValue: string);
116     procedure SetUnitLinkList(const AValue: string);
117     procedure SetUnitLinkListValid(const AValue: boolean);
118   public
119     constructor Create;
120     destructor Destroy; override;
121     procedure InitWithEnvironmentVariables;
FindDefaultCompilerFilenamenull122     function FindDefaultCompilerFilename: string;
123 
124     procedure SaveToXMLConfig(XMLConfig: TXMLConfig; const Path: string);
125     procedure LoadFromXMLConfig(XMLConfig: TXMLConfig; const Path: string);
126     procedure SaveToFile(const Filename: string);
127     procedure LoadFromFile(const Filename: string);
128 
129     property Modified: boolean read FModified write SetModified;
130 
131     // FPC
132     property FPCSrcDir: string read FFPCSrcDir write SetFPCSrcDir; // e.g. /usr/share/fpcsrc
133     property FPCPath: string read FFPCPath write SetFPCPath; // e.g. /usr/bin/fpc or /usr/bin/ppc386
134     property FPCOptions: string read FFPCOptions write SetFPCOptions; // extra options for fpc
135     property TargetOS: string read FTargetOS write SetTargetOS;
136     property TargetProcessor: string read FTargetProcessor write SetTargetProcessor;
137     property TestPascalFile: string read FTestPascalFile write SetTestPascalFile; // points to an empty unit
138     property FPCUnitPath: string read FFPCUnitPath write SetFPCUnitPath;
139     property PPUExt: string read FPPUExt write SetPPUExt;
140     property SourceCaches: TFPCSourceCaches read FSourceCaches;
141     property ConfigCaches: TPCTargetConfigCaches read FConfigCaches;
142     property UnitLinkListValid: boolean read FUnitLinkListValid write SetUnitLinkListValid;
143     property UnitLinkList: string read FUnitLinkList write SetUnitLinkList;
144 
145     // Project
146     property ProjectDir: string read FProjectDir write SetProjectDir;
147 
148     // Lazarus
149     property LazarusSrcDir: string read FLazarusSrcDir write SetLazarusSrcDir;
150     property LCLWidgetType: string read FLCLWidgetType write SetLCLWidgetType;
151     property LazarusSrcOptions: string read FLazarusSrcOptions write SetLazarusSrcOptions;
152   end;
153 
154 implementation
155 
156 { TCodeToolsOptions }
157 
158 procedure TCodeToolsOptions.SetFPCOptions(const AValue: string);
159 begin
160   if FFPCOptions=AValue then exit;
161   FFPCOptions:=AValue;
162   Modified:=true;
163 end;
164 
165 procedure TCodeToolsOptions.SetFPCPath(const AValue: string);
166 var
167   NewValue: String;
168 begin
169   NewValue:=TrimAndExpandFilename(AValue);
170   if FFPCPath=NewValue then exit;
171   FFPCPath:=NewValue;
172   FUnitLinkListValid:=false;
173   Modified:=true;
174 end;
175 
176 procedure TCodeToolsOptions.SetFPCSrcDir(const AValue: string);
177 var
178   NewValue: String;
179 begin
180   NewValue:=TrimAndExpandFilename(AValue);
181   if FFPCSrcDir=NewValue then exit;
182   FFPCSrcDir:=NewValue;
183   FUnitLinkListValid:=false;
184   Modified:=true;
185 end;
186 
187 procedure TCodeToolsOptions.SetFPCUnitPath(const AValue: string);
188 begin
189   if FFPCUnitPath=AValue then exit;
190   FFPCUnitPath:=AValue;
191   FUnitLinkListValid:=false;
192   Modified:=true;
193 end;
194 
195 procedure TCodeToolsOptions.SetLazarusSrcDir(const AValue: string);
196 var
197   NewValue: String;
198 begin
199   NewValue:=TrimAndExpandFilename(AValue);
200   if FLazarusSrcDir=NewValue then exit;
201   FLazarusSrcDir:=NewValue;
202   Modified:=true;
203 end;
204 
205 procedure TCodeToolsOptions.SetLCLWidgetType(const AValue: string);
206 begin
207   if FLCLWidgetType=AValue then exit;
208   FLCLWidgetType:=AValue;
209   Modified:=true;
210 end;
211 
212 procedure TCodeToolsOptions.SetLazarusSrcOptions(const AValue: string);
213 begin
214   if FLazarusSrcOptions=AValue then exit;
215   FLazarusSrcOptions:=AValue;
216   Modified:=true;
217 end;
218 
219 procedure TCodeToolsOptions.SetModified(const AValue: boolean);
220 begin
221   if FModified=AValue then exit;
222   FModified:=AValue;
223 end;
224 
225 procedure TCodeToolsOptions.SetPPUExt(const AValue: string);
226 begin
227   if FPPUExt=AValue then exit;
228   FPPUExt:=AValue;
229   Modified:=true;
230 end;
231 
232 procedure TCodeToolsOptions.SetProjectDir(const AValue: string);
233 begin
234   if FProjectDir=AValue then exit;
235   FProjectDir:=AppendPathDelim(AValue);
236   Modified:=true;
237 end;
238 
239 procedure TCodeToolsOptions.SetTargetOS(const AValue: string);
240 begin
241   if FTargetOS=AValue then exit;
242   FTargetOS:=AValue;
243   FUnitLinkListValid:=false;
244   Modified:=true;
245 end;
246 
247 procedure TCodeToolsOptions.SetTargetProcessor(const AValue: string);
248 begin
249   if FTargetProcessor=AValue then exit;
250   FTargetProcessor:=AValue;
251   FUnitLinkListValid:=false;
252   Modified:=true;
253 end;
254 
255 procedure TCodeToolsOptions.SetTestPascalFile(const AValue: string);
256 begin
257   if FTestPascalFile=AValue then exit;
258   FTestPascalFile:=AValue;
259   Modified:=true;
260 end;
261 
262 procedure TCodeToolsOptions.SetUnitLinkList(const AValue: string);
263 begin
264   if FUnitLinkList=AValue then exit;
265   FUnitLinkList:=AValue;
266   Modified:=true;
267 end;
268 
269 procedure TCodeToolsOptions.SetUnitLinkListValid(const AValue: boolean);
270 begin
271   if FUnitLinkListValid=AValue then exit;
272   FUnitLinkListValid:=AValue;
273   Modified:=true;
274 end;
275 
276 constructor TCodeToolsOptions.Create;
277 begin
278   FPPUExt:='.ppu';
279   FLCLWidgetType:='gtk2';
280   FConfigCaches:=TPCTargetConfigCaches.Create(nil);
281   FSourceCaches:=TFPCSourceCaches.Create(nil);
282 end;
283 
284 destructor TCodeToolsOptions.Destroy;
285 begin
286   FreeAndNil(FConfigCaches);
287   FreeAndNil(FSourceCaches);
288   inherited Destroy;
289 end;
290 
291 procedure TCodeToolsOptions.InitWithEnvironmentVariables;
292 
293 {  procedure WriteEnv;
294   var
295     i: Integer;
296   begin
297     for i:=0 to GetEnvironmentVariableCount-1 do
298       debugln(['TCodeToolsOptions.InitWithEnvironmentVariables ',i,' ',GetEnvironmentStringUTF8(i)]);
299   end;
300 }
301 begin
302   if GetEnvironmentVariableUTF8('PP')<>'' then
303     FPCPath:=GetEnvironmentVariableUTF8('PP')
304   else if (FPCPath='') or not FileExistsCached(FPCPath) then
305     FPCPath:=FindDefaultCompilerFilename;
306   if GetEnvironmentVariableUTF8('FPCDIR')<>'' then
307     FPCSrcDir:=GetEnvironmentVariableUTF8('FPCDIR');
308   if GetEnvironmentVariableUTF8('LAZARUSDIR')<>'' then
309     LazarusSrcDir:=GetEnvironmentVariableUTF8('LAZARUSDIR');
310   if GetEnvironmentVariableUTF8('FPCTARGET')<>'' then
311     TargetOS:=GetEnvironmentVariableUTF8('FPCTARGET');
312   if GetEnvironmentVariableUTF8('FPCTARGETCPU')<>'' then
313     TargetProcessor:=GetEnvironmentVariableUTF8('FPCTARGETCPU');
314 end;
315 
FindDefaultCompilerFilenamenull316 function TCodeToolsOptions.FindDefaultCompilerFilename: string;
317 begin
318   Result:=SearchFileInPath(GetDefaultCompilerFilename,'',
319                            GetEnvironmentVariableUTF8('PATH'),PathSeparator,ctsfcDefault);
320 end;
321 
322 procedure TCodeToolsOptions.SaveToXMLConfig(XMLConfig: TXMLConfig;
323   const Path: string);
324 begin
325   XMLConfig.SetDeleteValue(Path+'FPC/Options/Value',FPCOptions,'');
326   XMLConfig.SetDeleteValue(Path+'FPC/CompilerPath/Value',FPCPath,'');
327   XMLConfig.SetDeleteValue(Path+'FPC/SrcDir/Value',FPCSrcDir,'');
328   XMLConfig.SetDeleteValue(Path+'FPC/UnitPath/Value',FPCUnitPath,'');
329   XMLConfig.SetDeleteValue(Path+'FPC/TargetOS/Value',TargetOS,'');
330   XMLConfig.SetDeleteValue(Path+'FPC/TargetProcessor/Value',TargetProcessor,'');
331   XMLConfig.SetDeleteValue(Path+'FPC/PPUExt/Value',PPUExt,'.ppu');
332   XMLConfig.SetDeleteValue(Path+'FPC/TestPascalFile/Value',TestPascalFile,'');
333   XMLConfig.SetDeleteValue(Path+'FPC/UnitLinkList/Value',UnitLinkList,'');
334   XMLConfig.SetDeleteValue(Path+'FPC/UnitLinkList/Valid',UnitLinkListValid,false);
335   XMLConfig.SetDeleteValue(Path+'Lazarus/SrcDir/Value',LazarusSrcDir,'');
336   XMLConfig.SetDeleteValue(Path+'Lazarus/SrcDirOptions/Value',LazarusSrcOptions,'');
337   XMLConfig.SetDeleteValue(Path+'Lazarus/LCLWidgetType/Value',LCLWidgetType,'');
338   XMLConfig.SetDeleteValue(Path+'Project/Dir/Value',ProjectDir,'');
339   FConfigCaches.SaveToXMLConfig(XMLConfig,Path+'FPCConfigCaches/');
340   FSourceCaches.SaveToXMLConfig(XMLConfig,Path+'FPCSrcDirCaches/');
341   Modified:=false;
342 end;
343 
344 procedure TCodeToolsOptions.LoadFromXMLConfig(XMLConfig: TXMLConfig;
345   const Path: string);
346 var
347   i: Integer;
348   UnitPath: string;
349 begin
350   FPCOptions:=XMLConfig.GetValue(Path+'FPC/Options/Value','');
351   FPCPath:=XMLConfig.GetValue(Path+'FPC/CompilerPath/Value','');
352   FPCSrcDir:=XMLConfig.GetValue(Path+'FPC/SrcDir/Value','');
353   UnitPath:=XMLConfig.GetValue(Path+'FPC/UnitPath/Value','');
354   for i:=1 to length(UnitPath) do
355     if (UnitPath[i] in [#0..#8,#10..#31]) then
356       UnitPath[i]:=';';
357   FPCUnitPath:=UnitPath;
358   TargetOS:=XMLConfig.GetValue(Path+'FPC/TargetOS/Value','');
359   TargetProcessor:=XMLConfig.GetValue(Path+'FPC/TargetProcessor/Value','');
360   PPUExt:=XMLConfig.GetValue(Path+'FPC/PPUExt/Value','.ppu');
361   TestPascalFile:=XMLConfig.GetValue(Path+'FPC/TestPascalFile/Value','');
362   UnitLinkList:=XMLConfig.GetValue(Path+'FPC/UnitLinkList/Value','');
363   // UnitLinkListValid must be set as last
364   UnitLinkListValid:=XMLConfig.GetValue(Path+'FPC/UnitLinkList/Valid',false);
365   FConfigCaches.LoadFromXMLConfig(XMLConfig,Path+'FPCConfigCaches/');
366   FSourceCaches.LoadFromXMLConfig(XMLConfig,Path+'FPCSrcDirCaches/');
367 
368   LazarusSrcDir:=XMLConfig.GetValue(Path+'Lazarus/SrcDir/Value','');
369   LazarusSrcOptions:=XMLConfig.GetValue(Path+'Lazarus/SrcDirOptions/Value','');
370   LCLWidgetType:=XMLConfig.GetValue(Path+'Lazarus/LCLWidgetType/Value','');
371   ProjectDir:=XMLConfig.GetValue(Path+'Project/Dir/Value','');
372   Modified:=false;
373 end;
374 
375 procedure TCodeToolsOptions.SaveToFile(const Filename: string);
376 var
377   XMLConfig: TXMLConfig;
378 begin
379   XMLConfig:=TXMLConfig.CreateClean(Filename);
380   try
381     SaveToXMLConfig(XMLConfig,'CodeToolsOptions/');
382     XMLConfig.Flush;
383   finally
384     XMLConfig.Free;
385   end;
386 end;
387 
388 procedure TCodeToolsOptions.LoadFromFile(const Filename: string);
389 var
390   XMLConfig: TXMLConfig;
391 begin
392   XMLConfig:=TXMLConfig.Create(Filename);
393   try
394     LoadFromXMLConfig(XMLConfig,'CodeToolsOptions/');
395     XMLConfig.Flush;
396   finally
397     XMLConfig.Free;
398   end;
399 end;
400 
401 { TCodeBufXMLConfig }
402 
403 procedure TCodeBufXMLConfig.ReadXMLFile(out ADoc: TXMLDocument;
404   const AFilename: String);
405 var
406   Buf: TCodeBuffer;
407   ms: TMemoryStream;
408   Cache: TCodeCache;
409 begin
410   Cache:=GetCache;
411   if Cache<>nil then begin
412     Buf:=Cache.LoadFile(AFilename);
413     if Buf<>nil then begin
414       fKeepFileAttributes:=true;
415       ms:=TMemoryStream.Create;
416       try
417         Buf.SaveToStream(ms);
418         ms.Position:=0;
419         Laz2_XMLRead.ReadXMLFile(ADoc, ms, ReadFlags);
420         exit; // success
421       finally
422         ms.Free;
423       end;
424     end;
425   end;
426   // try default (this will create the normal exceptions)
427   inherited ReadXMLFile(ADoc, AFilename);
428 end;
429 
430 procedure TCodeBufXMLConfig.WriteXMLFile(ADoc: TXMLDocument;
431   const AFileName: String);
432 var
433   Buf: TCodeBuffer;
434   ms: TMemoryStream;
435   Cache: TCodeCache;
436 begin
437   Cache:=GetCache;
438   if Cache<>nil then begin
439     Buf:=nil;
440     if (not fKeepFileAttributes) or (not FileExistsCached(AFileName)) then
441       Buf:=Cache.CreateFile(AFilename)
442     else
443       Buf:=Cache.LoadFile(AFilename);
444     if Buf<>nil then begin
445       fKeepFileAttributes:=true;
446       ms:=TMemoryStream.Create;
447       try
448         Laz2_XMLWrite.WriteXMLFile(ADoc, ms, WriteFlags);
449         ms.Position:=0;
450         Buf.LoadFromStream(ms);
451         if Buf.FileOnDiskIsEqual then exit;
452         //debugln(['TCodeBufXMLConfig.WriteXMLFile writing ',AFileName,' ...']);
453         if Buf.Save then exit; // success
454       finally
455         ms.Free;
456       end;
457     end;
458   end;
459   // try default (this will create the normal exceptions)
460   inherited WriteXMLFile(ADoc, AFileName);
461 end;
462 
TCodeBufXMLConfig.GetCachenull463 function TCodeBufXMLConfig.GetCache: TCodeCache;
464 begin
465   Result:=CodeCache;
466   if Result=nil then
467     Result:=DefaultConfigCodeCache;
468 end;
469 
470 constructor TCodeBufXMLConfig.CreateWithCache(AFilename: string;
471   LoadContent: boolean; LoadFileAttributes: boolean; ASource: string;
472   ACache: TCodeCache);
473 begin
474   CodeCache:=ACache;
475   fKeepFileAttributes:=LoadFileAttributes;
476   if (ASource<>'') then
477     inherited CreateWithSource(AFilename,ASource)
478   else if LoadContent then
479     inherited Create(AFilename)
480   else
481     inherited CreateClean(AFilename);
482 end;
483 
484 end.
485 
486