/components/codetools/codetoolsconfig.pas

  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., 59 Temple Place - Suite 330, Boston, MA 02111-1307, 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}
 43unit CodeToolsConfig;
 44
 45{$mode objfpc}{$H+}
 46
 47{$I codetools.inc}
 48
 49interface
 50
 51uses
 52  Classes, SysUtils, Laz2_XMLCfg, Laz2_XMLRead, Laz2_XMLWrite, Laz2_DOM,
 53  FileProcs, LazFileUtils, LazFileCache, LazUTF8, CodeCache, DefineTemplates;
 54  
 55type
 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;
 66    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
 77var
 78  DefaultConfigCodeCache: TCodeCache = nil; // set by CodeToolBoss
 79
 80type
 81
 82  { TCodeToolsOptions }
 83
 84  TCodeToolsOptions = class
 85  private
 86    FConfigCaches: TFPCTargetConfigCaches;
 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;
122    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: TFPCTargetConfigCaches 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
154implementation
155
156{ TCodeToolsOptions }
157
158procedure TCodeToolsOptions.SetFPCOptions(const AValue: string);
159begin
160  if FFPCOptions=AValue then exit;
161  FFPCOptions:=AValue;
162  Modified:=true;
163end;
164
165procedure TCodeToolsOptions.SetFPCPath(const AValue: string);
166var
167  NewValue: String;
168begin
169  NewValue:=TrimAndExpandFilename(AValue);
170  if FFPCPath=NewValue then exit;
171  FFPCPath:=NewValue;
172  FUnitLinkListValid:=false;
173  Modified:=true;
174end;
175
176procedure TCodeToolsOptions.SetFPCSrcDir(const AValue: string);
177var
178  NewValue: String;
179begin
180  NewValue:=TrimAndExpandFilename(AValue);
181  if FFPCSrcDir=NewValue then exit;
182  FFPCSrcDir:=NewValue;
183  FUnitLinkListValid:=false;
184  Modified:=true;
185end;
186
187procedure TCodeToolsOptions.SetFPCUnitPath(const AValue: string);
188begin
189  if FFPCUnitPath=AValue then exit;
190  FFPCUnitPath:=AValue;
191  FUnitLinkListValid:=false;
192  Modified:=true;
193end;
194
195procedure TCodeToolsOptions.SetLazarusSrcDir(const AValue: string);
196var
197  NewValue: String;
198begin
199  NewValue:=TrimAndExpandFilename(AValue);
200  if FLazarusSrcDir=NewValue then exit;
201  FLazarusSrcDir:=NewValue;
202  Modified:=true;
203end;
204
205procedure TCodeToolsOptions.SetLCLWidgetType(const AValue: string);
206begin
207  if FLCLWidgetType=AValue then exit;
208  FLCLWidgetType:=AValue;
209  Modified:=true;
210end;
211
212procedure TCodeToolsOptions.SetLazarusSrcOptions(const AValue: string);
213begin
214  if FLazarusSrcOptions=AValue then exit;
215  FLazarusSrcOptions:=AValue;
216  Modified:=true;
217end;
218
219procedure TCodeToolsOptions.SetModified(const AValue: boolean);
220begin
221  if FModified=AValue then exit;
222  FModified:=AValue;
223end;
224
225procedure TCodeToolsOptions.SetPPUExt(const AValue: string);
226begin
227  if FPPUExt=AValue then exit;
228  FPPUExt:=AValue;
229  Modified:=true;
230end;
231
232procedure TCodeToolsOptions.SetProjectDir(const AValue: string);
233begin
234  if FProjectDir=AValue then exit;
235  FProjectDir:=AppendPathDelim(AValue);
236  Modified:=true;
237end;
238
239procedure TCodeToolsOptions.SetTargetOS(const AValue: string);
240begin
241  if FTargetOS=AValue then exit;
242  FTargetOS:=AValue;
243  FUnitLinkListValid:=false;
244  Modified:=true;
245end;
246
247procedure TCodeToolsOptions.SetTargetProcessor(const AValue: string);
248begin
249  if FTargetProcessor=AValue then exit;
250  FTargetProcessor:=AValue;
251  FUnitLinkListValid:=false;
252  Modified:=true;
253end;
254
255procedure TCodeToolsOptions.SetTestPascalFile(const AValue: string);
256begin
257  if FTestPascalFile=AValue then exit;
258  FTestPascalFile:=AValue;
259  Modified:=true;
260end;
261
262procedure TCodeToolsOptions.SetUnitLinkList(const AValue: string);
263begin
264  if FUnitLinkList=AValue then exit;
265  FUnitLinkList:=AValue;
266  Modified:=true;
267end;
268
269procedure TCodeToolsOptions.SetUnitLinkListValid(const AValue: boolean);
270begin
271  if FUnitLinkListValid=AValue then exit;
272  FUnitLinkListValid:=AValue;
273  Modified:=true;
274end;
275
276constructor TCodeToolsOptions.Create;
277begin
278  FPPUExt:='.ppu';
279  FLCLWidgetType:='gtk2';
280  FConfigCaches:=TFPCTargetConfigCaches.Create(nil);
281  FSourceCaches:=TFPCSourceCaches.Create(nil);
282end;
283
284destructor TCodeToolsOptions.Destroy;
285begin
286  FreeAndNil(FConfigCaches);
287  FreeAndNil(FSourceCaches);
288  inherited Destroy;
289end;
290
291procedure 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}
301begin
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');
314end;
315
316function TCodeToolsOptions.FindDefaultCompilerFilename: string;
317begin
318  Result:=SearchFileInPath(GetDefaultCompilerFilename,'',
319                           GetEnvironmentVariableUTF8('PATH'),PathSeparator,ctsfcDefault);
320end;
321
322procedure TCodeToolsOptions.SaveToXMLConfig(XMLConfig: TXMLConfig;
323  const Path: string);
324begin
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;
342end;
343
344procedure TCodeToolsOptions.LoadFromXMLConfig(XMLConfig: TXMLConfig;
345  const Path: string);
346var
347  i: Integer;
348  UnitPath: string;
349begin
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;
373end;
374
375procedure TCodeToolsOptions.SaveToFile(const Filename: string);
376var
377  XMLConfig: TXMLConfig;
378begin
379  XMLConfig:=TXMLConfig.CreateClean(Filename);
380  try
381    SaveToXMLConfig(XMLConfig,'CodeToolsOptions/');
382    XMLConfig.Flush;
383  finally
384    XMLConfig.Free;
385  end;
386end;
387
388procedure TCodeToolsOptions.LoadFromFile(const Filename: string);
389var
390  XMLConfig: TXMLConfig;
391begin
392  XMLConfig:=TXMLConfig.Create(Filename);
393  try
394    LoadFromXMLConfig(XMLConfig,'CodeToolsOptions/');
395    XMLConfig.Flush;
396  finally
397    XMLConfig.Free;
398  end;
399end;
400
401{ TCodeBufXMLConfig }
402
403procedure TCodeBufXMLConfig.ReadXMLFile(out ADoc: TXMLDocument;
404  const AFilename: String);
405var
406  Buf: TCodeBuffer;
407  ms: TMemoryStream;
408  Cache: TCodeCache;
409begin
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);
428end;
429
430procedure TCodeBufXMLConfig.WriteXMLFile(ADoc: TXMLDocument;
431  const AFileName: String);
432var
433  Buf: TCodeBuffer;
434  ms: TMemoryStream;
435  Cache: TCodeCache;
436begin
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);
461end;
462
463function TCodeBufXMLConfig.GetCache: TCodeCache;
464begin
465  Result:=CodeCache;
466  if Result=nil then
467    Result:=DefaultConfigCodeCache;
468end;
469
470constructor TCodeBufXMLConfig.CreateWithCache(AFilename: string;
471  LoadContent: boolean; LoadFileAttributes: boolean; ASource: string;
472  ACache: TCodeCache);
473begin
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);
482end;
483
484end.
485