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  Simple functions
22   - for file access, not yet in fpc.
23   - recent list
24   - xmlconfig formats
25}
26unit IDEProcs;
27
28{$mode objfpc}{$H+}
29
30interface
31
32uses
33  // RTL
34  Classes, SysUtils, Laz_AVL_Tree,
35  // LazUtils
36  FileUtil, LazFileUtils, LazUtilities, LazFileCache, LazUTF8,
37  Laz2_XMLCfg, AvgLvlTree, LazLoggerBase, LazTracer,
38  // LCL
39  StdCtrls, ExtCtrls,
40  // CodeTools
41  BasicCodeTools, FileProcs, CodeToolManager, CodeToolsConfig, CodeCache,
42  PackageIntf,
43  // IDE
44  TransferMacros,
45  LazConf;
46
47const
48  SBuildMethod: array[TBuildMethod] of string = (
49    'Lazarus',
50    'FPMake',
51    'Both'
52    );
53function StringToBuildMethod(const BuildMethod: string): TBuildMethod;
54function GetFPCVer: String;
55
56// file operations
57function BackupFileForWrite(const Filename, BackupFilename: string): boolean;
58function CreateEmptyFile(const Filename: string): boolean;
59
60// file names
61function FilenameIsPascalSource(const Filename: string): boolean;
62function ChompEndNumber(const s: string): string;
63
64// find file
65function FindFilesCaseInsensitive(const Directory,
66  CaseInsensitiveFilename: string; IgnoreExact: boolean): TStringList;
67function FindFirstFileWithExt(const Directory, Ext: string): string;
68function CreateNonExistingFilename(const BaseFilename: string): string;
69function FindFPCTool(const Executable, CompilerFilename: string): string;
70procedure ResolveLinksInFileList(List: TStrings; RemoveDanglingLinks: Boolean);
71function FindProgram(ProgramName, BaseDirectory: string;
72                     WithBaseDirectory: boolean): string;
73
74// search paths
75function TrimSearchPath(const SearchPath, BaseDirectory: string;
76                  DeleteDoubles: boolean = false; ExpandPaths: boolean = false): string;
77function MergeSearchPaths(const OldSearchPath, AddSearchPath: string): string;
78procedure MergeSearchPaths(SearchPath: TStrings; const AddSearchPath: string);
79function RemoveSearchPaths(const SearchPath, RemoveSearchPath: string): string;
80function RemoveNonExistingPaths(const SearchPath, BaseDirectory: string): string;
81function RebaseSearchPath(const SearchPath,
82                          OldBaseDirectory, NewBaseDirectory: string;
83                          SkipPathsStartingWithMacro: boolean): string;
84function ShortenSearchPath(const SearchPath, BaseDirectory,
85                           ChompDirectory: string): string;
86function GetNextDirectoryInSearchPath(const SearchPath: string;
87                                      var NextStartPos: integer): string;
88function GetNextUsedDirectoryInSearchPath(const SearchPath,
89                          FilterDir: string; var NextStartPos: integer): string;
90function SearchPathToList(const SearchPath: string): TStringList;
91function SearchDirectoryInSearchPath(const SearchPath, Directory: string;
92                                     DirStartPos: integer = 1): integer;
93function SearchDirectoryInSearchPath(SearchPath: TStrings;
94                    const Directory: string; DirStartPos: integer = 0): integer;
95
96// Recent item lists
97type
98  TRecentListType = (
99    rltCaseSensitive,
100    rltCaseInsensitive,
101    rltFile
102    );
103const
104  RecentListTypeNames: array[TRecentListType] of string = (
105    'CaseSensitive',
106    'CaseInsensitive',
107    'File'
108    );
109function IndexInRecentList(List: TStrings; ListType: TRecentListType;
110  const Path: string): integer;
111function StrToRecentListType(s: string): TRecentListType;
112function CompareRecentListItem(s1, s2: string; ListType: TRecentListType): boolean;
113procedure LoadRecentList(XMLConfig: TXMLConfig; List: TStrings; const Path: string;
114                         ListType: TRecentListType);
115procedure SaveRecentList(XMLConfig: TXMLConfig; List: TStrings;
116                         const Path: string); overload;
117procedure SaveRecentList(XMLConfig: TXMLConfig; List: TStrings;
118                         const Path: string; aMax: Integer); overload;
119function AddToRecentList(const s: string; List: TStrings; aMax: integer;
120                         ListType: TRecentListType): boolean;
121function AddComboTextToRecentList(cb: TCombobox; aMax: integer;
122                                  ListType: TRecentListType): boolean;
123procedure RemoveFromRecentList(const s: string; List: TStrings;
124                               ListType: TRecentListType);
125procedure CleanUpRecentList(List: TStrings; ListType: TRecentListType);
126
127// XMLconfig
128procedure LoadRect(XMLConfig: TXMLConfig; const Path:string;
129                   var ARect:TRect);
130procedure LoadRect(XMLConfig: TXMLConfig; const Path:string;
131                   var ARect:TRect; const DefaultRect: TRect);
132procedure SaveRect(XMLConfig: TXMLConfig; const Path:string;
133                   const ARect: TRect);
134procedure SaveRect(XMLConfig: TXMLConfig; const Path:string;
135                   const ARect, DefaultRect: TRect);
136procedure LoadPoint(XMLConfig: TXMLConfig; const Path:string;
137                    var APoint:TPoint; const DefaultPoint: TPoint);
138procedure SavePoint(XMLConfig: TXMLConfig; const Path:string;
139                    const APoint, DefaultPoint:TPoint);
140procedure LoadStringList(XMLConfig: TXMLConfig; List: TStrings; const Path: string);
141procedure SaveStringList(XMLConfig: TXMLConfig; List: TStrings; const Path: string);
142procedure LoadStringToStringTree(XMLConfig: TXMLConfig;
143                                 Tree: TStringToStringTree; const Path: string);
144procedure SaveStringToStringTree(XMLConfig: TXMLConfig;
145                                 Tree: TStringToStringTree; const Path: string);
146procedure MakeXMLName(var Name: string);
147function LoadXMLConfigViaCodeBuffer(Filename: string): TXMLConfig;
148
149// Point conversion
150function PointToCfgStr(const Point: TPoint): string;
151procedure CfgStrToPoint(const s: string; var Point: TPoint; const DefaultPoint: TPoint);
152
153// environment
154type
155  TParseString = record
156    UnparsedValue: string;
157    ParsedValue: string;
158    ParseStamp: integer;
159    Parsing: boolean;
160  end;
161
162function GetCurrentUserName: string;
163function GetCurrentChangeLog: string;
164function GetProgramSearchPath: string;
165
166// miscellaneous
167procedure CheckList(List: TList; TestListNil, TestDoubles, TestNils: boolean);
168procedure CheckList(List: TFPList; TestListNil, TestDoubles, TestNils: boolean);
169procedure CheckEmptyListCut(List1, List2: TList);
170procedure RemoveDoubles(List: TStrings);
171function SearchInStringListI(List: TStrings; const s: string): integer; // search ASCII case insensitive, not UTF-8
172procedure ReverseList(List: TList);
173procedure ReverseList(List: TFPList);
174procedure FreeListObjects(List: TList; FreeList: boolean);
175procedure FreeListObjects(List: TFPList; FreeList: boolean);
176function CompareMemStreamText(s1, s2: TMemoryStream): Boolean;
177
178function CheckGroupItemChecked(CheckGroup: TCheckGroup; const Caption: string): Boolean;
179
180
181implementation
182
183{$IfNdef MSWindows}
184{$ifNdef HASAMIGA}
185// to get more detailed error messages consider the os
186uses
187  Unix, BaseUnix;
188{$EndIf}
189{$EndIf}
190
191{-------------------------------------------------------------------------------
192  function FindFilesCaseInsensitive(const Directory,
193    CaseInsensitiveFilename: string; IgnoreExact: boolean): TStringLists;
194
195  Search Pascal case insensitive in Directory for all files
196  named CaseInsensitiveFilename
197-------------------------------------------------------------------------------}
198function FindFilesCaseInsensitive(const Directory,
199  CaseInsensitiveFilename: string; IgnoreExact: boolean): TStringList;
200var
201  FileInfo: TSearchRec;
202begin
203  Result:=nil;
204  if FindFirstUTF8(AppendPathDelim(Directory)+GetAllFilesMask,
205                        faAnyFile,FileInfo)=0
206  then begin
207    repeat
208      // check if special file
209      if (FileInfo.Name='.') or (FileInfo.Name='..') or (FileInfo.Name='') then
210        continue;
211      if (CompareText(CaseInsensitiveFilename,FileInfo.Name)=0) // Pascal insensitibity, not UTF-8, thing about Turkish I
212      and ((not IgnoreExact)
213           or (CompareFilenames(CaseInsensitiveFilename,FileInfo.Name)<>0))
214      then begin
215        if Result=nil then Result:=TStringList.Create;
216        Result.Add(FileInfo.Name);
217      end;
218    until FindNextUTF8(FileInfo)<>0;
219  end;
220  FindCloseUTF8(FileInfo);
221end;
222
223function FilenameIsPascalSource(const Filename: string): boolean;
224var
225  s: string;
226  i: Integer;
227begin
228  Result:=False;
229  // Check unit name
230  s:=ExtractFileNameOnly(Filename);
231  if (s='') or not IsDottedIdentifier(s) then
232    exit;
233  // Check extension
234  s:=lowercase(ExtractFileExt(Filename));
235  for i:=Low(PascalSourceExt) to High(PascalSourceExt) do
236    if s=PascalSourceExt[i] then
237      exit(True);
238end;
239
240function CreateNonExistingFilename(const BaseFilename: string): string;
241var
242  PostFix: String;
243  PreFix: String;
244  i: Integer;
245begin
246  if not FileExistsUTF8(BaseFilename) then begin
247    Result:=BaseFilename;
248    exit;
249  end;
250  PostFix:=ExtractFileExt(BaseFilename);
251  PreFix:=copy(BaseFilename,1,length(BaseFilename)-length(PostFix));
252  i:=0;
253  repeat
254    inc(i);
255    Result:=PreFix+IntToStr(i)+PostFix;
256  until not FileExistsUTF8(Result);
257end;
258
259function FindFPCTool(const Executable, CompilerFilename: string): string;
260begin
261  if ConsoleVerbosity>=0 then
262    DebugLn('Hint: (lazarus) FindFPCTool Executable="',Executable,'" CompilerFilename="',CompilerFilename,'"');
263  Result:=AppendPathDelim(ExtractFilePath(CompilerFilename))+Executable;
264  if ConsoleVerbosity>=0 then
265    DebugLn('Hint: (lazarus) FindFPCTool Try="',Result);
266  if FileExistsUTF8(Result) then exit;
267  Result:=FindDefaultExecutablePath(Executable);
268  if FileExistsUTF8(Result) then exit;
269  Result:='';
270end;
271
272procedure ResolveLinksInFileList(List: TStrings; RemoveDanglingLinks: Boolean);
273var
274  i: Integer;
275  OldFilename: string;
276  NewFilename: String;
277begin
278  if List=nil then exit;
279  for i:=List.Count-1 downto 0 do begin
280    OldFilename:=List[i];
281    NewFilename:=GetPhysicalFilenameCached(OldFilename,true);
282    //DebugLn(['ResolveLinksInFileList OldFilename=',OldFilename,' NewFilename=',NewFilename]);
283    if NewFilename='' then begin
284      if RemoveDanglingLinks then
285        List.Delete(i);
286    end
287    else if NewFilename<>OldFilename then
288      List[i]:=NewFilename;
289  end;
290end;
291
292function MergeSearchPaths(const OldSearchPath, AddSearchPath: string): string;
293var
294  l: Integer;
295  EndPos: Integer;
296  StartPos: Integer;
297  NewPath: String;
298begin
299  Result:=OldSearchPath;
300  if Result='' then begin
301    Result:=AddSearchPath;
302    exit;
303  end;
304  l:=length(AddSearchPath);
305  EndPos:=1;
306  while EndPos<=l do begin
307    StartPos:=EndPos;
308    while (AddSearchPath[StartPos]=';') do begin
309      inc(StartPos);
310      if StartPos>l then exit;
311    end;
312    EndPos:=StartPos;
313    while (EndPos<=l) and (AddSearchPath[EndPos]<>';') do inc(EndPos);
314    if SearchDirectoryInSearchPath(Result,AddSearchPath,StartPos)<1 then
315    begin
316      // new path found -> add
317      NewPath:=copy(AddSearchPath,StartPos,EndPos-StartPos);
318      if Result<>'' then
319        NewPath:=';'+NewPath;
320      Result:=Result+NewPath;
321    end;
322  end;
323end;
324
325procedure MergeSearchPaths(SearchPath: TStrings; const AddSearchPath: string);
326var
327  l: Integer;
328  EndPos: Integer;
329  StartPos: Integer;
330begin
331  l:=length(AddSearchPath);
332  EndPos:=1;
333  while EndPos<=l do begin
334    StartPos:=EndPos;
335    while (AddSearchPath[StartPos]=';') do begin
336      inc(StartPos);
337      if StartPos>l then exit;
338    end;
339    EndPos:=StartPos;
340    while (EndPos<=l) and (AddSearchPath[EndPos]<>';') do inc(EndPos);
341    if SearchDirectoryInSearchPath(SearchPath,AddSearchPath,StartPos)<1 then
342    begin
343      // new path found -> add
344      SearchPath.Add(copy(AddSearchPath,StartPos,EndPos-StartPos));
345    end;
346  end;
347end;
348
349function RemoveSearchPaths(const SearchPath, RemoveSearchPath: string): string;
350var
351  OldPathLen: Integer;
352  EndPos: Integer;
353  StartPos: Integer;
354  ResultStartPos: Integer;
355begin
356  Result:=SearchPath;
357  OldPathLen:=length(SearchPath);
358  EndPos:=1;
359  ResultStartPos:=1;
360  repeat
361    StartPos:=EndPos;
362    while (StartPos<=OldPathLen) and (SearchPath[StartPos]=';') do
363      inc(StartPos);
364    if StartPos>OldPathLen then break;
365    EndPos:=StartPos;
366    while (EndPos<=OldPathLen) and (SearchPath[EndPos]<>';') do
367      inc(EndPos);
368    //DebugLn('RemoveSearchPaths Dir="',copy(SearchPath,StartPos,EndPos-StartPos),'" RemoveSearchPath="',RemoveSearchPath,'"');
369    if SearchDirectoryInSearchPath(RemoveSearchPath,SearchPath,StartPos)>0 then
370    begin
371      // remove path -> skip
372    end else begin
373      // keep path -> copy
374      if ResultStartPos>1 then begin
375        Result[ResultStartPos]:=';';
376        inc(ResultStartPos);
377      end;
378      while StartPos<EndPos do begin
379        Result[ResultStartPos]:=SearchPath[StartPos];
380        inc(ResultStartPos);
381        inc(StartPos);
382      end;
383    end;
384  until false;
385  SetLength(Result,ResultStartPos-1);
386end;
387
388function RebaseSearchPath(const SearchPath, OldBaseDirectory,
389  NewBaseDirectory: string; SkipPathsStartingWithMacro: boolean): string;
390// change every relative search path
391var
392  EndPos: Integer;
393  StartPos: Integer;
394  CurPath: String;
395begin
396  Result:=SearchPath;
397  if CompareFilenames(OldBaseDirectory,NewBaseDirectory)=0 then exit;
398  EndPos:=1;
399  repeat
400    StartPos:=EndPos;
401    while (StartPos<=length(Result)) and (Result[StartPos]=';') do
402      inc(StartPos);
403    if StartPos>length(Result) then break;
404    EndPos:=StartPos;
405    while (EndPos<=length(Result)) and (Result[EndPos]<>';') do
406      inc(EndPos);
407    if EndPos>StartPos then begin
408      CurPath:=copy(Result,StartPos,EndPos-StartPos);
409      if (not FilenameIsAbsolute(CurPath))
410      and ((not SkipPathsStartingWithMacro) or (CurPath[1]<>'$'))
411      then begin
412        CurPath:=TrimFilename(AppendPathDelim(OldBaseDirectory)+CurPath);
413        CurPath:=CreateRelativePath(CurPath,NewBaseDirectory);
414        Result:=copy(Result,1,StartPos-1)+CurPath
415                   +copy(Result,EndPos,length(Result));
416        EndPos:=StartPos+length(CurPath);
417      end;
418    end;
419  until false;
420end;
421
422function ShortenSearchPath(const SearchPath, BaseDirectory,
423  ChompDirectory: string): string;
424// Every search path that is a subdirectory of ChompDirectory will be shortened.
425// Before the test relative paths are expanded by BaseDirectory.
426var
427  BaseEqualsChompDir: boolean;
428
429  function Normalize(var ADirectory: string): boolean;
430  begin
431    if FilenameIsAbsolute(ADirectory) then begin
432      Result:=true;
433    end else begin
434      if BaseEqualsChompDir then
435        Result:=false
436      else begin
437        Result:=true;
438        ADirectory:=AppendPathDelim(BaseDirectory)+ADirectory;
439      end;
440    end;
441    if Result then
442      ADirectory:=AppendPathDelim(TrimFilename(ADirectory));
443  end;
444
445var
446  PathLen: Integer;
447  EndPos: Integer;
448  StartPos: Integer;
449  CurDir: String;
450  NewCurDir: String;
451  DiffLen: Integer;
452begin
453  Result:=SearchPath;
454  if (SearchPath='') or (ChompDirectory='') then exit;
455
456  PathLen:=length(Result);
457  EndPos:=1;
458  BaseEqualsChompDir:=CompareFilenames(BaseDirectory,ChompDirectory)=0;
459  while EndPos<=PathLen do begin
460    StartPos:=EndPos;
461    while (Result[StartPos] in [';',#0..#32]) do begin
462      inc(StartPos);
463      if StartPos>PathLen then exit;
464    end;
465    EndPos:=StartPos;
466    while (EndPos<=PathLen) and (Result[EndPos]<>';') do inc(EndPos);
467    CurDir:=copy(Result,StartPos,EndPos-StartPos);
468    NewCurDir:=CurDir;
469    if Normalize(NewCurDir) then begin
470      if CompareFilenames(NewCurDir,ChompDirectory)=0 then
471        NewCurDir:='.'
472      else if FileIsInPath(NewCurDir,ChompDirectory) then
473        NewCurDir:=AppendPathDelim(CreateRelativePath(NewCurDir,BaseDirectory));
474      if NewCurDir<>CurDir then begin
475        DiffLen:=length(NewCurDir)-length(CurDir);
476        Result:=copy(Result,1,StartPos-1)+NewCurDir
477                +copy(Result,EndPos,PathLen-EndPos+1);
478        inc(EndPos,DiffLen);
479        inc(PathLen,DiffLen);
480      end;
481    end;
482    StartPos:=EndPos;
483  end;
484end;
485
486function GetNextDirectoryInSearchPath(const SearchPath: string;
487                                      var NextStartPos: integer): string;
488var
489  PathLen: Integer;
490  CurStartPos: Integer;
491begin
492  PathLen:=length(SearchPath);
493  if PathLen>0 then begin
494    repeat
495      while (NextStartPos<=PathLen)
496      and (SearchPath[NextStartPos] in [';',#0..#32]) do
497        inc(NextStartPos);
498      CurStartPos:=NextStartPos;
499      while (NextStartPos<=PathLen) and (SearchPath[NextStartPos]<>';') do
500        inc(NextStartPos);
501      Result:=TrimFilename(copy(SearchPath,CurStartPos,NextStartPos-CurStartPos));
502      if Result<>'' then exit;
503    until (NextStartPos>PathLen);
504  end else begin
505    NextStartPos:=1;
506  end;
507  Result:='';
508end;
509
510function GetNextUsedDirectoryInSearchPath(const SearchPath,
511                    FilterDir: string; var NextStartPos: integer): string;
512// searches next directory in search path,
513// which is equal to FilterDir or is in FilterDir
514begin
515  while (NextStartPos<=length(SearchPath)) do begin
516    Result:=GetNextDirectoryInSearchPath(SearchPath,NextStartPos);
517    if (Result<>'') and PathIsInPath(Result,FilterDir) then
518      exit;
519  end;
520  Result:=''
521end;
522
523function SearchPathToList(const SearchPath: string): TStringList;
524var
525  p: Integer;
526  CurDir: String;
527begin
528  Result:=TStringList.Create;
529  p:=1;
530  repeat
531    CurDir:=GetNextDirectoryInSearchPath(SearchPath,p);
532    if CurDir='' then break;
533    Result.Add(CurDir);
534  until false;
535end;
536
537function SearchDirectoryInSearchPath(const SearchPath, Directory: string;
538  DirStartPos: integer): integer;
539// -1 on not found
540var
541  PathLen: Integer;
542  DirLen: Integer;
543  EndPos: Integer;
544  StartPos: Integer;
545  DirEndPos: Integer;
546  CurDirLen: Integer;
547  CurDirEndPos: Integer;
548begin
549  Result:=-1;
550  DirLen:=length(Directory);
551  if (SearchPath='')
552  or (Directory='') or (DirStartPos>DirLen) or (Directory[DirStartPos]=';') then
553    exit;
554  DirEndPos:=DirStartPos;
555  while (DirEndPos<=DirLen) and (Directory[DirEndPos]<>';') do inc(DirEndPos);
556  // ignore PathDelim at end
557  if (DirEndPos>DirStartPos) and (Directory[DirEndPos-1]=PathDelim) then begin
558    while (DirEndPos>DirStartPos) and (Directory[DirEndPos-1]=PathDelim) do
559      dec(DirEndPos);
560    // check if it is the root path '/'
561    if DirEndPos=DirStartPos then DirEndPos:=DirStartPos+1;
562  end;
563  CurDirLen:=DirEndPos-DirStartPos;
564  //DebugLn('SearchDirectoryInSearchPath Dir="',copy(Directory,DirStartPos,CurDirLen),'"');
565  PathLen:=length(SearchPath);
566  EndPos:=1;
567  while EndPos<=PathLen do begin
568    StartPos:=EndPos;
569    while (SearchPath[StartPos] in [';',#0..#32]) do begin
570      inc(StartPos);
571      if StartPos>PathLen then exit;
572    end;
573    EndPos:=StartPos;
574    while (EndPos<=PathLen) and (SearchPath[EndPos]<>';') do inc(EndPos);
575    CurDirEndPos:=EndPos;
576    // ignore PathDelim at end
577    if (CurDirEndPos>StartPos) and (SearchPath[CurDirEndPos-1]=PathDelim) then
578    begin
579      while (CurDirEndPos>StartPos) and (SearchPath[CurDirEndPos-1]=PathDelim)
580      do
581        dec(CurDirEndPos);
582      // check if it is the root path '/'
583      if CurDirEndPos=StartPos then CurDirEndPos:=StartPos+1;
584    end;
585    //DebugLn('SearchDirectoryInSearchPath CurDir="',copy(SearchPath,StartPos,CurDirEndPos-StartPos),'"');
586    if CurDirEndPos-StartPos=CurDirLen then begin
587      // directories have same length -> compare chars
588      if FileUtil.CompareFilenames(@SearchPath[StartPos],CurDirLen,
589                          @Directory[DirStartPos],CurDirLen,
590                          false)=0
591      then begin
592        // directory found
593        Result:=StartPos;
594        exit;
595      end;
596    end;
597    StartPos:=EndPos;
598  end;
599end;
600
601function SearchDirectoryInSearchPath(SearchPath: TStrings;
602  const Directory: string; DirStartPos: integer): integer;
603var
604  DirLen: Integer;
605  DirEndPos: Integer;
606  CurDirLen: Integer;
607  CurPath: string;
608  CurPathLen: Integer;
609begin
610  Result:=-1;
611  DirLen:=length(Directory);
612  if (SearchPath.Count=0)
613  or (Directory='') or (DirStartPos>DirLen) or (Directory[DirStartPos]=';') then
614    exit;
615  DirEndPos:=DirStartPos;
616  while (DirEndPos<=DirLen) and (Directory[DirEndPos]<>';') do inc(DirEndPos);
617  // ignore PathDelim at end
618  if (DirEndPos>DirStartPos) and (Directory[DirEndPos-1]=PathDelim) then begin
619    while (DirEndPos>DirStartPos) and (Directory[DirEndPos-1]=PathDelim) do
620      dec(DirEndPos);
621    // check if it is the root path '/'
622    if DirEndPos=DirStartPos then DirEndPos:=DirStartPos+1;
623  end;
624  CurDirLen:=DirEndPos-DirStartPos;
625
626  // search in all search paths
627  Result:=SearchPath.Count-1;
628  while Result>=0 do begin
629    CurPath:=SearchPath[Result];
630    CurPathLen:=length(CurPath);
631    if CurPathLen>0 then
632    begin
633      while (CurPathLen>1) and (CurPath[CurPathLen]=PathDelim) do dec(CurPathLen);
634    end;
635    if (CurPathLen>0)
636    and (FileUtil.CompareFilenames(@CurPath[1],CurPathLen,
637                                   @Directory[DirStartPos],CurDirLen,
638                                   false)=0)
639    then begin
640      // directory found
641      exit;
642    end;
643    dec(Result);
644  end;
645end;
646
647function RemoveNonExistingPaths(const SearchPath, BaseDirectory: string): string;
648var
649  StartPos: Integer;
650  EndPos: LongInt;
651  CurPath: String;
652  MacroStartPos: LongInt;
653begin
654  Result:=SearchPath;
655  StartPos:=1;
656  while StartPos<=length(Result) do begin
657    EndPos:=StartPos;
658    while (EndPos<=length(Result)) and (Result[EndPos]=';') do inc(EndPos);
659    if EndPos>StartPos then begin
660      // empty paths, e.g. ;;;;
661      // remove
662      Result:=copy(Result,1,StartPos-1)+copy(Result,EndPos,length(Result));
663      EndPos:=StartPos;
664    end;
665    while (EndPos<=length(Result)) and (Result[EndPos]<>';') do inc(EndPos);
666
667    CurPath:=copy(Result,StartPos,EndPos-StartPos);
668
669    // cut macros
670    MacroStartPos:=System.Pos('$(',CurPath);
671    if MacroStartPos>0 then begin
672      CurPath:=copy(CurPath,1,MacroStartPos-1);
673      if (CurPath<>'') and (CurPath[length(CurPath)]<>PathDelim) then
674        CurPath:=ExtractFilePath(CurPath);
675    end;
676
677    // make path absolute
678    if (CurPath<>'') and (not FilenameIsAbsolute(CurPath)) then
679      CurPath:=AppendPathDelim(BaseDirectory)+CurPath;
680
681    if ((CurPath='') and (MacroStartPos<1))
682    or (not DirPathExistsCached(CurPath)) then begin
683      // path does not exist -> remove
684      Result:=copy(Result,1,StartPos-1)+copy(Result,EndPos+1,length(Result));
685      EndPos:=StartPos;
686    end else begin
687      StartPos:=EndPos+1;
688    end;
689  end;
690end;
691
692function StringToBuildMethod(const BuildMethod: string): TBuildMethod;
693begin
694  if BuildMethod=SBuildMethod[bmFPMake] then
695    result := bmFPMake
696  else if BuildMethod=SBuildMethod[bmBoth] then
697    result := bmBoth
698  else
699    result := bmLazarus;
700end;
701
702function GetFPCVer: String;
703begin
704  Result:='$(FPCVer)';
705  GlobalMacroList.SubstituteStr(Result);
706end;
707
708function ChompEndNumber(const s: string): string;
709var
710  NewLen: Integer;
711begin
712  Result:=s;
713  NewLen:=length(Result);
714  while (NewLen>0) and (Result[NewLen] in ['0'..'9']) do
715    dec(NewLen);
716  SetLength(Result,NewLen);
717end;
718
719function FindFirstFileWithExt(const Directory, Ext: string): string;
720var
721  FileInfo: TSearchRec;
722begin
723  Result:='';
724  if FindFirstUTF8(AppendPathDelim(Directory)+GetAllFilesMask,
725                        faAnyFile,FileInfo)=0
726  then begin
727    repeat
728      // check if special file
729      if (FileInfo.Name='.') or (FileInfo.Name='..') or (FileInfo.Name='') then
730        continue;
731      // check extension
732      if FilenameExtIs(FileInfo.Name,Ext,false) then begin
733        Result:=AppendPathDelim(Directory)+FileInfo.Name;
734        break;
735      end;
736    until FindNextUTF8(FileInfo)<>0;
737  end;
738  FindCloseUTF8(FileInfo);
739end;
740
741// Recent item lists :
742
743function IndexInRecentList(List: TStrings; ListType: TRecentListType;
744  const Path: string): integer;
745begin
746  Result:=List.Count-1;
747  while (Result>=0) and (not CompareRecentListItem(List[Result],Path,ListType)) do
748    dec(Result);
749end;
750
751function StrToRecentListType(s: string): TRecentListType;
752begin
753  for Result:=Low(TRecentListType) to high(TRecentListType)  do
754    if SysUtils.CompareText(s,RecentListTypeNames[Result])=0 then exit;
755  Result:=rltCaseSensitive;
756end;
757
758function CompareRecentListItem(s1, s2: string; ListType: TRecentListType): boolean;
759begin
760  case ListType of
761  rltCaseInsensitive: Result:=UTF8CompareLatinTextFast(s1,s2)=0;
762  rltFile: Result:=CompareFilenames(ChompPathDelim(s1),ChompPathDelim(s2))=0;
763  else Result:=s1=s2;
764  end;
765end;
766
767procedure LoadRecentList(XMLConfig: TXMLConfig; List: TStrings;
768  const Path: string; ListType: TRecentListType);
769begin
770  LoadStringList(XMLConfig,List,Path);
771  CleanUpRecentList(List,ListType);
772end;
773
774procedure SaveRecentList(XMLConfig: TXMLConfig; List: TStrings; const Path: string);
775begin
776  SaveStringList(XMLConfig,List,Path);
777end;
778
779procedure SaveRecentList(XMLConfig: TXMLConfig; List: TStrings;
780  const Path: string; aMax: Integer);
781var
782  i: Integer;
783  s: String;
784begin
785  if aMax>0 then
786    while List.Count>aMax do    // Truncate list to aMax items.
787      List.Delete(List.Count-1);
788  SaveStringList(XMLConfig,List,Path);
789  i:=List.Count+1;
790  while True do
791  begin
792    s:=Path+'Item'+IntToStr(i);
793    if not XMLConfig.HasPath(s+'/Value',True) then Break;
794    XMLConfig.DeletePath(s);    // Remove excess items from XML.
795    Inc(i);
796  end;
797end;
798
799function AddToRecentList(const s: string; List: TStrings; aMax: integer;
800  ListType: TRecentListType): boolean;
801begin
802  if (List.Count>0) and CompareRecentListItem(List[0],s,ListType) then
803    exit(false);
804  Result:=true;
805  RemoveFromRecentList(s,List,ListType);
806  List.Insert(0,s);
807  if aMax>0 then
808    while List.Count>aMax do
809      List.Delete(List.Count-1);
810end;
811
812function AddComboTextToRecentList(cb: TCombobox; aMax: integer;
813  ListType: TRecentListType): boolean;
814var
815  List: TStringList;
816begin
817  List:=TStringList.Create;
818  try
819    List.Assign(cb.Items);
820    Result:=AddToRecentList(cb.Text,List,aMax,ListType);
821    if Result then
822    begin
823      cb.Items.Assign(List);
824      cb.ItemIndex:=0;
825    end;
826  finally
827    List.Free;
828  end;
829end;
830
831procedure RemoveFromRecentList(const s: string; List: TStrings;
832  ListType: TRecentListType);
833var
834  i: integer;
835begin
836  for i:=List.Count-1 downto 0 do
837    if CompareRecentListItem(List[i],s,ListType) then
838      List.Delete(i);
839end;
840
841procedure CleanUpRecentList(List: TStrings; ListType: TRecentListType);
842var
843  i: Integer;
844begin
845  for i:=List.Count-1 downto 1 do
846    if (List[i]='') or CompareRecentListItem(List[i],List[i-1],ListType) then
847      List.Delete(i);
848end;
849
850// XMLConfig
851
852procedure LoadStringList(XMLConfig: TXMLConfig; List: TStrings; const Path: string);
853var
854  i,Count: integer;
855  s: string;
856begin
857  Count:=XMLConfig.GetValue(Path+'Count',0);
858  List.Clear;
859  for i:=1 to Count do begin
860    s:=XMLConfig.GetValue(Path+'Item'+IntToStr(i)+'/Value','');
861    if s<>'' then List.Add(s);
862  end;
863end;
864
865procedure SaveStringList(XMLConfig: TXMLConfig; List: TStrings; const Path: string);
866var
867  i: integer;
868begin
869  XMLConfig.SetDeleteValue(Path+'Count',List.Count,0);
870  for i:=0 to List.Count-1 do
871    XMLConfig.SetDeleteValue(Path+'Item'+IntToStr(i+1)+'/Value',List[i],'');
872end;
873
874procedure LoadStringToStringTree(XMLConfig: TXMLConfig;
875  Tree: TStringToStringTree; const Path: string);
876var
877  Cnt: LongInt;
878  SubPath: String;
879  CurName: String;
880  CurValue: String;
881  i: Integer;
882begin
883  Tree.Clear;
884  Cnt:=XMLConfig.GetValue(Path+'Count',0);
885  for i:=0 to Cnt-1 do begin
886    SubPath:=Path+'Item'+IntToStr(i)+'/';
887    CurName:=XMLConfig.GetValue(SubPath+'Name','');
888    CurValue:=XMLConfig.GetValue(SubPath+'Value','');
889    Tree.Values[CurName]:=CurValue;
890  end;
891end;
892
893procedure SaveStringToStringTree(XMLConfig: TXMLConfig;
894  Tree: TStringToStringTree; const Path: string);
895var
896  Node: TAvlTreeNode;
897  Item: PStringToStringItem;
898  i: Integer;
899  SubPath: String;
900begin
901  XMLConfig.SetDeleteValue(Path+'Count',Tree.Tree.Count,0);
902  Node:=Tree.Tree.FindLowest;
903  i:=0;
904  while Node<>nil do begin
905    Item:=PStringToStringItem(Node.Data);
906    SubPath:=Path+'Item'+IntToStr(i)+'/';
907    XMLConfig.SetDeleteValue(SubPath+'Name',Item^.Name,'');
908    XMLConfig.SetDeleteValue(SubPath+'Value',Item^.Value,'');
909    Node:=Tree.Tree.FindSuccessor(Node);
910    inc(i);
911  end;
912end;
913
914procedure MakeXMLName(var Name: string);
915var
916  i: Integer;
917begin
918  i:=1;
919  while i<=length(Name) do begin
920    if (Name[i] in ['a'..'z','A'..'Z','_'])
921    or (i>1) and (Name[i] in ['0'..'9']) then begin
922      inc(i);
923    end else begin
924      System.Delete(Name,i,1);
925    end;
926  end;
927end;
928
929function LoadXMLConfigViaCodeBuffer(Filename: string): TXMLConfig;
930var
931  Code: TCodeBuffer;
932begin
933  Result:=nil;
934  Code:=CodeToolBoss.LoadFile(Filename,true,false);
935  if Code=nil then exit;
936  try
937    Result:=TCodeBufXMLConfig.CreateWithCache(Filename);
938  except
939    on E: Exception do begin
940      debugln(['LoadXMLConfigViaCodeBuffer Filename="',Filename,'": ',E.Message]);
941    end;
942  end;
943end;
944
945procedure LoadRect(XMLConfig: TXMLConfig; const Path: string;
946  var ARect: TRect);
947begin
948  LoadRect(XMLConfig,Path,ARect,Rect(0,0,0,0));
949end;
950
951procedure LoadRect(XMLConfig: TXMLConfig; const Path:string; var ARect:TRect;
952  const DefaultRect: TRect);
953begin
954  ARect.Left:=XMLConfig.GetValue(Path+'Left',DefaultRect.Left);
955  ARect.Top:=XMLConfig.GetValue(Path+'Top',DefaultRect.Top);
956  ARect.Right:=XMLConfig.GetValue(Path+'Right',DefaultRect.Right);
957  ARect.Bottom:=XMLConfig.GetValue(Path+'Bottom',DefaultRect.Bottom);
958end;
959
960procedure SaveRect(XMLConfig: TXMLConfig; const Path: string; const ARect: TRect);
961begin
962  SaveRect(XMLConfig,Path,ARect,Rect(0,0,0,0));
963end;
964
965procedure SaveRect(XMLConfig: TXMLConfig; const Path:string;
966  const ARect, DefaultRect: TRect);
967begin
968  XMLConfig.SetDeleteValue(Path+'Left',ARect.Left,DefaultRect.Left);
969  XMLConfig.SetDeleteValue(Path+'Top',ARect.Top,DefaultRect.Top);
970  XMLConfig.SetDeleteValue(Path+'Right',ARect.Right,DefaultRect.Right);
971  XMLConfig.SetDeleteValue(Path+'Bottom',ARect.Bottom,DefaultRect.Bottom);
972end;
973
974procedure LoadPoint(XMLConfig: TXMLConfig; const Path: string;
975                    var APoint: TPoint; const DefaultPoint: TPoint);
976begin
977  APoint.X:=XMLConfig.GetValue(Path+'X',DefaultPoint.X);
978  APoint.Y:=XMLConfig.GetValue(Path+'Y',DefaultPoint.Y);
979end;
980
981procedure SavePoint(XMLConfig: TXMLConfig; const Path: string;
982                    const APoint, DefaultPoint: TPoint);
983begin
984  XMLConfig.SetDeleteValue(Path+'X',APoint.X,DefaultPoint.X);
985  XMLConfig.SetDeleteValue(Path+'Y',APoint.Y,DefaultPoint.Y);
986end;
987
988procedure CheckList(List: TList; TestListNil, TestDoubles, TestNils: boolean);
989var
990  Cnt: Integer;
991  i: Integer;
992  CurItem: Pointer;
993  j: Integer;
994begin
995  if List=nil then begin
996    if TestListNil then
997      RaiseGDBException('CheckList List is Nil');
998    exit;
999  end;
1000  Cnt:=List.Count;
1001  if TestNils then begin
1002    for i:=0 to Cnt-1 do
1003      if List[i]=nil then
1004        RaiseGDBException('CheckList item is Nil');
1005  end;
1006  if TestDoubles then begin
1007    for i:=0 to Cnt-2 do begin
1008      CurItem:=List[i];
1009      for j:=i+1 to Cnt-1 do begin
1010        if List[j]=CurItem then
1011          RaiseGDBException('CheckList Double');
1012      end;
1013    end;
1014  end;
1015end;
1016
1017procedure CheckList(List: TFPList; TestListNil, TestDoubles, TestNils: boolean);
1018var
1019  Cnt: Integer;
1020  i: Integer;
1021  CurItem: Pointer;
1022  j: Integer;
1023begin
1024  if List=nil then begin
1025    if TestListNil then
1026      RaiseGDBException('CheckList List is Nil');
1027    exit;
1028  end;
1029  Cnt:=List.Count;
1030  if TestNils then begin
1031    for i:=0 to Cnt-1 do
1032      if List[i]=nil then
1033        RaiseGDBException('CheckList item is Nil');
1034  end;
1035  if TestDoubles then begin
1036    for i:=0 to Cnt-2 do begin
1037      CurItem:=List[i];
1038      for j:=i+1 to Cnt-1 do begin
1039        if List[j]=CurItem then
1040          RaiseGDBException('CheckList Double');
1041      end;
1042    end;
1043  end;
1044end;
1045
1046procedure CheckEmptyListCut(List1, List2: TList);
1047var
1048  Cnt1: Integer;
1049  i: Integer;
1050begin
1051  if (List1=nil) or (List2=nil) then exit;
1052  Cnt1:=List1.Count;
1053  for i:=0 to Cnt1 do begin
1054    if List2.IndexOf(List1[i])>=0 then
1055      RaiseGDBException('CheckEmptyListCut');
1056  end;
1057end;
1058
1059procedure RemoveDoubles(List: TStrings);
1060var
1061  i: Integer;
1062  List2: TStringListUTF8Fast;
1063begin
1064  if List=nil then exit;
1065  List2:=TStringListUTF8Fast.Create;
1066  List2.AddStrings(List);
1067  List2.Sort;
1068  List.Assign(List2);
1069  List2.Free;
1070  for i:=List.Count-2 downto 0 do begin
1071    if List[i]=List[i+1] then List.Delete(i+1);
1072  end;
1073end;
1074
1075function SearchInStringListI(List: TStrings; const s: string): integer;
1076begin
1077  if List=nil then exit(-1);
1078  Result:=List.Count-1;
1079  while (Result>=0) and (CompareText(List[Result],s)<>0) do dec(Result);
1080end;
1081
1082{-------------------------------------------------------------------------------
1083  procedure ReverseList(List: TList);
1084
1085  Reverse the order of a TList
1086-------------------------------------------------------------------------------}
1087procedure ReverseList(List: TList);
1088var
1089  i: Integer;
1090  j: Integer;
1091begin
1092  if List=nil then exit;
1093  i:=0;
1094  j:=List.Count-1;
1095  while i<j do begin
1096    List.Exchange(i,j);
1097    inc(i);
1098    dec(j);
1099  end;
1100end;
1101
1102procedure ReverseList(List: TFPList);
1103var
1104  i: Integer;
1105  j: Integer;
1106begin
1107  if List=nil then exit;
1108  i:=0;
1109  j:=List.Count-1;
1110  while i<j do begin
1111    List.Exchange(i,j);
1112    inc(i);
1113    dec(j);
1114  end;
1115end;
1116
1117procedure FreeListObjects(List: TList; FreeList: boolean);
1118var
1119  i: Integer;
1120begin
1121  for i:=0 to List.Count-1 do
1122    TObject(List[i]).Free;
1123  List.Clear;
1124  if FreeList then
1125    List.Free;
1126end;
1127
1128procedure FreeListObjects(List: TFPList; FreeList: boolean);
1129var
1130  i: Integer;
1131begin
1132  if List=nil then exit;
1133  for i:=0 to List.Count-1 do
1134    TObject(List[i]).Free;
1135  List.Clear;
1136  if FreeList then
1137    List.Free;
1138end;
1139
1140{-------------------------------------------------------------------------------
1141  function TrimSearchPath(const SearchPath, BaseDirectory: string): boolean;
1142
1143  - Removes empty paths.
1144  - Uses TrimFilename on every path.
1145  - If BaseDirectory<>'' then every relative Filename will be expanded.
1146  - removes doubles
1147-------------------------------------------------------------------------------}
1148function TrimSearchPath(const SearchPath, BaseDirectory: string;
1149  DeleteDoubles: boolean; ExpandPaths: boolean): string;
1150var
1151  CurPath: String;
1152  EndPos: Integer;
1153  StartPos: Integer;
1154  len: Integer;
1155  BaseDir: String;
1156begin
1157  Result:='';
1158  EndPos:=1;
1159  len:=length(SearchPath);
1160  BaseDir:=AppendPathDelim(TrimFilename(BaseDirectory));
1161  while EndPos<=len do begin
1162    StartPos:=EndPos;
1163    // skip empty paths and space chars at start
1164    while (StartPos<=len) and (SearchPath[StartPos] in [';',#0..#32]) do
1165      inc(StartPos);
1166    if StartPos>len then break;
1167    EndPos:=StartPos;
1168    while (EndPos<=len) and (SearchPath[EndPos]<>';') do inc(EndPos);
1169    CurPath:=copy(SearchPath,StartPos,EndPos-StartPos);
1170    if CurPath<>'' then begin
1171      // non empty path => expand, trim and normalize
1172      if ExpandPaths then
1173        CurPath:=TrimAndExpandDirectory(CurPath,BaseDir)
1174      else if (BaseDir<>'') and (not FilenameIsAbsolute(CurPath)) then
1175        CurPath:=BaseDir+CurPath;
1176      CurPath:=ChompPathDelim(TrimFilename(CurPath));
1177      if CurPath='' then CurPath:='.';
1178      // check if path already exists
1179      if (not DeleteDoubles) or (SearchDirectoryInSearchPath(Result,CurPath)<1)
1180      then begin
1181        if Result<>'' then
1182          CurPath:=';'+CurPath;
1183        if CurPath<>'' then
1184          Result:=Result+CurPath
1185        else
1186          Result:=Result+'.';
1187      end;
1188    end;
1189  end;
1190end;
1191
1192{-------------------------------------------------------------------------------
1193  BackupFileForWrite
1194
1195  Params: const Filename, BackupFilename: string
1196  Result: boolean
1197
1198  Rename Filename to Backupfilename and create empty Filename with same
1199  file attributes
1200-------------------------------------------------------------------------------}
1201function BackupFileForWrite(const Filename, BackupFilename: string): boolean;
1202
1203  function FileIsLocked(const {%H-}FileName: String): Boolean;
1204  {$ifdef Windows}
1205  var
1206    FHandle: THandle;
1207  {$endif}
1208  begin
1209    {$ifdef Windows}
1210    // try to open with all denies
1211    FHandle := FileOpen(UTF8ToSys(FileName), fmOpenRead or fmShareDenyRead or fmShareDenyWrite);
1212    Result := FHandle = feInvalidHandle;
1213    if not Result then
1214      FileClose(FHandle);
1215    {$else}
1216    Result := False;
1217    {$endif}
1218  end;
1219
1220var
1221  FHandle: THandle;
1222  Code: TCodeBuffer;
1223  {$IF defined(MSWindows) or defined(HASAMIGA)}
1224  OldAttr: Longint;
1225  {$ELSE}
1226  OldInfo: Stat;
1227  {$ENDIF}
1228begin
1229  Result := False;
1230
1231  // store file attributes
1232  {$IF defined(MSWindows) or defined(HASAMIGA)}
1233  OldAttr := FileGetAttrUTF8(Filename);
1234  {$ELSE}
1235  if FpStat(Filename, OldInfo{%H-})<>0 then
1236    exit; // can't backup this file
1237  {$ENDIF}
1238
1239  // if not a symlink/hardlink or locked => rename old file (quick), create empty new file
1240  if not FileIsSymlink(Filename) and
1241     not FileIsHardLink(FileName) and
1242     not FileIsLocked(Filename) and
1243     RenameFileUTF8(Filename, BackupFilename) then
1244  begin
1245    // create empty file
1246    FHandle := FileCreate(UTF8ToSys(FileName));
1247    FileClose(FHandle);
1248    Code:=CodeToolBoss.FindFile(Filename);
1249    if Code<>nil then
1250      Code.InvalidateLoadDate;
1251  end
1252  else // file is a symlink/hardlink or locked or rename failed => copy file (slow)
1253  if not CopyFile(Filename, BackupFilename) then exit;
1254
1255  // restore file attributes
1256  {$IFdef MSWindows}
1257  FileSetAttrUTF8(FileName, OldAttr);
1258  {$ELSE}
1259  FpChmod(Filename, OldInfo.st_Mode and (STAT_IRWXO+STAT_IRWXG+STAT_IRWXU
1260                                        +STAT_ISUID+STAT_ISGID+STAT_ISVTX));
1261  {$ENDIF}
1262
1263  Result := True;
1264end;
1265
1266function FindProgram(ProgramName, BaseDirectory: string;
1267  WithBaseDirectory: boolean): string;
1268var
1269  Flags: TSearchFileInPathFlags;
1270begin
1271  Result:='';
1272  if ProgramName='' then exit;
1273  {$IFDEF Unix}
1274  if ProgramName[1]='~' then begin
1275    Delete(ProgramName,1,1);
1276    ProgramName:=GetEnvironmentVariableUTF8('HOME')+ProgramName;
1277  end;
1278  {$ENDIF}
1279  ProgramName:=ResolveDots(ProgramName);
1280  if FilenameIsAbsolute(ProgramName) then begin
1281    if FileExistsCached(ProgramName) then
1282      Result:=ProgramName
1283    else
1284      Result:='';
1285    exit;
1286  end;
1287  Flags:=[sffFile,sffExecutable];
1288  if not WithBaseDirectory then
1289    Include(Flags,sffDontSearchInBasePath);
1290  Result:=FileUtil.SearchFileInPath(ProgramName,BaseDirectory,
1291                                    GetProgramSearchPath,PathSep,Flags);
1292end;
1293
1294function PointToCfgStr(const Point: TPoint): string;
1295begin
1296  Result:=IntToStr(Point.X)+','+IntToStr(Point.Y);
1297end;
1298
1299procedure CfgStrToPoint(const s: string; var Point: TPoint; const DefaultPoint: TPoint);
1300var
1301  p: Integer;
1302begin
1303  p:=1;
1304  while (p<=length(s)) and (s[p]<>',') do inc(p);
1305  Point.X:=StrToIntDef(copy(s,1,p-1),DefaultPoint.X);
1306  Point.Y:=StrToIntDef(copy(s,p+1,length(s)-p),DefaultPoint.Y);
1307end;
1308
1309function GetCurrentUserName: string;
1310begin
1311  Result:=GetEnvironmentVariableUTF8({$IFDEF MSWindows}'USERNAME'{$ELSE}'USER'{$ENDIF});
1312end;
1313
1314function GetCurrentChangeLog: string;
1315begin
1316  Result:='<'+GetCurrentUserName+'@'+
1317  {$IF defined(MSWindows) or defined(HASAMIGA)}
1318    GetEnvironmentVariableUTF8('COMPUTERNAME')
1319  {$ELSE}
1320    GetHostname
1321  {$ENDIF}
1322    + '>';
1323end;
1324
1325function GetProgramSearchPath: string;
1326begin
1327  GetProgramSearchPath := GetEnvironmentVariableUTF8('PATH');
1328end;
1329
1330function CreateEmptyFile(const Filename: string): boolean;
1331var
1332  fs: TFileStream;
1333begin
1334  Result:=false;
1335  try
1336    InvalidateFileStateCache;
1337    fs:=TFileStream.Create(Filename,fmCreate);
1338    fs.Free;
1339    Result:=true;
1340  except
1341  end;
1342end;
1343
1344function CompareMemStreamText(s1, s2: TMemoryStream): Boolean;
1345// compare text in s2, s2 ignoring line ends
1346var
1347  p1: PChar;
1348  p2: PChar;
1349  Count1: Int64;
1350  Count2: Int64;
1351begin
1352  Result:=false;
1353  if s1.Memory=nil then begin
1354    Result:=s2.Memory=nil;
1355  end else begin
1356    if s2.Memory<>nil then begin
1357      p1:=PChar(s1.Memory);
1358      p2:=PChar(s2.Memory);
1359      Count1:=s1.Size;
1360      Count2:=s2.Size;
1361      repeat
1362        if not (p1^ in [#10,#13]) then begin
1363          // p1 has normal char
1364          if p1^=p2^ then begin
1365            inc(p1);
1366            dec(Count1);
1367            inc(p2);
1368            dec(Count2);
1369          end else begin
1370            exit(false);
1371          end;
1372        end else begin
1373          // p1 has a newline
1374          if (p2^ in [#10,#13]) then begin
1375            // p2 has a newline
1376            if (Count1>1) and (p1[1] in [#10,#13]) and (p1[0]<>p1[1]) then
1377            begin
1378              inc(p1,2);
1379              dec(Count1,2);
1380            end else begin
1381              inc(p1);
1382              dec(Count1);
1383            end;
1384            if (Count2>1) and (p2[1] in [#10,#13]) and (p2[0]<>p2[1]) then
1385            begin
1386              inc(p2,2);
1387              dec(Count2,2);
1388            end else begin
1389              inc(p2);
1390              dec(Count2);
1391            end;
1392          end else begin
1393            // p1 has newline, p2 not
1394            exit(false);
1395          end;
1396        end;
1397        if Count1=0 then begin
1398          Result:=Count2=0;
1399          exit;
1400        end else if Count2=0 then begin
1401          exit(false);
1402        end;
1403      until false;
1404    end;
1405  end;
1406end;
1407
1408function CheckGroupItemChecked(CheckGroup: TCheckGroup; const Caption: string): Boolean;
1409begin
1410  Result := CheckGroup.Checked[CheckGroup.Items.IndexOf(Caption)];
1411end;
1412
1413end.
1414
1415