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