PageRenderTime 63ms CodeModel.GetById 20ms RepoModel.GetById 0ms app.codeStats 1ms

/components/codetools/fileprocs.pas

http://github.com/graemeg/lazarus
Pascal | 2547 lines | 2137 code | 176 blank | 234 comment | 175 complexity | 7ecf9f316da6673ef722294bbe45aa2a MD5 | raw file
Possible License(s): GPL-2.0, LGPL-2.0, MPL-2.0-no-copyleft-exception
  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. Author: Mattias Gaertner
  21. Abstract:
  22. - simple file functions and fpc additions
  23. - all functions are thread safe unless explicitely stated
  24. }
  25. unit FileProcs;
  26. {$mode objfpc}{$H+}
  27. interface
  28. {$I codetools.inc}
  29. uses
  30. {$IFDEF MEM_CHECK}
  31. MemCheck,
  32. {$ENDIF}
  33. {$IFDEF Windows}
  34. Windows,
  35. {$ENDIF}
  36. // RTL + FCL
  37. Classes, SysUtils, AVL_Tree,
  38. // CodeTools
  39. CodeToolsStrConsts,
  40. // LazUtils
  41. LazUtilities,
  42. {$IFDEF EnableWrapperFunctions}
  43. LazDbgLog,
  44. {$ENDIF}
  45. LazLogger, LazUTF8, LazFileCache,
  46. LazFileUtils, LazUTF8Classes;
  47. type
  48. TFPCStreamSeekType = int64;
  49. TFPCMemStreamSeekType = integer;
  50. PCharZ = Pointer;
  51. {$if defined(Windows) or defined(darwin)}
  52. {$define CaseInsensitiveFilenames}
  53. {$endif}
  54. {$IF defined(CaseInsensitiveFilenames) or defined(darwin)}
  55. {$DEFINE NotLiteralFilenames}
  56. {$ENDIF}
  57. const
  58. FilenamesCaseSensitive = {$IFDEF CaseInsensitiveFilenames}false{$ELSE}true{$ENDIF};// lower and upper letters are treated the same
  59. FilenamesLiteral = {$IFDEF NotLiteralFilenames}false{$ELSE}true{$ENDIF};// file names can be compared using = string operator
  60. SpecialChar = '#'; // used to use PathDelim, e.g. #\
  61. FileMask = AllFilesMask;
  62. {$IFDEF Windows}
  63. ExeExt = '.exe';
  64. {$ELSE}
  65. {$IFDEF NetWare}
  66. ExeExt = '.nlm';
  67. {$ELSE}
  68. ExeExt = '';
  69. {$ENDIF}
  70. {$ENDIF}
  71. type
  72. TCTSearchFileCase = (
  73. ctsfcDefault, // e.g. case insensitive on windows
  74. ctsfcLoUpCase, // also search for lower and upper case
  75. ctsfcAllCase // search case insensitive
  76. );
  77. TCTFileAgeTime = longint;
  78. PCTFileAgeTime = ^TCTFileAgeTime;
  79. {$IFDEF EnableWrapperFunctions}
  80. // *** Wrappers for LazUTF8 ***
  81. function UTF8ToSys(const s: string): string; inline; deprecated 'Use the function in LazUTF8 unit';
  82. function SysToUTF8(const s: string): string; inline; deprecated 'Use the function in LazUTF8 unit';
  83. function UTF8CharacterLength(p: PChar): integer; inline; deprecated 'Use the function in LazUTF8 unit';
  84. // environment
  85. function ParamStrUTF8(Param: Integer): string; inline; deprecated 'Use the function in LazUTF8 unit';
  86. function GetEnvironmentStringUTF8(Index : Integer): String; inline; deprecated 'Use the function in LazUTF8 unit';
  87. function GetEnvironmentVariableUTF8(const EnvVar: String): String; inline; deprecated 'Use the function in LazUTF8 unit';
  88. // *** Wrappers for LazFileUtils ***
  89. function CompareFilenames(const Filename1, Filename2: string): integer; inline; deprecated 'Use the function in LazFileUtils unit';
  90. function CompareFilenamesIgnoreCase(const Filename1, Filename2: string): integer; inline; deprecated 'Use the function in LazFileUtils unit';
  91. //function CompareFileExt(const Filename, Ext: string; CaseSensitive: boolean): integer; inline; deprecated 'Use the function in LazFileUtils unit';
  92. function CompareFilenameStarts(const Filename1, Filename2: string): integer; inline; deprecated 'Use the function in LazFileUtils unit';
  93. function CompareFilenames(Filename1: PChar; Len1: integer;
  94. Filename2: PChar; Len2: integer): integer; inline; deprecated 'Use the function in LazFileUtils unit';
  95. function DirPathExists(DirectoryName: string): boolean; inline; deprecated 'Use the function in LazFileUtils unit';
  96. function DirectoryIsWritable(const DirectoryName: string): boolean; inline; deprecated 'Use the function in LazFileUtils unit';
  97. function ExtractFileNameOnly(const AFilename: string): string; inline; deprecated 'Use the function in LazFileUtils unit';
  98. function FilenameIsAbsolute(const TheFilename: string):boolean; inline; deprecated 'Use the function in LazFileUtils unit';
  99. function FilenameIsWinAbsolute(const TheFilename: string):boolean; inline; deprecated 'Use the function in LazFileUtils unit';
  100. function FilenameIsUnixAbsolute(const TheFilename: string):boolean; inline; deprecated 'Use the function in LazFileUtils unit';
  101. function ForceDirectory(DirectoryName: string): boolean; inline; deprecated 'Use the function in LazFileUtils unit';
  102. procedure CheckIfFileIsExecutable(const AFilename: string); inline; deprecated 'Use the function in LazFileUtils unit';
  103. function FileIsExecutable(const AFilename: string): boolean; inline; deprecated 'Use the function in LazFileUtils unit';
  104. function FileIsReadable(const AFilename: string): boolean; inline; deprecated 'Use the function in LazFileUtils unit';
  105. function FileIsWritable(const AFilename: string): boolean; inline; deprecated 'Use the function in LazFileUtils unit';
  106. function FileIsText(const AFilename: string): boolean; inline; deprecated 'Use the function in LazFileUtils unit';
  107. function FileIsText(const AFilename: string; out FileReadable: boolean): boolean; inline; deprecated 'Use the function in LazFileUtils unit';
  108. function FilenameIsTrimmed(const TheFilename: string): boolean; inline; deprecated 'Use the function in LazFileUtils unit';
  109. function FilenameIsTrimmed(StartPos: PChar; NameLen: integer): boolean; inline; deprecated 'Use the function in LazFileUtils unit';
  110. function TrimFilename(const AFilename: string): string; inline; deprecated 'Use the function in LazFileUtils unit';
  111. function CleanAndExpandFilename(const Filename: string): string; inline; deprecated 'Use the function in LazFileUtils unit';
  112. function CleanAndExpandDirectory(const Filename: string): string; inline; deprecated 'Use the function in LazFileUtils unit';
  113. function TrimAndExpandFilename(const Filename: string; const BaseDir: string = ''): string; inline; deprecated 'Use the function in LazFileUtils unit';
  114. function TrimAndExpandDirectory(const Filename: string; const BaseDir: string = ''): string; inline; deprecated 'Use the function in LazFileUtils unit';
  115. function CreateRelativePath(const Filename, BaseDirectory: string;
  116. UsePointDirectory: boolean = false): string; inline; deprecated 'Use the function in LazFileUtils unit';
  117. function FileIsInPath(const Filename, Path: string): boolean; inline; deprecated 'Use the function in LazFileUtils unit';
  118. function AppendPathDelim(const Path: string): string; inline; deprecated 'Use the function in LazFileUtils unit';
  119. function ChompPathDelim(const Path: string): string; inline; deprecated 'Use the function in LazFileUtils unit';
  120. // file operations
  121. function FileExistsUTF8(const Filename: string): boolean; inline; deprecated 'Use the function in LazFileUtils unit';
  122. function FileAgeUTF8(const FileName: string): Longint; inline; deprecated 'Use the function in LazFileUtils unit';
  123. function DirectoryExistsUTF8(const Directory: string): Boolean; inline; deprecated 'Use the function in LazFileUtils unit';
  124. function ExpandFileNameUTF8(const FileName: string): string; inline; deprecated 'Use the function in LazFileUtils unit';
  125. function FindFirstUTF8(const Path: string; Attr: Longint; out Rslt: TSearchRec): Longint; inline; deprecated 'Use the function in LazFileUtils unit';
  126. function FindNextUTF8(var Rslt: TSearchRec): Longint; inline; deprecated 'Use the function in LazFileUtils unit';
  127. procedure FindCloseUTF8(var F: TSearchrec); inline; deprecated 'Use the function in LazFileUtils unit';
  128. function FileSetDateUTF8(const FileName: String; Age: Longint): Longint; inline; deprecated 'Use the function in LazFileUtils unit';
  129. function FileGetAttrUTF8(const FileName: String): Longint; inline; deprecated 'Use the function in LazFileUtils unit';
  130. function FileSetAttrUTF8(const Filename: String; Attr: longint): Longint; inline; deprecated 'Use the function in LazFileUtils unit';
  131. function DeleteFileUTF8(const FileName: String): Boolean; inline; deprecated 'Use the function in LazFileUtils unit';
  132. function RenameFileUTF8(const OldName, NewName: String): Boolean; inline; deprecated 'Use the function in LazFileUtils unit';
  133. function FileSearchUTF8(const Name, DirList : String): String; inline; deprecated 'Use the function in LazFileUtils unit';
  134. function FileIsReadOnlyUTF8(const FileName: String): Boolean; inline; deprecated 'Use the function in LazFileUtils unit';
  135. function GetCurrentDirUTF8: String; inline; deprecated 'Use the function in LazFileUtils unit';
  136. function SetCurrentDirUTF8(const NewDir: String): Boolean; inline; deprecated 'Use the function in LazFileUtils unit';
  137. function CreateDirUTF8(const NewDir: String): Boolean; inline; deprecated 'Use the function in LazFileUtils unit';
  138. function RemoveDirUTF8(const Dir: String): Boolean; inline; deprecated 'Use the function in LazFileUtils unit';
  139. function ForceDirectoriesUTF8(const Dir: string): Boolean; inline; deprecated 'Use the function in LazFileUtils unit';
  140. // search paths
  141. function CreateAbsoluteSearchPath(const SearchPath, BaseDirectory: string): string; inline; deprecated 'Use the function in LazFileUtils unit';
  142. function CreateRelativeSearchPath(const SearchPath, BaseDirectory: string): string; inline; deprecated 'Use the function in LazFileUtils unit';
  143. function MinimizeSearchPath(const SearchPath: string): string; inline; deprecated 'Use the function in LazFileUtils unit';
  144. // Can lead to "wrong number of parameters" error, LazFileUtils has more versions of the func.
  145. //function FindPathInSearchPath(APath: PChar; APathLen: integer;
  146. // SearchPath: PChar; SearchPathLen: integer): PChar; inline;
  147. // *** Wrappers for LazFileCache ***
  148. function FileExistsCached(const AFilename: string): boolean; inline; deprecated 'Use the function in LazFileCache unit';
  149. function DirPathExistsCached(const AFilename: string): boolean; inline; deprecated 'Use the function in LazFileCache unit';
  150. function DirectoryIsWritableCached(const ADirectoryName: string): boolean; inline; deprecated 'Use the function in LazFileCache unit';
  151. function FileIsExecutableCached(const AFilename: string): boolean; inline; deprecated 'Use the function in LazFileCache unit';
  152. function FileIsReadableCached(const AFilename: string): boolean; inline; deprecated 'Use the function in LazFileCache unit';
  153. function FileIsWritableCached(const AFilename: string): boolean; inline; deprecated 'Use the function in LazFileCache unit';
  154. function FileIsTextCached(const AFilename: string): boolean; inline; deprecated 'Use the function in LazFileCache unit';
  155. function FileAgeCached(const AFileName: string): Longint; inline; deprecated 'Use the function in LazFileCache unit';
  156. procedure InvalidateFileStateCache(const Filename: string = ''); inline; deprecated 'Use the function in LazFileCache unit';
  157. // *** Wrappers for LazUtilities ***
  158. function ComparePointers(p1, p2: Pointer): integer; inline; deprecated 'Use the function in LazUtilities unit';
  159. procedure MergeSort(List: PPointer; ListLength: PtrInt;
  160. const Compare: TListSortCompare); inline; deprecated 'Use the function in LazUtilities unit';
  161. function GetNextDelimitedItem(const List: string; Delimiter: char;
  162. var Position: integer): string; inline; deprecated 'Use the function in LazUtilities unit';
  163. function HasDelimitedItem(const List: string; Delimiter: char; FindItem: string): boolean; inline; deprecated 'Use the function in LazUtilities unit';
  164. function FindNextDelimitedItem(const List: string; Delimiter: char;
  165. var Position: integer; FindItem: string): string; inline; deprecated 'Use the function in LazUtilities unit';
  166. // *** Wrappers for LazDbgLog ***
  167. function MemSizeString(const s: string): PtrUInt; inline; deprecated 'Use the function in LazDbgLog unit';
  168. function MemSizeFPList(const List: TFPList): PtrUInt; inline; deprecated 'Use the function in LazDbgLog unit';
  169. function GetStringRefCount(const s: string): PtrInt; inline; deprecated 'Use the function in LazDbgLog unit';
  170. {$ENDIF EnableWrapperFunctions}
  171. // file operations
  172. function FileDateToDateTimeDef(aFileDate: TCTFileAgeTime; const Default: TDateTime = 0): TDateTime;
  173. function FilenameIsMatching(const Mask, Filename: string; MatchExactly: boolean): boolean;
  174. function FindNextDirectoryInFilename(const Filename: string; var Position: integer): string;
  175. function ClearFile(const Filename: string; RaiseOnError: boolean): boolean;
  176. function GetTempFilename(const Path, Prefix: string): string;
  177. function SearchFileInDir(const Filename, BaseDirectory: string;
  178. SearchCase: TCTSearchFileCase): string; // not thread-safe
  179. function SearchFileInPath(const Filename, BasePath, SearchPath, Delimiter: string;
  180. SearchCase: TCTSearchFileCase): string; overload; // not thread-safe
  181. function FindDiskFilename(const Filename: string): string;
  182. {$IFDEF darwin}
  183. function GetDarwinSystemFilename(Filename: string): string;
  184. {$ENDIF}
  185. function ReadAllLinks(const Filename: string;
  186. ExceptionOnError: boolean): string; inline; // if a link is broken returns ''
  187. function TryReadAllLinks(const Filename: string): string; inline; // if a link is broken returns Filename
  188. const
  189. CTInvalidChangeStamp = LUInvalidChangeStamp;
  190. CTInvalidChangeStamp64 = LUInvalidChangeStamp64; // using a value outside integer to spot wrong types early
  191. function GetFilenameOnDisk(const AFilename: string): string; inline; deprecated; // use FindDiskFilename
  192. function CompareAnsiStringFilenames(Data1, Data2: Pointer): integer;
  193. function CompareFilenameOnly(Filename: PChar; FilenameLen: integer;
  194. NameOnly: PChar; NameOnlyLen: integer; CaseSensitive: boolean): integer;
  195. // searching .pas, .pp, .p
  196. function FilenameIsPascalUnit(const Filename: string;
  197. CaseSensitive: boolean = false): boolean;
  198. function FilenameIsPascalUnit(Filename: PChar; FilenameLen: integer;
  199. CaseSensitive: boolean = false): boolean;
  200. function ExtractFileUnitname(Filename: string; WithNameSpace: boolean): string;
  201. function IsPascalUnitExt(FileExt: PChar; CaseSensitive: boolean = false): boolean;
  202. function SearchPascalUnitInDir(const AnUnitName, BaseDirectory: string;
  203. SearchCase: TCTSearchFileCase): string;
  204. function SearchPascalUnitInPath(const AnUnitName, BasePath, SearchPath,
  205. Delimiter: string; SearchCase: TCTSearchFileCase): string;
  206. // searching .ppu
  207. function SearchPascalFileInDir(const ShortFilename, BaseDirectory: string;
  208. SearchCase: TCTSearchFileCase): string;
  209. function SearchPascalFileInPath(const ShortFilename, BasePath, SearchPath,
  210. Delimiter: string; SearchCase: TCTSearchFileCase): string;
  211. // FPC
  212. function ReadNextFPCParameter(const CmdLine: string; var Position: integer;
  213. out StartPos: integer): boolean;
  214. function ExtractFPCParameter(const CmdLine: string; StartPos: integer): string;
  215. function FindNextFPCParameter(const CmdLine, BeginsWith: string; var Position: integer): integer;
  216. function GetLastFPCParameter(const CmdLine, BeginsWith: string; CutBegins: boolean = true): string;
  217. function GetFPCParameterSrcFile(const CmdLine: string): string;
  218. type
  219. TCTPascalExtType = (petNone, petPAS, petPP, petP);
  220. const
  221. CTPascalExtension: array[TCTPascalExtType] of string =
  222. ('', '.pas', '.pp', '.p');
  223. function FileAgeToStr(aFileAge: longint): string;
  224. function AVLTreeHasDoubles(Tree: TAVLTree): TAVLTreeNode;
  225. // store date locale independent, thread safe
  226. const DateAsCfgStrFormat='YYYYMMDD';
  227. const DateTimeAsCfgStrFormat='YYYY/MM/DD HH:NN:SS';
  228. function DateToCfgStr(const Date: TDateTime; const aFormat: string = DateAsCfgStrFormat): string;
  229. function CfgStrToDate(const s: string; out Date: TDateTime; const aFormat: string = DateAsCfgStrFormat): boolean;
  230. procedure CTIncreaseChangeStamp(var ChangeStamp: integer); inline;
  231. procedure CTIncreaseChangeStamp64(var ChangeStamp: int64); inline;
  232. function SimpleFormat(const Fmt: String; const Args: Array of const): String;
  233. // debugging
  234. var
  235. CTConsoleVerbosity: integer = {$IFDEF VerboseCodetools}1{$ELSE}0{$ENDIF}; // 0=quiet, 1=normal, 2=verbose
  236. procedure RaiseCatchableException(const Msg: string);
  237. procedure RaiseAndCatchException;
  238. procedure DebugLn(Args: array of const);
  239. procedure DebugLn(const S: String; Args: array of const);// similar to Format(s,Args)
  240. procedure DebugLn; inline;
  241. procedure DebugLn(const s: string); inline;
  242. procedure DebugLn(const s1,s2: string); inline;
  243. procedure DebugLn(const s1,s2,s3: string); inline;
  244. procedure DebugLn(const s1,s2,s3,s4: string); inline;
  245. procedure DebugLn(const s1,s2,s3,s4,s5: string); inline;
  246. procedure DebugLn(const s1,s2,s3,s4,s5,s6: string); inline;
  247. procedure DebugLn(const s1,s2,s3,s4,s5,s6,s7: string); inline;
  248. procedure DebugLn(const s1,s2,s3,s4,s5,s6,s7,s8: string); inline;
  249. procedure DebugLn(const s1,s2,s3,s4,s5,s6,s7,s8,s9: string); inline;
  250. procedure DebugLn(const s1,s2,s3,s4,s5,s6,s7,s8,s9,s10: string); inline;
  251. procedure DebugLn(const s1,s2,s3,s4,s5,s6,s7,s8,s9,s10,s11: string); inline;
  252. procedure DebugLn(const s1,s2,s3,s4,s5,s6,s7,s8,s9,s10,s11,s12: string); inline;
  253. procedure DbgOut(Args: array of const);
  254. procedure DbgOut(const s: string); inline;
  255. procedure DbgOut(const s1,s2: string); inline;
  256. procedure DbgOut(const s1,s2,s3: string); inline;
  257. procedure DbgOut(const s1,s2,s3,s4: string); inline;
  258. procedure DbgOut(const s1,s2,s3,s4,s5: string); inline;
  259. procedure DbgOut(const s1,s2,s3,s4,s5,s6: string); inline;
  260. function DbgS(Args: array of const): string; overload;
  261. function DbgS(const c: char): string; overload;
  262. function DbgS(const c: cardinal): string; inline; overload;
  263. function DbgS(const i: integer): string; inline; overload;
  264. function DbgS(const i: QWord): string; inline; overload;
  265. function DbgS(const i: int64): string; inline; overload;
  266. function DbgS(const r: TRect): string; inline; overload;
  267. function DbgS(const p: TPoint): string; inline; overload;
  268. function DbgS(const p: pointer): string; inline; overload;
  269. function DbgS(const e: extended; MaxDecimals: integer = 999): string; overload; inline;
  270. function DbgS(const b: boolean): string; overload; inline;
  271. function DbgS(const ms: TCustomMemoryStream; Count: PtrInt = -1): string; inline; overload;
  272. function DbgSName(const p: TObject): string; overload; inline;
  273. function DbgSName(const p: TClass): string; overload; inline;
  274. function dbgMemRange(P: PByte; Count: integer; Width: integer = 0): string; inline;
  275. function DbgS(const i1,i2,i3,i4: integer): string; overload; inline;
  276. function DbgStr(const StringWithSpecialChars: string): string; overload;
  277. function DbgStr(const StringWithSpecialChars: string; StartPos, Len: PtrInt): string; overload;
  278. function DbgText(const StringWithSpecialChars: string;
  279. KeepLines: boolean = true // true = add LineEnding for each line break
  280. ): string; overload;
  281. type
  282. TCTMemStat = class
  283. public
  284. Name: string;
  285. Sum: PtrUint;
  286. end;
  287. { TCTMemStats }
  288. TCTMemStats = class
  289. private
  290. function GetItems(const Name: string): PtrUint;
  291. procedure SetItems(const Name: string; const AValue: PtrUint);
  292. public
  293. Tree: TAVLTree; // tree of TCTMemStat sorted for Name with CompareText
  294. Total: PtrUInt;
  295. constructor Create;
  296. destructor Destroy; override;
  297. property Items[const Name: string]: PtrUint read GetItems write SetItems; default;
  298. procedure Add(const Name: string; Size: PtrUint);
  299. procedure WriteReport;
  300. end;
  301. function CompareCTMemStat(Stat1, Stat2: TCTMemStat): integer;
  302. function CompareNameWithCTMemStat(KeyAnsiString: Pointer; Stat: TCTMemStat): integer;
  303. function GetTicks: int64; // not thread-safe
  304. type
  305. TCTStackTracePointers = array of Pointer;
  306. TCTLineInfoCacheItem = record
  307. Addr: Pointer;
  308. Info: string;
  309. end;
  310. PCTLineInfoCacheItem = ^TCTLineInfoCacheItem;
  311. procedure CTDumpStack;
  312. function CTGetStackTrace(UseCache: boolean): string;
  313. procedure CTGetStackTracePointers(var AStack: TCTStackTracePointers);
  314. function CTStackTraceAsString(const AStack: TCTStackTracePointers;
  315. UseCache: boolean): string;
  316. function CTGetLineInfo(Addr: Pointer; UseCache: boolean): string; // not thread safe
  317. function CompareCTLineInfoCacheItems(Data1, Data2: Pointer): integer;
  318. function CompareAddrWithCTLineInfoCacheItem(Addr, Item: Pointer): integer;
  319. implementation
  320. // to get more detailed error messages consider the os
  321. {$IFnDEF Windows}
  322. uses
  323. {$IFDEF darwin}
  324. MacOSAll,
  325. {$ENDIF}
  326. Unix;
  327. {$ENDIF}
  328. {$IFDEF EnableWrapperFunctions}
  329. // LazUTF8
  330. function UTF8ToSys(const s: string): string;
  331. begin
  332. Result:=LazUTF8.UTF8ToSys(s);
  333. end;
  334. function SysToUTF8(const s: string): string;
  335. begin
  336. Result:=LazUTF8.SysToUTF8(s);
  337. end;
  338. function UTF8CharacterLength(p: PChar): integer;
  339. begin
  340. Result:=LazUTF8.UTF8CharacterLength(p);
  341. end;
  342. function ParamStrUTF8(Param: Integer): string;
  343. begin
  344. Result:=LazUTF8.ParamStrUTF8(Param);
  345. end;
  346. function GetEnvironmentStringUTF8(Index: Integer): String;
  347. begin
  348. Result:=LazUTF8.GetEnvironmentStringUTF8(Index);
  349. end;
  350. function GetEnvironmentVariableUTF8(const EnvVar: String): String;
  351. begin
  352. Result:=LazUTF8.GetEnvironmentVariableUTF8(EnvVar);
  353. end;
  354. // LazFileUtils
  355. function CompareFilenames(const Filename1, Filename2: string): integer;
  356. begin
  357. Result:=LazFileUtils.CompareFilenames(Filename1,Filename2);
  358. end;
  359. function CompareFilenamesIgnoreCase(const Filename1, Filename2: string): integer;
  360. begin
  361. Result:=LazFileUtils.CompareFilenamesIgnoreCase(Filename1,Filename2);
  362. end;
  363. //function CompareFileExt(const Filename, Ext: string; CaseSensitive: boolean): integer;
  364. //begin
  365. // Result:=LazFileUtils.CompareFileExt(Filename,Ext,CaseSensitive);
  366. //end;
  367. function CompareFilenameStarts(const Filename1, Filename2: string): integer;
  368. begin
  369. Result:=LazFileUtils.CompareFilenameStarts(Filename1,Filename2);
  370. end;
  371. function CompareFilenames(Filename1: PChar; Len1: integer; Filename2: PChar;
  372. Len2: integer): integer;
  373. begin
  374. Result:=LazFileUtils.CompareFilenames(Filename1,Len1,Filename2,Len2);
  375. end;
  376. function DirPathExists(DirectoryName: string): boolean;
  377. begin
  378. Result:=LazFileUtils.DirPathExists(DirectoryName);
  379. end;
  380. function DirectoryIsWritable(const DirectoryName: string): boolean;
  381. begin
  382. Result:=LazFileUtils.DirectoryIsWritable(DirectoryName);
  383. end;
  384. function ExtractFileNameOnly(const AFilename: string): string;
  385. begin
  386. Result:=LazFileUtils.ExtractFileNameOnly(AFilename);
  387. end;
  388. function FilenameIsAbsolute(const TheFilename: string): boolean;
  389. begin
  390. Result:=LazFileUtils.FilenameIsAbsolute(TheFilename);
  391. end;
  392. function FilenameIsWinAbsolute(const TheFilename: string): boolean;
  393. begin
  394. Result:=LazFileUtils.FilenameIsWinAbsolute(TheFilename);
  395. end;
  396. function FilenameIsUnixAbsolute(const TheFilename: string): boolean;
  397. begin
  398. Result:=LazFileUtils.FilenameIsUnixAbsolute(TheFilename);
  399. end;
  400. function ForceDirectory(DirectoryName: string): boolean;
  401. begin
  402. Result:=LazFileUtils.ForceDirectory(DirectoryName);
  403. end;
  404. procedure CheckIfFileIsExecutable(const AFilename: string);
  405. begin
  406. LazFileUtils.CheckIfFileIsExecutable(AFilename);
  407. end;
  408. function FileIsExecutable(const AFilename: string): boolean;
  409. begin
  410. Result:=LazFileUtils.FileIsExecutable(AFilename);
  411. end;
  412. function FileIsReadable(const AFilename: string): boolean;
  413. begin
  414. Result:=LazFileUtils.FileIsReadable(AFilename);
  415. end;
  416. function FileIsWritable(const AFilename: string): boolean;
  417. begin
  418. Result:=LazFileUtils.FileIsWritable(AFilename);
  419. end;
  420. function FileIsText(const AFilename: string): boolean;
  421. begin
  422. Result:=LazFileUtils.FileIsText(AFilename);
  423. end;
  424. function FileIsText(const AFilename: string; out FileReadable: boolean): boolean;
  425. begin
  426. Result:=LazFileUtils.FileIsText(AFilename,FileReadable);
  427. end;
  428. function FilenameIsTrimmed(const TheFilename: string): boolean;
  429. begin
  430. Result:=LazFileUtils.FilenameIsTrimmed(TheFilename);
  431. end;
  432. function FilenameIsTrimmed(StartPos: PChar; NameLen: integer): boolean;
  433. begin
  434. Result:=LazFileUtils.FilenameIsTrimmed(StartPos,NameLen);
  435. end;
  436. function TrimFilename(const AFilename: string): string;
  437. begin
  438. Result:=LazFileUtils.TrimFilename(AFilename);
  439. end;
  440. function CleanAndExpandFilename(const Filename: string): string;
  441. begin
  442. Result:=LazFileUtils.CleanAndExpandFilename(Filename);
  443. end;
  444. function CleanAndExpandDirectory(const Filename: string): string;
  445. begin
  446. Result:=LazFileUtils.CleanAndExpandDirectory(Filename);
  447. end;
  448. function TrimAndExpandFilename(const Filename: string; const BaseDir: string): string;
  449. begin
  450. Result:=LazFileUtils.TrimAndExpandFilename(Filename,BaseDir);
  451. end;
  452. function TrimAndExpandDirectory(const Filename: string; const BaseDir: string): string;
  453. begin
  454. Result:=LazFileUtils.TrimAndExpandDirectory(Filename,BaseDir);
  455. end;
  456. function CreateRelativePath(const Filename, BaseDirectory: string;
  457. UsePointDirectory: boolean): string;
  458. begin
  459. Result:=LazFileUtils.CreateRelativePath(Filename,BaseDirectory,UsePointDirectory);
  460. end;
  461. function FileIsInPath(const Filename, Path: string): boolean;
  462. begin
  463. Result:=LazFileUtils.FileIsInPath(Filename,Path);
  464. end;
  465. function AppendPathDelim(const Path: string): string;
  466. begin
  467. Result:=LazFileUtils.AppendPathDelim(Path);
  468. end;
  469. function ChompPathDelim(const Path: string): string;
  470. begin
  471. Result:=LazFileUtils.ChompPathDelim(Path);
  472. end;
  473. function FileExistsUTF8(const Filename: string): boolean;
  474. begin
  475. Result:=LazFileUtils.FileExistsUTF8(Filename);
  476. end;
  477. function FileAgeUTF8(const FileName: string): Longint;
  478. begin
  479. Result:=LazFileUtils.FileAgeUTF8(Filename);
  480. end;
  481. function DirectoryExistsUTF8(const Directory: string): Boolean;
  482. begin
  483. Result:=LazFileUtils.DirectoryExistsUTF8(Directory);
  484. end;
  485. function ExpandFileNameUTF8(const FileName: string): string;
  486. begin
  487. Result:=LazFileUtils.ExpandFileNameUTF8(Filename);
  488. end;
  489. function FindFirstUTF8(const Path: string; Attr: Longint; out Rslt: TSearchRec): Longint;
  490. begin
  491. Result:=LazFileUtils.FindFirstUTF8(Path,Attr,Rslt);
  492. end;
  493. function FindNextUTF8(var Rslt: TSearchRec): Longint;
  494. begin
  495. Result:=LazFileUtils.FindNextUTF8(Rslt);
  496. end;
  497. procedure FindCloseUTF8(var F: TSearchrec);
  498. begin
  499. LazFileUtils.FindCloseUTF8(F);
  500. end;
  501. function FileSetDateUTF8(const FileName: String; Age: Longint): Longint;
  502. begin
  503. Result:=LazFileUtils.FileSetDateUTF8(FileName,Age);
  504. end;
  505. function FileGetAttrUTF8(const FileName: String): Longint;
  506. begin
  507. Result:=LazFileUtils.FileGetAttrUTF8(FileName);
  508. end;
  509. function FileSetAttrUTF8(const Filename: String; Attr: longint): Longint;
  510. begin
  511. Result:=LazFileUtils.FileSetAttrUTF8(FileName,Attr);
  512. end;
  513. function DeleteFileUTF8(const FileName: String): Boolean;
  514. begin
  515. Result:=LazFileUtils.DeleteFileUTF8(FileName);
  516. end;
  517. function RenameFileUTF8(const OldName, NewName: String): Boolean;
  518. begin
  519. Result:=LazFileUtils.RenameFileUTF8(OldName,NewName);
  520. end;
  521. function FileSearchUTF8(const Name, DirList: String): String;
  522. begin
  523. Result:=LazFileUtils.FileSearchUTF8(Name,DirList);
  524. end;
  525. function FileIsReadOnlyUTF8(const FileName: String): Boolean;
  526. begin
  527. Result:=LazFileUtils.FileIsReadOnlyUTF8(FileName);
  528. end;
  529. function GetCurrentDirUTF8: String;
  530. begin
  531. Result:=LazFileUtils.GetCurrentDirUTF8;
  532. end;
  533. function SetCurrentDirUTF8(const NewDir: String): Boolean;
  534. begin
  535. Result:=LazFileUtils.SetCurrentDirUTF8(NewDir);
  536. end;
  537. function CreateDirUTF8(const NewDir: String): Boolean;
  538. begin
  539. Result:=LazFileUtils.CreateDirUTF8(NewDir);
  540. end;
  541. function RemoveDirUTF8(const Dir: String): Boolean;
  542. begin
  543. Result:=LazFileUtils.RemoveDirUTF8(Dir);
  544. end;
  545. function ForceDirectoriesUTF8(const Dir: string): Boolean;
  546. begin
  547. Result:=LazFileUtils.ForceDirectoriesUTF8(Dir);
  548. end;
  549. function CreateAbsoluteSearchPath(const SearchPath, BaseDirectory: string): string;
  550. begin
  551. Result:=LazFileUtils.CreateAbsoluteSearchPath(SearchPath,BaseDirectory);
  552. end;
  553. function CreateRelativeSearchPath(const SearchPath, BaseDirectory: string): string;
  554. begin
  555. Result:=LazFileUtils.CreateRelativeSearchPath(SearchPath,BaseDirectory);
  556. end;
  557. function MinimizeSearchPath(const SearchPath: string): string;
  558. begin
  559. Result:=LazFileUtils.MinimizeSearchPath(SearchPath);
  560. end;
  561. //function FindPathInSearchPath(APath: PChar; APathLen: integer;
  562. // SearchPath: PChar; SearchPathLen: integer): PChar;
  563. //begin
  564. // Result:=LazFileUtils.FindPathInSearchPath(APath,APathLen,SearchPath,SearchPathLen);
  565. //end;
  566. // LazFileCache
  567. function FileExistsCached(const AFilename: string): boolean;
  568. begin
  569. Result:=LazFileCache.FileExistsCached(AFilename);
  570. end;
  571. function DirPathExistsCached(const AFilename: string): boolean;
  572. begin
  573. Result:=LazFileCache.DirPathExistsCached(AFilename);
  574. end;
  575. function DirectoryIsWritableCached(const ADirectoryName: string): boolean;
  576. begin
  577. Result:=LazFileCache.DirectoryIsWritableCached(ADirectoryName);
  578. end;
  579. function FileIsExecutableCached(const AFilename: string): boolean;
  580. begin
  581. Result:=LazFileCache.FileIsExecutableCached(AFilename);
  582. end;
  583. function FileIsReadableCached(const AFilename: string): boolean;
  584. begin
  585. Result:=LazFileCache.FileIsReadableCached(AFilename);
  586. end;
  587. function FileIsWritableCached(const AFilename: string): boolean;
  588. begin
  589. Result:=LazFileCache.FileIsWritableCached(AFilename);
  590. end;
  591. function FileIsTextCached(const AFilename: string): boolean;
  592. begin
  593. Result:=LazFileCache.FileIsTextCached(AFilename);
  594. end;
  595. function FileAgeCached(const AFileName: string): Longint;
  596. begin
  597. Result:=LazFileCache.FileAgeCached(AFileName);
  598. end;
  599. procedure InvalidateFileStateCache(const Filename: string = '');
  600. begin
  601. LazFileCache.InvalidateFileStateCache(Filename);
  602. end;
  603. // LazUtilities
  604. function ComparePointers(p1, p2: Pointer): integer;
  605. begin
  606. Result:=LazUtilities.ComparePointers(p1,p2);
  607. end;
  608. procedure MergeSort(List: PPointer; ListLength: PtrInt; const Compare: TListSortCompare);
  609. begin
  610. LazUtilities.MergeSort(List,ListLength,Compare);
  611. end;
  612. function GetNextDelimitedItem(const List: string; Delimiter: char;
  613. var Position: integer): string;
  614. begin
  615. Result:=LazUtilities.GetNextDelimitedItem(List,Delimiter,Position);
  616. end;
  617. function HasDelimitedItem(const List: string; Delimiter: char; FindItem: string): boolean;
  618. begin
  619. Result:=LazUtilities.HasDelimitedItem(List,Delimiter,FindItem);
  620. end;
  621. function FindNextDelimitedItem(const List: string; Delimiter: char;
  622. var Position: integer; FindItem: string): string;
  623. begin
  624. Result:=LazUtilities.FindNextDelimitedItem(List,Delimiter,Position,FindItem);
  625. end;
  626. // LazDbgLog
  627. function MemSizeString(const s: string): PtrUInt;
  628. begin
  629. Result:=LazDbgLog.MemSizeString(s);
  630. end;
  631. function MemSizeFPList(const List: TFPList): PtrUInt;
  632. begin
  633. Result:=LazDbgLog.MemSizeFPList(List);
  634. end;
  635. function GetStringRefCount(const s: string): PtrInt;
  636. begin
  637. Result:=LazDbgLog.GetStringRefCount(s);
  638. end;
  639. {$ENDIF EnableWrapperFunctions}
  640. procedure CTIncreaseChangeStamp(var ChangeStamp: integer);
  641. begin
  642. LazFileCache.LUIncreaseChangeStamp(ChangeStamp);
  643. end;
  644. procedure CTIncreaseChangeStamp64(var ChangeStamp: int64);
  645. begin
  646. LazFileCache.LUIncreaseChangeStamp64(ChangeStamp);
  647. end;
  648. function SimpleFormat(const Fmt: String; const Args: array of const): String;
  649. var
  650. Used: array of boolean;
  651. p: Integer;
  652. StartPos: Integer;
  653. procedure ReplaceArg(i: integer; var s: string);
  654. var
  655. Arg: String;
  656. begin
  657. if (i<Low(Args)) or (i>High(Args)) then exit;
  658. case Args[i].VType of
  659. vtInteger: Arg:=dbgs(Args[i].vinteger);
  660. vtInt64: Arg:=dbgs(Args[i].VInt64^);
  661. vtQWord: Arg:=dbgs(Args[i].VQWord^);
  662. vtBoolean: Arg:=dbgs(Args[i].vboolean);
  663. vtExtended: Arg:=dbgs(Args[i].VExtended^);
  664. vtString: Arg:=Args[i].VString^;
  665. vtAnsiString: Arg:=AnsiString(Args[i].VAnsiString);
  666. vtChar: Arg:=Args[i].VChar;
  667. vtPChar: Arg:=Args[i].VPChar;
  668. else exit;
  669. end;
  670. Used[i]:=true;
  671. ReplaceSubstring(s,StartPos,p-StartPos,Arg);
  672. p:=StartPos+length(Arg);
  673. end;
  674. var
  675. RunIndex: Integer;
  676. FixedIndex: Integer;
  677. begin
  678. Result:=Fmt;
  679. if Low(Args)>High(Args) then exit;
  680. SetLength(Used,High(Args)-Low(Args)+1);
  681. for RunIndex:=Low(Args) to High(Args) do
  682. Used[RunIndex]:=false;
  683. RunIndex:=Low(Args);
  684. p:=1;
  685. while p<=length(Result) do
  686. begin
  687. if Result[p]='%' then
  688. begin
  689. StartPos:=p;
  690. inc(p);
  691. case Result[p] of
  692. 's':
  693. begin
  694. inc(p);
  695. ReplaceArg(RunIndex,Result);
  696. inc(RunIndex);
  697. end;
  698. '0'..'9':
  699. begin
  700. FixedIndex:=0;
  701. while (p<=length(Result)) and (Result[p] in ['0'..'9']) do
  702. begin
  703. if FixedIndex<High(Args) then
  704. FixedIndex:=FixedIndex*10+ord(Result[p])-ord('0');
  705. inc(p);
  706. end;
  707. if (p<=length(Result)) and (Result[p]=':') then
  708. begin
  709. inc(p);
  710. if (p<=length(Result)) and (Result[p]='s') then
  711. inc(p);
  712. end;
  713. ReplaceArg(FixedIndex,Result);
  714. end;
  715. else
  716. inc(p);
  717. end;
  718. end else
  719. inc(p);
  720. end;
  721. // append all missing arguments
  722. for RunIndex:=Low(Args) to High(Args) do
  723. begin
  724. if Used[RunIndex] then continue;
  725. Result+=',';
  726. StartPos:=length(Result)+1;
  727. p:=StartPos;
  728. ReplaceArg(RunIndex,Result);
  729. end;
  730. end;
  731. procedure RaiseCatchableException(const Msg: string);
  732. begin
  733. { Raises an exception.
  734. gdb does not catch fpc Exception objects, therefore this procedure raises
  735. a standard AV which is catched by gdb. }
  736. DebugLn('ERROR in CodeTools: ',Msg);
  737. // creates an exception, that gdb catches:
  738. DebugLn('Creating gdb catchable error:');
  739. if (length(Msg) div (length(Msg) div 10000))=0 then ;
  740. end;
  741. procedure RaiseAndCatchException;
  742. begin
  743. try
  744. if (length(ctsAddsDirToIncludePath) div (length(ctsAddsDirToIncludePath) div 10000))=0 then ;
  745. except
  746. end;
  747. end;
  748. var
  749. LineInfoCache: TAVLTree = nil;
  750. LastTick: int64 = 0;
  751. function FileDateToDateTimeDef(aFileDate: TCTFileAgeTime; const Default: TDateTime
  752. ): TDateTime;
  753. begin
  754. try
  755. Result:=FileDateToDateTime(aFileDate);
  756. except
  757. Result:=Default;
  758. end;
  759. end;
  760. {-------------------------------------------------------------------------------
  761. function ClearFile(const Filename: string; RaiseOnError: boolean): boolean;
  762. -------------------------------------------------------------------------------}
  763. function ClearFile(const Filename: string; RaiseOnError: boolean): boolean;
  764. var
  765. fs: TFileStreamUTF8;
  766. begin
  767. if LazFileUtils.FileExistsUTF8(Filename) then begin
  768. try
  769. LazFileUtils.InvalidateFileStateCache(Filename);
  770. fs:=TFileStreamUTF8.Create(Filename,fmOpenWrite);
  771. fs.Size:=0;
  772. fs.Free;
  773. except
  774. on E: Exception do begin
  775. Result:=false;
  776. if RaiseOnError then raise;
  777. exit;
  778. end;
  779. end;
  780. end;
  781. Result:=true;
  782. end;
  783. function GetTempFilename(const Path, Prefix: string): string;
  784. var
  785. i: Integer;
  786. CurPath: String;
  787. CurName: String;
  788. begin
  789. Result:=LazFileUtils.ExpandFileNameUTF8(Path);
  790. CurPath:=LazFileUtils.AppendPathDelim(ExtractFilePath(Result));
  791. CurName:=Prefix+LazFileUtils.ExtractFileNameOnly(Result);
  792. i:=1;
  793. repeat
  794. Result:=CurPath+CurName+IntToStr(i)+'.tmp';
  795. if not LazFileUtils.FileExistsUTF8(Result) then exit;
  796. inc(i);
  797. until false;
  798. end;
  799. function FindDiskFilename(const Filename: string): string;
  800. // Searches for the filename case on disk.
  801. // if it does not exist, only the found path will be improved
  802. // For example:
  803. // If Filename='file' and there is only a 'File' then 'File' will be returned.
  804. var
  805. StartPos: Integer;
  806. EndPos: LongInt;
  807. FileInfo: TSearchRec;
  808. CurDir: String;
  809. CurFile: String;
  810. AliasFile: String;
  811. Ambiguous: Boolean;
  812. FileNotFound: Boolean;
  813. begin
  814. Result:=Filename;
  815. // check every directory and filename
  816. StartPos:=1;
  817. {$IFDEF Windows}
  818. // uppercase Drive letter and skip it
  819. if ((length(Result)>=2) and (Result[1] in ['A'..'Z','a'..'z'])
  820. and (Result[2]=':')) then begin
  821. StartPos:=3;
  822. if Result[1] in ['a'..'z'] then
  823. Result[1]:=FPUpChars[Result[1]];
  824. end;
  825. {$ENDIF}
  826. FileNotFound:=false;
  827. repeat
  828. // skip PathDelim
  829. while (StartPos<=length(Result)) and (Result[StartPos]=PathDelim) do
  830. inc(StartPos);
  831. // find end of filename part
  832. EndPos:=StartPos;
  833. while (EndPos<=length(Result)) and (Result[EndPos]<>PathDelim) do
  834. inc(EndPos);
  835. if EndPos>StartPos then begin
  836. // search file
  837. CurDir:=copy(Result,1,StartPos-1);
  838. CurFile:=copy(Result,StartPos,EndPos-StartPos);
  839. AliasFile:='';
  840. Ambiguous:=false;
  841. if LazFileUtils.FindFirstUTF8(CurDir+FileMask,faAnyFile,FileInfo)=0 then
  842. begin
  843. repeat
  844. // check if special file
  845. if (FileInfo.Name='.') or (FileInfo.Name='..') or (FileInfo.Name='')
  846. then
  847. continue;
  848. if LazFileUtils.CompareFilenamesIgnoreCase(FileInfo.Name,CurFile)=0 then begin
  849. //writeln('FindDiskFilename ',FileInfo.Name,' ',CurFile);
  850. if FileInfo.Name=CurFile then begin
  851. // file found, has already the correct name
  852. AliasFile:='';
  853. break;
  854. end else begin
  855. // alias found, but has not the correct name
  856. if AliasFile='' then begin
  857. AliasFile:=FileInfo.Name;
  858. end else begin
  859. // there are more than one candidate
  860. Ambiguous:=true;
  861. end;
  862. end;
  863. end;
  864. until LazFileUtils.FindNextUTF8(FileInfo)<>0;
  865. end else
  866. FileNotFound:=true;
  867. LazFileUtils.FindCloseUTF8(FileInfo);
  868. if FileNotFound then break;
  869. if (AliasFile<>'') and (not Ambiguous) then begin
  870. // better filename found -> replace
  871. Result:=CurDir+AliasFile+copy(Result,EndPos,length(Result));
  872. end;
  873. end;
  874. StartPos:=EndPos+1;
  875. until StartPos>length(Result);
  876. end;
  877. {------------------------------------------------------------------------------
  878. function ReadAllLinks(const Filename: string;
  879. ExceptionOnError: boolean): string;
  880. ------------------------------------------------------------------------------}
  881. function ReadAllLinks(const Filename: string;
  882. ExceptionOnError: boolean): string;
  883. begin
  884. Result:=LazFileUtils.ReadAllLinks(Filename,ExceptionOnError);
  885. end;
  886. function TryReadAllLinks(const Filename: string): string;
  887. begin
  888. Result:=LazFileUtils.TryReadAllLinks(Filename);
  889. end;
  890. {$IFDEF darwin}
  891. function GetDarwinSystemFilename(Filename: string): string;
  892. var
  893. s: CFStringRef;
  894. l: CFIndex;
  895. begin
  896. if Filename='' then exit('');
  897. s:=CFStringCreateWithCString(nil,Pointer(Filename),kCFStringEncodingUTF8);
  898. l:=CFStringGetMaximumSizeOfFileSystemRepresentation(s);
  899. SetLength(Result,l);
  900. if Result<>'' then begin
  901. CFStringGetFileSystemRepresentation(s,@Result[1],length(Result));
  902. SetLength(Result,StrLen(PChar(Result)));
  903. end;
  904. CFRelease(s);
  905. end;
  906. {$ENDIF}
  907. function GetFilenameOnDisk(const AFilename: string): string;
  908. begin
  909. Result:=FindDiskFilename(AFilename);
  910. end;
  911. function CompareAnsiStringFilenames(Data1, Data2: Pointer): integer;
  912. begin
  913. Result:=LazFileUtils.CompareFilenames(AnsiString(Data1),AnsiString(Data2));
  914. end;
  915. function CompareFilenameOnly(Filename: PChar; FilenameLen: integer;
  916. NameOnly: PChar; NameOnlyLen: integer; CaseSensitive: boolean): integer;
  917. // compare only the filename (without extension and path)
  918. var
  919. EndPos: integer;
  920. StartPos: LongInt;
  921. p: Integer;
  922. l: LongInt;
  923. FilenameOnlyLen: Integer;
  924. begin
  925. StartPos:=FilenameLen;
  926. while (StartPos>0) and (Filename[StartPos-1]<>PathDelim) do dec(StartPos);
  927. EndPos:=FilenameLen;
  928. while (EndPos>StartPos) and (Filename[EndPos]<>'.') do dec(EndPos);
  929. if (EndPos=StartPos) and (EndPos<FilenameLen) and (Filename[EndPos]<>'.') then
  930. EndPos:=FilenameLen;
  931. FilenameOnlyLen:=EndPos-StartPos;
  932. l:=FilenameOnlyLen;
  933. if l>NameOnlyLen then
  934. l:=NameOnlyLen;
  935. //DebugLn('CompareFilenameOnly NameOnly="',copy(NameOnly,1,NameOnlyLen),'" FilenameOnly="',copy(Filename,StartPos,EndPos-StartPos),'"');
  936. p:=0;
  937. if CaseSensitive then begin
  938. while p<l do begin
  939. Result:=ord(Filename[StartPos+p])-ord(NameOnly[p]);
  940. if Result<>0 then exit;
  941. inc(p);
  942. end;
  943. end else begin
  944. while p<l do begin
  945. Result:=ord(FPUpChars[Filename[StartPos+p]])-ord(FPUpChars[NameOnly[p]]);
  946. if Result<>0 then exit;
  947. inc(p);
  948. end;
  949. end;
  950. Result:=FilenameOnlyLen-NameOnlyLen;
  951. end;
  952. function FilenameIsPascalUnit(const Filename: string;
  953. CaseSensitive: boolean): boolean;
  954. begin
  955. Result:=(Filename<>'')
  956. and FilenameIsPascalUnit(PChar(Filename),length(Filename),CaseSensitive);
  957. end;
  958. function FilenameIsPascalUnit(Filename: PChar; FilenameLen: integer;
  959. CaseSensitive: boolean): boolean;
  960. var
  961. ExtPos: LongInt;
  962. ExtLen: Integer;
  963. e: TCTPascalExtType;
  964. i: Integer;
  965. p: PChar;
  966. begin
  967. if (Filename=nil) or (FilenameLen<2) then exit(false);
  968. ExtPos:=FilenameLen-1;
  969. while (ExtPos>0) and (Filename[ExtPos]<>'.') do dec(ExtPos);
  970. if ExtPos<=0 then exit(false);
  971. // check extension
  972. ExtLen:=FilenameLen-ExtPos;
  973. for e:=Low(CTPascalExtension) to High(CTPascalExtension) do begin
  974. if (CTPascalExtension[e]='') or (length(CTPascalExtension[e])<>ExtLen) then
  975. continue;
  976. i:=0;
  977. p:=PChar(Pointer(CTPascalExtension[e]));// pointer type cast avoids #0 check
  978. if CaseSensitive then begin
  979. while (i<ExtLen) and (p^=Filename[ExtPos+i]) do begin
  980. inc(i);
  981. inc(p);
  982. end;
  983. end else begin
  984. while (i<ExtLen) and (FPUpChars[p^]=FPUpChars[Filename[ExtPos+i]]) do
  985. begin
  986. inc(i);
  987. inc(p);
  988. end;
  989. end;
  990. if i<>ExtLen then continue;
  991. // check name is dotted identifier
  992. p:=@Filename[ExtPos];
  993. while (p>Filename) and (p[-1]<>PathDelim) do dec(p);
  994. repeat
  995. if not (p^ in ['a'..'z','A'..'Z','_']) then exit(false);
  996. inc(p);
  997. while (p^ in ['a'..'z','A'..'Z','_','0'..'9']) do inc(p);
  998. if p^<>'.' then exit(false);
  999. if p-Filename=ExtPos then exit(true);
  1000. inc(p);
  1001. until false;
  1002. end;
  1003. Result:=false;
  1004. end;
  1005. function ExtractFileUnitname(Filename: string; WithNameSpace: boolean): string;
  1006. var
  1007. p: Integer;
  1008. begin
  1009. Result:=LazFileUtils.ExtractFileNameOnly(Filename);
  1010. if (Result='') or WithNameSpace then exit;
  1011. // find last dot
  1012. p:=length(Result);
  1013. while p>0 do begin
  1014. if Result[p]='.' then begin
  1015. Delete(Result,1,p);
  1016. exit;
  1017. end;
  1018. dec(p);
  1019. end;
  1020. end;
  1021. function IsPascalUnitExt(FileExt: PChar; CaseSensitive: boolean): boolean;
  1022. // check if asciiz FileExt is a CTPascalExtension '.pp', '.pas'
  1023. var
  1024. ExtLen: Integer;
  1025. p: PChar;
  1026. e: TCTPascalExtType;
  1027. f: PChar;
  1028. begin
  1029. Result:=false;
  1030. if (FileExt=nil) then exit;
  1031. ExtLen:=strlen(FileExt);
  1032. if ExtLen=0 then exit;
  1033. for e:=Low(CTPascalExtension) to High(CTPascalExtension) do begin
  1034. if length(CTPascalExtension[e])<>ExtLen then
  1035. continue;
  1036. p:=PChar(Pointer(CTPascalExtension[e]));// pointer type cast avoids #0 check
  1037. f:=FileExt;
  1038. //debugln(['IsPascalUnitExt p="',dbgstr(p),'" f="',dbgstr(f),'"']);
  1039. if CaseSensitive then begin
  1040. while (p^=f^) and (p^<>#0) do begin
  1041. inc(p);
  1042. inc(f);
  1043. end;
  1044. end else begin
  1045. while (FPUpChars[p^]=FPUpChars[f^]) and (p^<>#0) do
  1046. begin
  1047. inc(p);
  1048. inc(f);
  1049. end;
  1050. end;
  1051. if p^=#0 then
  1052. exit(true);
  1053. end;
  1054. end;
  1055. function SearchPascalUnitInDir(const AnUnitName, BaseDirectory: string;
  1056. SearchCase: TCTSearchFileCase): string;
  1057. procedure RaiseNotImplemented;
  1058. begin
  1059. raise Exception.Create('not implemented');
  1060. end;
  1061. var
  1062. Base: String;
  1063. FileInfo: TSearchRec;
  1064. LowerCaseUnitname: String;
  1065. UpperCaseUnitname: String;
  1066. CurUnitName: String;
  1067. begin
  1068. Base:=LazFileUtils.AppendPathDelim(BaseDirectory);
  1069. Base:=LazFileUtils.TrimFilename(Base);
  1070. // search file
  1071. Result:='';
  1072. if SearchCase=ctsfcAllCase then
  1073. Base:=FindDiskFilename(Base);
  1074. if SearchCase in [ctsfcDefault,ctsfcLoUpCase] then begin
  1075. LowerCaseUnitname:=lowercase(AnUnitName);
  1076. UpperCaseUnitname:=uppercase(AnUnitName);
  1077. end else begin
  1078. LowerCaseUnitname:='';
  1079. UpperCaseUnitname:='';
  1080. end;
  1081. if LazFileUtils.FindFirstUTF8(Base+FileMask,faAnyFile,FileInfo)=0 then
  1082. begin
  1083. repeat
  1084. // check if special file
  1085. if (FileInfo.Name='.') or (FileInfo.Name='..') or (FileInfo.Name='')
  1086. then
  1087. continue;
  1088. if not FilenameIsPascalUnit(FileInfo.Name,false) then continue;
  1089. case SearchCase of
  1090. ctsfcDefault,ctsfcLoUpCase:
  1091. if (CompareFilenameOnly(PChar(Pointer(FileInfo.Name)),// pointer type cast avoids #0 check
  1092. length(FileInfo.Name),
  1093. PChar(Pointer(AnUnitName)),
  1094. length(AnUnitName),false)=0)
  1095. then begin
  1096. CurUnitName:=LazFileUtils.ExtractFileNameOnly(FileInfo.Name);
  1097. if CurUnitName=AnUnitName then begin
  1098. Result:=FileInfo.Name;
  1099. break;
  1100. end else if ((LowerCaseUnitname=CurUnitName)
  1101. or (UpperCaseUnitname=CurUnitName)) then begin
  1102. Result:=FileInfo.Name;
  1103. end;
  1104. end;
  1105. ctsfcAllCase:
  1106. if (CompareFilenameOnly(PChar(Pointer(FileInfo.Name)),// pointer type cast avoids #0 check
  1107. length(FileInfo.Name),
  1108. PChar(Pointer(AnUnitName)),length(AnUnitName),
  1109. false)=0)
  1110. then begin
  1111. Result:=FileInfo.Name;
  1112. CurUnitName:=LazFileUtils.ExtractFileNameOnly(FileInfo.Name);
  1113. if CurUnitName=AnUnitName then
  1114. break;
  1115. end;
  1116. else
  1117. RaiseNotImplemented;
  1118. end;
  1119. until LazFileUtils.FindNextUTF8(FileInfo)<>0;
  1120. end;
  1121. LazFileUtils.FindCloseUTF8(FileInfo);
  1122. if Result<>'' then Result:=Base+Result;
  1123. end;
  1124. function SearchPascalUnitInPath(const AnUnitName, BasePath, SearchPath,
  1125. Delimiter: string; SearchCase: TCTSearchFileCase): string;
  1126. var
  1127. p, StartPos, l: integer;
  1128. CurPath, Base: string;
  1129. begin
  1130. Base:=LazFileUtils.AppendPathDelim(LazFileUtils.ExpandFileNameUTF8(BasePath));
  1131. // search in current directory
  1132. Result:=SearchPascalUnitInDir(AnUnitName,Base,SearchCase);
  1133. if Result<>'' then exit;
  1134. // search in search path
  1135. StartPos:=1;
  1136. l:=length(SearchPath);
  1137. while StartPos<=l do begin
  1138. p:=StartPos;
  1139. while (p<=l) and (pos(SearchPath[p],Delimiter)<1) do inc(p);
  1140. CurPath:=Trim(copy(SearchPath,StartPos,p-StartPos));
  1141. if CurPath<>'' then begin
  1142. if not LazFileUtils.FilenameIsAbsolute(CurPath) then
  1143. CurPath:=Base+CurPath;
  1144. CurPath:=LazFileUtils.AppendPathDelim(ResolveDots(CurPath));
  1145. Result:=SearchPascalUnitInDir(AnUnitName,CurPath,SearchCase);
  1146. if Result<>'' then exit;
  1147. end;
  1148. StartPos:=p+1;
  1149. end;
  1150. Result:='';
  1151. end;
  1152. function SearchPascalFileInDir(const ShortFilename, BaseDirectory: string;
  1153. SearchCase: TCTSearchFileCase): string;
  1154. procedure RaiseNotImplemented;
  1155. begin
  1156. raise Exception.Create('not implemented');
  1157. end;
  1158. var
  1159. Base: String;
  1160. FileInfo: TSearchRec;
  1161. LowerCaseFilename: string;
  1162. UpperCaseFilename: string;
  1163. begin
  1164. Base:=LazFileUtils.AppendPathDelim(BaseDirectory);
  1165. Base:=LazFileUtils.TrimFilename(Base);
  1166. // search file
  1167. Result:='';
  1168. if SearchCase=ctsfcAllCase then
  1169. Base:=FindDiskFilename(Base);
  1170. if SearchCase in [ctsfcDefault,ctsfcLoUpCase] then begin
  1171. LowerCaseFilename:=lowercase(ShortFilename);
  1172. UpperCaseFilename:=uppercase(ShortFilename);
  1173. end else begin
  1174. LowerCaseFilename:='';
  1175. UpperCaseFilename:='';
  1176. end;
  1177. if LazFileUtils.FindFirstUTF8(Base+FileMask,faAnyFile,FileInfo)=0 then
  1178. begin
  1179. repeat
  1180. // check if special file
  1181. if (FileInfo.Name='.') or (FileInfo.Name='..') or (FileInfo.Name='')
  1182. then
  1183. continue;
  1184. case SearchCase of
  1185. ctsfcDefault,ctsfcLoUpCase:
  1186. if (ShortFilename=FileInfo.Name) then begin
  1187. Result:=FileInfo.Name;
  1188. break;
  1189. end else if (LowerCaseFilename=FileInfo.Name)
  1190. or (UpperCaseFilename=FileInfo.Name)
  1191. then
  1192. Result:=FileInfo.Name;
  1193. ctsfcAllCase:
  1194. if LazFileUtils.CompareFilenamesIgnoreCase(ShortFilename,FileInfo.Name)=0 then begin
  1195. Result:=FileInfo.Name;
  1196. if ShortFilename=FileInfo.Name then break;
  1197. end;
  1198. else
  1199. RaiseNotImplemented;
  1200. end;
  1201. until LazFileUtils.FindNextUTF8(FileInfo)<>0;
  1202. end;
  1203. LazFileUtils.FindCloseUTF8(FileInfo);
  1204. if Result<>'' then Result:=Base+Result;
  1205. end;
  1206. function SearchPascalFileInPath(const ShortFilename, BasePath, SearchPath,
  1207. Delimiter: string; SearchCase: TCTSearchFileCase): string;
  1208. // search in each directory, first normal case, then lower case, then upper case
  1209. var
  1210. p, StartPos, l: integer;
  1211. CurPath, Base: string;
  1212. begin
  1213. Base:=LazFileUtils.AppendPathDelim(LazFileUtils.ExpandFileNameUTF8(BasePath));
  1214. // search in current directory
  1215. if not LazFileUtils.FilenameIsAbsolute(Base) then
  1216. Base:='';
  1217. if Base<>'' then begin
  1218. Result:=SearchPascalFileInDir(ShortFilename,Base,SearchCase);
  1219. if Result<>'' then exit;
  1220. end;
  1221. // search in search path
  1222. StartPos:=1;
  1223. l:=length(SearchPath);
  1224. while StartPos<=l do begin
  1225. p:=StartPos;
  1226. while (p<=l) and (pos(SearchPath[p],Delimiter)<1) do inc(p);
  1227. CurPath:=Trim(copy(SearchPath,StartPos,p-StartPos));
  1228. if CurPath<>'' then begin
  1229. if not LazFileUtils.FilenameIsAbsolute(CurPath) then
  1230. CurPath:=Base+CurPath;
  1231. CurPath:=LazFileUtils.AppendPathDelim(ResolveDots(CurPath));
  1232. if LazFileUtils.FilenameIsAbsolute(CurPath) then begin
  1233. Result:=SearchPascalFileInDir(ShortFilename,CurPath,SearchCase);
  1234. if Result<>'' then exit;
  1235. end;
  1236. end;
  1237. StartPos:=p+1;
  1238. end;
  1239. Result:='';
  1240. end;
  1241. function ReadNextFPCParameter(const CmdLine: string; var Position: integer; out
  1242. StartPos: integer): boolean;
  1243. // reads till start of next FPC command line parameter, parses quotes ' and "
  1244. var
  1245. c: Char;
  1246. begin
  1247. StartPos:=Position;
  1248. while (StartPos<=length(CmdLine)) and (CmdLine[StartPos] in [' ',#9,#10,#13]) do
  1249. inc(StartPos);
  1250. Position:=StartPos;
  1251. while (Position<=length(CmdLine)) do begin
  1252. c:=CmdLine[Position];
  1253. case c of
  1254. ' ',#9,#10,#13: break;
  1255. '''','"':
  1256. repeat
  1257. inc(Position);
  1258. until (Position>length(CmdLine)) or (CmdLine[Position]=c);
  1259. end;
  1260. inc(Position);
  1261. end;
  1262. Result:=StartPos<=length(CmdLine);
  1263. end;
  1264. function ExtractFPCParameter(const CmdLine: string; StartPos: integer): string;
  1265. // returns a single FPC command line parameter, resolves quotes ' and "
  1266. var
  1267. p: Integer;
  1268. c: Char;
  1269. procedure Add;
  1270. begin
  1271. Result:=Result+copy(CmdLine,StartPos,p-StartPos);
  1272. end;
  1273. begin
  1274. Result:='';
  1275. p:=StartPos;
  1276. while (p<=length(CmdLine)) do begin
  1277. c:=CmdLine[p];
  1278. case c of
  1279. ' ',#9,#10,#13: break;
  1280. '''','"':
  1281. begin
  1282. Add;
  1283. inc(p);
  1284. StartPos:=p;
  1285. while (p<=length(CmdLine)) do begin
  1286. if CmdLine[p]=c then begin
  1287. Add;
  1288. inc(p);
  1289. StartPos:=p;
  1290. break;
  1291. end;
  1292. inc(p);
  1293. end;
  1294. end;
  1295. end;
  1296. inc(p);
  1297. end;
  1298. Add;
  1299. end;
  1300. function FindNextFPCParameter(const CmdLine, BeginsWith: string;
  1301. var Position: integer): integer;
  1302. begin
  1303. if BeginsWith='' then
  1304. exit(-1);
  1305. while ReadNextFPCParameter(CmdLine,Position,Result) do
  1306. if LeftStr(ExtractFPCParameter(CmdLine,Result),length(BeginsWith))=BeginsWith
  1307. then
  1308. exit;
  1309. Result:=-1;
  1310. end;
  1311. function GetLastFPCParameter(const CmdLine, BeginsWith: string;
  1312. CutBegins: boolean): string;
  1313. var
  1314. Param: String;
  1315. p: Integer;
  1316. StartPos: integer;
  1317. begin
  1318. Result:='';
  1319. if BeginsWith='' then
  1320. exit;
  1321. p:=1;
  1322. while ReadNextFPCParameter(CmdLine,p,StartPos) do begin
  1323. Param:=ExtractFPCParameter(CmdLine,StartPos);
  1324. if LeftStr(Param,length(BeginsWith))=BeginsWith then begin
  1325. Result:=Param;
  1326. if CutBegins then
  1327. System.Delete(Result,1,length(BeginsWith));
  1328. end;
  1329. end;
  1330. end;
  1331. function GetFPCParameterSrcFile(const CmdLine: string): string;
  1332. // the source file is the last parameter not starting with minus
  1333. var
  1334. p: Integer;
  1335. StartPos: integer;
  1336. begin
  1337. p:=1;
  1338. while ReadNextFPCParameter(CmdLine,p,StartPos) do begin
  1339. if (CmdLine[StartPos]='-') then continue;
  1340. Result:=ExtractFPCParameter(CmdLine,StartPos);
  1341. if (Result='') or (Result[1]='-') then continue;
  1342. exit;
  1343. end;
  1344. Result:='';
  1345. end;
  1346. function SearchFileInDir(const Filename, BaseDirectory: string;
  1347. SearchCase: TCTSearchFileCase): string;
  1348. procedure RaiseNotImplemented;
  1349. begin
  1350. raise Exception.Create('not implemented');
  1351. end;
  1352. var
  1353. Base: String;
  1354. ShortFile: String;
  1355. FileInfo: TSearchRec;
  1356. begin
  1357. Result:='';
  1358. Base:=LazFileUtils.AppendPathDelim(BaseDirectory);
  1359. ShortFile:=Filename;
  1360. if System.Pos(PathDelim,ShortFile)>0 then begin
  1361. Base:=Base+ExtractFilePath(ShortFile);
  1362. ShortFile:=ExtractFilename(ShortFile);
  1363. end;
  1364. Base:=LazFileUtils.TrimFilename(Base);
  1365. case SearchCase of
  1366. ctsfcDefault:
  1367. begin
  1368. Result:=Base+ShortFile;
  1369. if not LazFileCache.FileExistsCached(Result) then Result:='';
  1370. end;
  1371. ctsfcLoUpCase:
  1372. begin
  1373. Result:=Base+ShortFile;
  1374. if not LazFileCache.FileExistsCached(Result) then begin
  1375. Result:=lowercase(Result);
  1376. if not LazFileCache.FileExistsCached(Result) then begin
  1377. Result:=uppercase(Result);
  1378. if not LazFileCache.FileExistsCached(Result) then Result:='';
  1379. end;
  1380. end;
  1381. end;
  1382. ctsfcAllCase:
  1383. begin
  1384. // search file
  1385. Base:=FindDiskFilename(Base);
  1386. if LazFileUtils.FindFirstUTF8(Base+FileMask,faAnyFile,FileInfo)=0 then
  1387. begin
  1388. repeat
  1389. // check if special file
  1390. if (FileInfo.Name='.') or (FileInfo.Name='..') or (FileInfo.Name='')
  1391. then
  1392. continue;
  1393. if LazFileUtils.CompareFilenamesIgnoreCase(FileInfo.Name,ShortFile)=0 then begin
  1394. if FileInfo.Name=ShortFile then begin
  1395. // file found, with correct name
  1396. Result:=FileInfo.Name;
  1397. break;
  1398. end else begin
  1399. // alias found, but has not the correct name
  1400. Result:=FileInfo.Name;
  1401. end;
  1402. end;
  1403. until LazFileUtils.FindNextUTF8(FileInfo)<>0;
  1404. end;
  1405. LazFileUtils.FindCloseUTF8(FileInfo);
  1406. if Result<>'' then Result:=Base+Result;
  1407. end;
  1408. else
  1409. RaiseNotImplemented;
  1410. end;
  1411. end;
  1412. function SearchFileInPath(const Filename, BasePath, SearchPath,
  1413. Delimiter: string; SearchCase: TCTSearchFileCase): string;
  1414. var
  1415. p, StartPos, l: integer;
  1416. CurPath, Base: string;
  1417. begin
  1418. //debugln('[SearchFileInPath] Filename="',Filename,'" BasePath="',BasePath,'" SearchPath="',SearchPath,'" Delimiter="',Delimiter,'"');
  1419. if (Filename='') then begin
  1420. Result:='';
  1421. exit;
  1422. end;
  1423. // check if filename absolute
  1424. if LazFileUtils.FilenameIsAbsolute(Filename) then begin
  1425. if SearchCase=ctsfcDefault then begin
  1426. Result:=ResolveDots(Filename);
  1427. if not LazFileCache.FileExistsCached(Result) then
  1428. Result:='';
  1429. end else
  1430. Result:=SearchFileInPath(ExtractFilename(Filename),
  1431. ExtractFilePath(BasePath),'',';',SearchCase);
  1432. exit;
  1433. end;
  1434. Base:=LazFileUtils.AppendPathDelim(LazFileUtils.ExpandFileNameUTF8(BasePath));
  1435. // search in current directory
  1436. Result:=SearchFileInDir(Filename,Base,SearchCase);
  1437. if Result<>'' then exit;
  1438. // search in search path
  1439. StartPos:=1;
  1440. l:=length(SearchPath);
  1441. while StartPos<=l do begin
  1442. p:=StartPos;
  1443. while (p<=l) and (pos(SearchPath[p],Delimiter)<1) do inc(p);
  1444. CurPath:=Trim(copy(SearchPath,StartPos,p-StartPos));
  1445. if CurPath<>'' then begin
  1446. if not LazFileUtils.FilenameIsAbsolute(CurPath) then
  1447. CurPath:=Base+CurPath;
  1448. CurPath:=LazFileUtils.AppendPathDelim(ResolveDots(CurPath));
  1449. Result:=SearchFileInDir(Filename,CurPath,SearchCase);
  1450. if Result<>'' then exit;
  1451. end;
  1452. StartPos:=p+1;
  1453. end;
  1454. Result:='';
  1455. end;
  1456. function FilenameIsMatching(const Mask, Filename: string; MatchExactly: boolean
  1457. ): boolean;
  1458. (*
  1459. check if Filename matches Mask
  1460. if MatchExactly then the complete Filename must match, else only the
  1461. start
  1462. Filename matches exactly or is a file/directory in a subdirectory of mask.
  1463. Mask can contain the wildcards * and ? and the set operator {,}.
  1464. The wildcards will *not* match PathDelim.
  1465. You can nest the {} sets.
  1466. If you need the asterisk, the question mark or the PathDelim as character
  1467. just put the SpecialChar character in front of it (e.g. #*, #? #/).
  1468. Examples:
  1469. /abc matches /abc, /abc/, /abc/p, /abc/xyz/filename
  1470. but not /abcd
  1471. /abc/ matches /abc, /abc/, /abc//, but not /abc/.
  1472. /abc/x?z/www matches /abc/xyz/www, /abc/xaz/www
  1473. but not /abc/x/z/www
  1474. /abc/x*z/www matches /abc/xz/www, /abc/xyz/www, /abc/xAAAz/www
  1475. but not /abc/x/z/www
  1476. /abc/x#*z/www matches /abc/x*z/www, /abc/x*z/www/ttt
  1477. /a{b,c,d}e matches /abe, /ace, /ade
  1478. *.p{as,p,} matches a.pas, unit1.pp, b.p but not b.inc
  1479. *.{p{as,p,},inc} matches a.pas, unit1.pp, b.p, b.inc but not c.lfm
  1480. *)
  1481. {off $DEFINE VerboseFilenameIsMatching}
  1482. function Check(MaskP, FileP: PChar): boolean;
  1483. var
  1484. Level: Integer;
  1485. MaskStart: PChar;
  1486. FileStart: PChar;
  1487. begin
  1488. {$IFDEF VerboseFilenameIsMatching}
  1489. debugln([' Check Mask="',MaskP,'" FileP="',FileP,'"']);
  1490. {$ENDIF}
  1491. Result:=false;
  1492. repeat
  1493. case MaskP^ of
  1494. #0:
  1495. begin
  1496. // the whole Mask fits the start of Filename
  1497. // trailing PathDelim in FileP are ok
  1498. {$IFDEF VerboseFilenameIsMatching}
  1499. debugln([' Check END Mask="',MaskP,'" FileP="',FileP,'"']);
  1500. {$ENDIF}
  1501. if FileP^=#0 then exit(true);
  1502. if FileP^<>PathDelim then exit(false);
  1503. while FileP^=PathDelim do inc(FileP);
  1504. Result:=(FileP^=#0) or (not MatchExactly);
  1505. exit;
  1506. end;
  1507. SpecialChar:
  1508. begin
  1509. // match on character
  1510. {$IFDEF VerboseFilenameIsMatching}
  1511. debugln([' Check specialchar Mask="',MaskP,'" FileP="',FileP,'"']);
  1512. {$ENDIF}
  1513. inc(MaskP);
  1514. if MaskP^=#0 then exit;
  1515. if MaskP^<>FileP^ then exit;
  1516. inc(MaskP);
  1517. inc(FileP);
  1518. end;
  1519. PathDelim:
  1520. begin
  1521. // match PathDelim(s) or end of filename
  1522. {$IFDEF VerboseFilenameIsMatching}
  1523. debugln([' Check PathDelim Mask="',MaskP,'" FileP="',FileP,'"']);
  1524. {$ENDIF}
  1525. if not (FileP^ in [#0,PathDelim]) then exit;
  1526. // treat several PathDelim as one
  1527. while MaskP^=PathDelim do inc(MaskP);
  1528. while FileP^=PathDelim do inc(FileP);
  1529. if MaskP^=#0 then
  1530. exit((FileP^=#0) or not MatchExactly);
  1531. end;
  1532. '?':
  1533. begin
  1534. // match any one character, but PathDelim
  1535. {$IFDEF VerboseFilenameIsMatching}
  1536. debugln([' Check any one char Mask="',MaskP,'" FileP="',FileP,'"']);
  1537. {$ENDIF}
  1538. if FileP^ in [#0,PathDelim] then exit;
  1539. inc(MaskP);
  1540. inc(FileP,LazUTF8.UTF8CharacterLength(FileP));
  1541. end;
  1542. '*':
  1543. begin
  1544. // match 0 or more characters, but PathDelim
  1545. {$IFDEF VerboseFilenameIsMatching}
  1546. debugln([' Check any chars Mask="',MaskP,'" FileP="',FileP,'"']);
  1547. {$ENDIF}
  1548. while MaskP^='*' do inc(MaskP);
  1549. repeat
  1550. if Check(MaskP,FileP) then exit(true);
  1551. if FileP^ in [#0,PathDelim] then exit;
  1552. inc(FileP);
  1553. until false;
  1554. end;
  1555. '{':
  1556. begin
  1557. // OR options separated by comma
  1558. {$IFDEF VerboseFilenameIsMatching}
  1559. debugln([' Check { Mask="',MaskP,'" FileP="',FileP,'"']);
  1560. {$ENDIF}
  1561. inc(MaskP);
  1562. repeat
  1563. if Check(MaskP,FileP) then begin
  1564. {$IFDEF VerboseFilenameIsMatching}
  1565. debugln([' Check { option fits -> end']);
  1566. {$ENDIF}
  1567. exit(true);
  1568. end;
  1569. {$IFDEF VerboseFilenameIsMatching}
  1570. debugln([' Check { skip to next option ...']);
  1571. {$ENDIF}
  1572. // skip to next option in MaskP
  1573. Level:=1;
  1574. repeat
  1575. case MaskP^ of
  1576. #0: exit;
  1577. SpecialChar:
  1578. begin
  1579. inc(MaskP);
  1580. if MaskP^=#0 then exit;
  1581. inc(MaskP);
  1582. end;
  1583. '{': inc(Level);
  1584. '}':
  1585. begin
  1586. dec(Level);
  1587. if Level=0 then exit; // no option fits
  1588. end;
  1589. ',':
  1590. if Level=1 then break;
  1591. end;
  1592. inc(MaskP);
  1593. until false;
  1594. {$IFDEF VerboseFilenameIsMatching}
  1595. debugln([' Check { next option: "',MaskP,'"']);
  1596. {$ENDIF}
  1597. inc(MaskP)
  1598. until false;
  1599. end;
  1600. '}':
  1601. begin
  1602. {$IFDEF VerboseFilenameIsMatching}
  1603. debugln([' Check } Mask="',MaskP,'" FileP="',FileP,'"']);
  1604. {$ENDIF}
  1605. inc(MaskP);
  1606. end;
  1607. ',':
  1608. begin
  1609. // OR option fits => continue behind the {}
  1610. {$IFDEF VerboseFilenameIsMatching}
  1611. debugln([' Check Skipping to end of {} Mask="',MaskP,'" ...']);
  1612. {$ENDIF}
  1613. Level:=1;
  1614. repeat
  1615. inc(MaskP);
  1616. case MaskP^ of
  1617. #0: exit;
  1618. SpecialChar:
  1619. begin
  1620. inc(MaskP);
  1621. if MaskP^=#0 then exit;
  1622. inc(MaskP);
  1623. end;
  1624. '{': inc(Level);
  1625. '}':
  1626. begin
  1627. dec(Level);
  1628. if Level=0 then break;
  1629. end;
  1630. end;
  1631. until false;
  1632. {$IFDEF VerboseFilenameIsMatching}
  1633. debugln([' Check Skipped to end of {} Mask="',MaskP,'"']);
  1634. {$ENDIF}
  1635. inc(MaskP);
  1636. end;
  1637. #128..#255:
  1638. begin
  1639. // match UTF-8 characters
  1640. {$IFDEF VerboseFilenameIsMatching}
  1641. debugln([' Check UTF-8 chars Mask="',MaskP,'" FileP="',FileP,'"']);
  1642. {$ENDIF}
  1643. MaskStart:=MaskP;
  1644. FileStart:=FileP;
  1645. while not (MaskP^ in [#0,SpecialChar,PathDelim,'?','*','{',',','}']) do
  1646. begin
  1647. if FileP^ in [#0,PathDelim] then exit;
  1648. inc(MaskP,LazUTF8.UTF8CharacterLength(MaskP));
  1649. inc(FileP,LazUTF8.UTF8CharacterLength(FileP));
  1650. end;
  1651. if LazFileUtils.CompareFilenames(MaskStart,MaskP-MaskStart,FileStart,FileP-FileStart)<>0 then
  1652. exit;
  1653. end;
  1654. else
  1655. // match ASCII characters
  1656. repeat
  1657. case MaskP^ of
  1658. #0,SpecialChar,PathDelim,'?','*','{',',','}': break;
  1659. {$IFDEF CaseInsensitiveFilenames}
  1660. 'a'..'z','A'..'Z':
  1661. if FPUpChars[MaskP^]<>FPUpChars[FileP^] then exit;
  1662. {$ENDIF}
  1663. else
  1664. if MaskP^<>FileP^ then exit;
  1665. end;
  1666. inc(MaskP);
  1667. inc(FileP);
  1668. until false;
  1669. end;
  1670. until false;
  1671. end;
  1672. begin
  1673. if Filename='' then exit(false);
  1674. if Mask='' then exit(true);
  1675. {$IFDEF VerboseFilenameIsMatching}
  1676. debugln(['FilenameIsMatching2 Mask="',Mask,'" File="',Filename,'" Exactly=',MatchExactly]);
  1677. {$ENDIF}
  1678. Result:=Check(PChar(Mask),PChar(Filename));
  1679. end;
  1680. function FindNextDirectoryInFilename(const Filename: string;
  1681. var Position: integer): string;
  1682. { for example:
  1683. Unix:
  1684. '/a/b' -> returns first 'a', then 'b'
  1685. '/a/' -> returns 'a', then ''
  1686. '/a//' -> returns 'a', then '', then ''
  1687. 'a/b.pas' -> returns first 'a', then 'b.pas'
  1688. Windows
  1689. 'C:\a\b.pas' -> returns first 'C:\', then 'a', then 'b.pas'
  1690. 'C:\a\' -> returns first 'C:\', then 'a', then ''
  1691. 'C:\a\\' -> returns first 'C:\', then 'a', then '', then ''
  1692. }
  1693. var
  1694. StartPos: Integer;
  1695. begin
  1696. if Position>length(Filename) then exit('');
  1697. {$IFDEF Windows}
  1698. if Position=1 then begin
  1699. Result := ExtractUNCVolume(Filename);
  1700. if Result<>'' then begin
  1701. // is it like \\?\C:\Directory? then also include the "C:\" part
  1702. if (Result = '\\?\') and (Length(FileName) > 6) and
  1703. (FileName[5] in ['a'..'z','A'..'Z']) and (FileName[6] = ':') and (FileName[7] = PathDelim)
  1704. then
  1705. Result := Copy(FileName, 1, 7);
  1706. Position:=length(Result)+1;
  1707. exit;
  1708. end;
  1709. end;
  1710. {$ENDIF}
  1711. if Filename[Position]=PathDelim then
  1712. inc(Position);
  1713. StartPos:=Position;
  1714. while (Position<=length(Filename)) and (Filename[Position]<>PathDelim) do
  1715. inc(Position);
  1716. Result:=copy(Filename,StartPos,Position-StartPos);
  1717. end;
  1718. function AVLTreeHasDoubles(Tree: TAVLTree): TAVLTreeNode;
  1719. var
  1720. Next: TAVLTreeNode;
  1721. begin
  1722. if Tree=nil then exit(nil);
  1723. Result:=Tree.FindLowest;
  1724. while Result<>nil do begin
  1725. Next:=Tree.FindSuccessor(Result);
  1726. if (Next<>nil) and (Tree.OnCompare(Result.Data,Next.Data)=0) then exit;
  1727. Result:=Next;
  1728. end;
  1729. end;
  1730. function DateToCfgStr(const Date: TDateTime; const aFormat: string): string;
  1731. var
  1732. NeedDate: Boolean;
  1733. NeedTime: Boolean;
  1734. Year: word;
  1735. Month: word;
  1736. Day: word;
  1737. Hour: word;
  1738. Minute: word;
  1739. Second: word;
  1740. MilliSecond: word;
  1741. p: Integer;
  1742. w: Word;
  1743. StartP: Integer;
  1744. s: String;
  1745. l: Integer;
  1746. begin
  1747. Result:=aFormat;
  1748. NeedDate:=false;
  1749. NeedTime:=false;
  1750. for p:=1 to length(aFormat) do
  1751. case aFormat[p] of
  1752. 'Y','M','D': NeedDate:=true;
  1753. 'H','N','S','Z': NeedTime:=true;
  1754. end;
  1755. if NeedDate then
  1756. DecodeDate(Date,Year,Month,Day);
  1757. if NeedTime then
  1758. DecodeTime(Date,Hour,Minute,Second,MilliSecond);
  1759. p:=1;
  1760. while p<=length(aFormat) do begin
  1761. case aFormat[p] of
  1762. 'Y': w:=Year;
  1763. 'M': w:=Month;
  1764. 'D': w:=Day;
  1765. 'H': w:=Hour;
  1766. 'N': w:=Minute;
  1767. 'S': w:=Second;
  1768. 'Z': w:=MilliSecond;
  1769. else
  1770. inc(p);
  1771. continue;
  1772. end;
  1773. StartP:=p;
  1774. repeat
  1775. inc(p);
  1776. until (p>length(aFormat)) or (aFormat[p]<>aFormat[p-1]);
  1777. l:=p-StartP;
  1778. s:=IntToStr(w);
  1779. if length(s)<l then
  1780. s:=StringOfChar('0',l-length(s))+s
  1781. else if length(s)>l then
  1782. raise Exception.Create('date format does not fit');
  1783. ReplaceSubstring(Result,StartP,l,s);
  1784. p:=StartP+length(s);
  1785. end;
  1786. //debugln('DateToCfgStr "',Result,'"');
  1787. end;
  1788. function CfgStrToDate(const s: string; out Date: TDateTime;
  1789. const aFormat: string): boolean;
  1790. procedure AddDecimal(var d: word; c: char); inline;
  1791. begin
  1792. d:=d*10+ord(c)-ord('0');
  1793. end;
  1794. var
  1795. i: Integer;
  1796. Year, Month, Day, Hour, Minute, Second, MilliSecond: word;
  1797. begin
  1798. //debugln('CfgStrToDate "',s,'"');
  1799. if length(s)<>length(aFormat) then begin
  1800. Date:=0.0;
  1801. exit(false);
  1802. end;
  1803. try
  1804. Year:=0;
  1805. Month:=0;
  1806. Day:=0;
  1807. Hour:=0;
  1808. Minute:=0;
  1809. Second:=0;
  1810. MilliSecond:=0;
  1811. for i:=1 to length(aFormat) do begin
  1812. case aFormat[i] of
  1813. 'Y': AddDecimal(Year,s[i]);
  1814. 'M': AddDecimal(Month,s[i]);
  1815. 'D': AddDecimal(Day,s[i]);
  1816. 'H': AddDecimal(Hour,s[i]);
  1817. 'N': AddDecimal(Minute,s[i]);
  1818. 'S': AddDecimal(Second,s[i]);
  1819. 'Z': AddDecimal(MilliSecond,s[i]);
  1820. end;
  1821. end;
  1822. Date:=ComposeDateTime(EncodeDate(Year,Month,Day),EncodeTime(Hour,Minute,Second,MilliSecond));
  1823. Result:=true;
  1824. except
  1825. Result:=false;
  1826. end;
  1827. end;
  1828. procedure DebugLn(Args: array of const);
  1829. begin
  1830. LazLogger.Debugln(Args);
  1831. end;
  1832. procedure DebugLn(const S: String; Args: array of const);
  1833. begin
  1834. LazLogger.DebugLn(Format(S, Args));
  1835. end;
  1836. procedure DebugLn;
  1837. begin
  1838. LazLogger.DebugLn('');
  1839. end;
  1840. procedure DebugLn(const s: string);
  1841. begin
  1842. LazLogger.Debugln(s);
  1843. end;
  1844. procedure DebugLn(const s1, s2: string);
  1845. begin
  1846. LazLogger.Debugln(s1,s2);
  1847. end;
  1848. procedure DebugLn(const s1, s2, s3: string);
  1849. begin
  1850. LazLogger.Debugln(s1,s2,s3);
  1851. end;
  1852. procedure DebugLn(const s1, s2, s3, s4: string);
  1853. begin
  1854. LazLogger.Debugln(s1,s2,s3,s4);
  1855. end;
  1856. procedure DebugLn(const s1, s2, s3, s4, s5: string);
  1857. begin
  1858. LazLogger.Debugln(s1,s2,s3,s4,s5);
  1859. end;
  1860. procedure DebugLn(const s1, s2, s3, s4, s5, s6: string);
  1861. begin
  1862. LazLogger.Debugln(s1,s2,s3,s4,s5,s6);
  1863. end;
  1864. procedure DebugLn(const s1, s2, s3, s4, s5, s6, s7: string);
  1865. begin
  1866. LazLogger.Debugln(s1,s2,s3,s4,s5,s6,s7);
  1867. end;
  1868. procedure DebugLn(const s1, s2, s3, s4, s5, s6, s7, s8: string);
  1869. begin
  1870. LazLogger.Debugln(s1,s2,s3,s4,s5,s6,s7,s8);
  1871. end;
  1872. procedure DebugLn(const s1, s2, s3, s4, s5, s6, s7, s8, s9: string);
  1873. begin
  1874. LazLogger.Debugln(s1,s2,s3,s4,s5,s6,s7,s8,s9);
  1875. end;
  1876. procedure DebugLn(const s1, s2, s3, s4, s5, s6, s7, s8, s9, s10: string);
  1877. begin
  1878. LazLogger.Debugln(s1,s2,s3,s4,s5,s6,s7,s8,s9,s10);
  1879. end;
  1880. procedure DebugLn(const s1, s2, s3, s4, s5, s6, s7, s8, s9, s10, s11: string);
  1881. begin
  1882. LazLogger.Debugln(s1,s2,s3,s4,s5,s6,s7,s8,s9,s10,s11);
  1883. end;
  1884. procedure DebugLn(const s1, s2, s3, s4, s5, s6, s7, s8, s9, s10, s11,
  1885. s12: string);
  1886. begin
  1887. LazLogger.Debugln(s1,s2,s3,s4,s5,s6,s7,s8,s9,s10,s11,s12);
  1888. end;
  1889. procedure DbgOut(Args: array of const);
  1890. begin
  1891. LazLogger.DbgOut(dbgs(Args));
  1892. end;
  1893. procedure DbgOut(const s: string);
  1894. begin
  1895. LazLogger.DbgOut(s);
  1896. end;
  1897. procedure DbgOut(const s1, s2: string);
  1898. begin
  1899. LazLogger.DbgOut(s1,s2);
  1900. end;
  1901. procedure DbgOut(const s1, s2, s3: string);
  1902. begin
  1903. LazLogger.DbgOut(s1,s2,s3);
  1904. end;
  1905. procedure DbgOut(const s1, s2, s3, s4: string);
  1906. begin
  1907. LazLogger.DbgOut(s1,s2,s3,s4);
  1908. end;
  1909. procedure DbgOut(const s1, s2, s3, s4, s5: string);
  1910. begin
  1911. LazLogger.DbgOut(s1,s2,s3,s4,s5);
  1912. end;
  1913. procedure DbgOut(const s1, s2, s3, s4, s5, s6: string);
  1914. begin
  1915. LazLogger.DbgOut(s1,s2,s3,s4,s5,s6);
  1916. end;
  1917. function DbgS(Args: array of const): string;
  1918. var
  1919. i: Integer;
  1920. begin
  1921. Result:='';
  1922. for i:=Low(Args) to High(Args) do begin
  1923. case Args[i].VType of
  1924. vtInteger: Result:=Result+dbgs(Args[i].vinteger);
  1925. vtInt64: Result:=Result+dbgs(Args[i].VInt64^);
  1926. vtQWord: Result:=Result+dbgs(Args[i].VQWord^);
  1927. vtBoolean: Result:=Result+dbgs(Args[i].vboolean);
  1928. vtExtended: Result:=Result+dbgs(Args[i].VExtended^);
  1929. {$ifdef FPC_CURRENCY_IS_INT64}
  1930. // MWE:
  1931. // fpc 2.x has troubles in choosing the right dbgs()
  1932. // so we convert here
  1933. vtCurrency: Result:=Result+dbgs(int64(Args[i].vCurrency^)/10000 , 4);
  1934. {$else}
  1935. vtCurrency: Result:=Result+dbgs(Args[i].vCurrency^);
  1936. {$endif}
  1937. vtString: Result:=Result+Args[i].VString^;
  1938. vtAnsiString: Result:=Result+AnsiString(Args[i].VAnsiString);
  1939. vtChar: Result:=Result+Args[i].VChar;
  1940. vtPChar: Result:=Result+Args[i].VPChar;
  1941. vtPWideChar: Result:=Result+UnicodeToUTF8(ord(Args[i].VPWideChar^));
  1942. vtWideChar: Result:=Result+UnicodeToUTF8(ord(Args[i].VWideChar));
  1943. vtWidestring: Result:=Result+UTF8Encode(WideString(Args[i].VWideString));
  1944. vtObject: Result:=Result+DbgSName(Args[i].VObject);
  1945. vtClass: Result:=Result+DbgSName(Args[i].VClass);
  1946. vtPointer: Result:=Result+Dbgs(Args[i].VPointer);
  1947. else
  1948. Result:=Result+'?unknown variant?';
  1949. end;
  1950. end;
  1951. end;
  1952. function DbgS(const c: char): string;
  1953. begin
  1954. case c of
  1955. ' '..#126: Result:=c;
  1956. else
  1957. Result:='#'+IntToStr(ord(c));
  1958. end;
  1959. end;
  1960. function DbgS(const c: cardinal): string;
  1961. begin
  1962. Result:=LazLogger.DbgS(c);
  1963. end;
  1964. function DbgS(const i: integer): string;
  1965. begin
  1966. Result:=LazLogger.DbgS(i);
  1967. end;
  1968. function DbgS(const i: QWord): string;
  1969. begin
  1970. Result:=LazLogger.DbgS(i);
  1971. end;
  1972. function DbgS(const i: int64): string;
  1973. begin
  1974. Result:=LazLogger.DbgS(i);
  1975. end;
  1976. function DbgS(const r: TRect): string;
  1977. begin
  1978. Result:=LazLogger.DbgS(r);
  1979. end;
  1980. function DbgS(const p: TPoint): string;
  1981. begin
  1982. Result:=LazLogger.DbgS(p);
  1983. end;
  1984. function DbgS(const p: pointer): string;
  1985. begin
  1986. Result:=LazLogger.DbgS(p);
  1987. end;
  1988. function DbgS(const e: extended; MaxDecimals: integer = 999): string;
  1989. begin
  1990. Result:=LazLogger.DbgS(e,MaxDecimals);
  1991. end;
  1992. function DbgS(const b: boolean): string;
  1993. begin
  1994. Result:=LazLogger.DbgS(b);
  1995. end;
  1996. function DbgS(const i1, i2, i3, i4: integer): string;
  1997. begin
  1998. Result:=LazLogger.DbgS(i1,i2,i3,i4);
  1999. end;
  2000. function DbgS(const ms: TCustomMemoryStream; Count: PtrInt): string;
  2001. begin
  2002. Result:=dbgMemStream(ms,Count);
  2003. end;
  2004. function DbgSName(const p: TObject): string;
  2005. begin
  2006. Result:=LazLogger.DbgSName(p);
  2007. end;
  2008. function DbgSName(const p: TClass): string;
  2009. begin
  2010. Result:=LazLogger.DbgSName(p);
  2011. end;
  2012. function dbgMemRange(P: PByte; Count: integer; Width: integer): string;
  2013. begin
  2014. Result:=LazLogger.dbgMemRange(P,Count,Width);
  2015. end;
  2016. function DbgStr(const StringWithSpecialChars: string): string;
  2017. var
  2018. i: Integer;
  2019. s: String;
  2020. begin
  2021. Result:=StringWithSpecialChars;
  2022. i:=length(Result);
  2023. while (i>0) do begin
  2024. case Result[i] of
  2025. ' '..#126: ;
  2026. else
  2027. s:='#'+IntToStr(ord(Result[i]));
  2028. ReplaceSubstring(Result,i,1,s);
  2029. end;
  2030. dec(i);
  2031. end;
  2032. end;
  2033. function DbgStr(const StringWithSpecialChars: string; StartPos, Len: PtrInt): string;
  2034. begin
  2035. Result:=dbgstr(copy(StringWithSpecialChars,StartPos,Len));
  2036. end;
  2037. function DbgText(const StringWithSpecialChars: string; KeepLines: boolean): string;
  2038. var
  2039. i: Integer;
  2040. s: String;
  2041. c: Char;
  2042. l: Integer;
  2043. begin
  2044. Result:=StringWithSpecialChars;
  2045. i:=1;
  2046. while (i<=length(Result)) do begin
  2047. c:=Result[i];
  2048. case c of
  2049. ' '..#126: inc(i);
  2050. else
  2051. if KeepLines and (c in [#10,#13]) then begin
  2052. // replace line ending with system line ending
  2053. if (i<length(Result)) and (Result[i+1] in [#10,#13])
  2054. and (c<>Result[i+1]) then
  2055. l:=2
  2056. else
  2057. l:=1;
  2058. ReplaceSubstring(Result,i,l,LineEnding);
  2059. inc(i,length(LineEnding));
  2060. end else begin
  2061. s:='#'+IntToStr(ord(c));
  2062. ReplaceSubstring(Result,i,1,s);
  2063. inc(i,length(s));
  2064. end;
  2065. end;
  2066. end;
  2067. end;
  2068. function CompareCTMemStat(Stat1, Stat2: TCTMemStat): integer;
  2069. begin
  2070. Result:=SysUtils.CompareText(Stat1.Name,Stat2.Name);
  2071. end;
  2072. function CompareNameWithCTMemStat(KeyAnsiString: Pointer; Stat: TCTMemStat): integer;
  2073. begin
  2074. Result:=SysUtils.CompareText(AnsiString(KeyAnsiString),Stat.Name);
  2075. end;
  2076. function GetTicks: int64;
  2077. var
  2078. CurTick: Int64;
  2079. begin
  2080. CurTick:=round(Now*86400000);
  2081. Result:=CurTick-LastTick;
  2082. LastTick:=CurTick;
  2083. end;
  2084. procedure CTDumpStack;
  2085. begin
  2086. DebugLn(CTGetStackTrace(true));
  2087. end;
  2088. function CTGetStackTrace(UseCache: boolean): string;
  2089. var
  2090. bp: Pointer;
  2091. addr: Pointer;
  2092. oldbp: Pointer;
  2093. CurAddress: Shortstring;
  2094. begin
  2095. Result:='';
  2096. { retrieve backtrace info }
  2097. bp:=get_caller_frame(get_frame);
  2098. while bp<>nil do begin
  2099. addr:=get_caller_addr(bp);
  2100. CurAddress:=CTGetLineInfo(addr,UseCache);
  2101. //DebugLn('GetStackTrace ',CurAddress);
  2102. Result:=Result+CurAddress+LineEnding;
  2103. oldbp:=bp;
  2104. bp:=get_caller_frame(bp);
  2105. if (bp<=oldbp) or (bp>(StackBottom + StackLength)) then
  2106. bp:=nil;
  2107. end;
  2108. end;
  2109. procedure CTGetStackTracePointers(var AStack: TCTStackTracePointers);
  2110. var
  2111. Depth: Integer;
  2112. bp: Pointer;
  2113. oldbp: Pointer;
  2114. begin
  2115. // get stack depth
  2116. Depth:=0;
  2117. bp:=get_caller_frame(get_frame);
  2118. while bp<>nil do begin
  2119. inc(Depth);
  2120. oldbp:=bp;
  2121. bp:=get_caller_frame(bp);
  2122. if (bp<=oldbp) or (bp>(StackBottom + StackLength)) then
  2123. bp:=nil;
  2124. end;
  2125. SetLength(AStack,Depth);
  2126. if Depth>0 then begin
  2127. Depth:=0;
  2128. bp:=get_caller_frame(get_frame);
  2129. while bp<>nil do begin
  2130. AStack[Depth]:=get_caller_addr(bp);
  2131. inc(Depth);
  2132. oldbp:=bp;
  2133. bp:=get_caller_frame(bp);
  2134. if (bp<=oldbp) or (bp>(StackBottom + StackLength)) then
  2135. bp:=nil;
  2136. end;
  2137. end;
  2138. end;
  2139. function CTStackTraceAsString(const AStack: TCTStackTracePointers; UseCache: boolean
  2140. ): string;
  2141. var
  2142. i: Integer;
  2143. CurAddress: String;
  2144. begin
  2145. Result:='';
  2146. for i:=0 to length(AStack)-1 do begin
  2147. CurAddress:=CTGetLineInfo(AStack[i],UseCache);
  2148. Result:=Result+CurAddress+LineEnding;
  2149. end;
  2150. end;
  2151. function CTGetLineInfo(Addr: Pointer; UseCache: boolean): string;
  2152. var
  2153. ANode: TAVLTreeNode;
  2154. Item: PCTLineInfoCacheItem;
  2155. begin
  2156. if UseCache then begin
  2157. if LineInfoCache=nil then
  2158. LineInfoCache:=TAVLTree.Create(@CompareCTLineInfoCacheItems);
  2159. ANode:=LineInfoCache.FindKey(Addr,@CompareAddrWithCTLineInfoCacheItem);
  2160. if ANode=nil then begin
  2161. Result:=BackTraceStrFunc(Addr);
  2162. New(Item);
  2163. Item^.Addr:=Addr;
  2164. Item^.Info:=Result;
  2165. LineInfoCache.Add(Item);
  2166. end else begin
  2167. Result:=PCTLineInfoCacheItem(ANode.Data)^.Info;
  2168. end;
  2169. end else
  2170. Result:=BackTraceStrFunc(Addr);
  2171. end;
  2172. function CompareCTLineInfoCacheItems(Data1, Data2: Pointer): integer;
  2173. begin
  2174. Result:=LazUtilities.ComparePointers(PCTLineInfoCacheItem(Data1)^.Addr,
  2175. PCTLineInfoCacheItem(Data2)^.Addr);
  2176. end;
  2177. function CompareAddrWithCTLineInfoCacheItem(Addr, Item: Pointer): integer;
  2178. begin
  2179. Result:=LazUtilities.ComparePointers(Addr,PCTLineInfoCacheItem(Item)^.Addr);
  2180. end;
  2181. function FileAgeToStr(aFileAge: longint): string;
  2182. begin
  2183. Result:=DateTimeToStr(FileDateToDateTimeDef(aFileAge));
  2184. end;
  2185. //------------------------------------------------------------------------------
  2186. procedure FreeLineInfoCache;
  2187. var
  2188. ANode: TAVLTreeNode;
  2189. Item: PCTLineInfoCacheItem;
  2190. begin
  2191. if LineInfoCache=nil then exit;
  2192. ANode:=LineInfoCache.FindLowest;
  2193. while ANode<>nil do begin
  2194. Item:=PCTLineInfoCacheItem(ANode.Data);
  2195. Dispose(Item);
  2196. ANode:=LineInfoCache.FindSuccessor(ANode);
  2197. end;
  2198. LineInfoCache.Free;
  2199. LineInfoCache:=nil;
  2200. end;
  2201. { TCTMemStats }
  2202. function TCTMemStats.GetItems(const Name: string): PtrUint;
  2203. var
  2204. Node: TAVLTreeNode;
  2205. begin
  2206. Node:=Tree.FindKey(Pointer(Name),TListSortCompare(@CompareNameWithCTMemStat));
  2207. if Node<>nil then
  2208. Result:=TCTMemStat(Node.Data).Sum
  2209. else
  2210. Result:=0;
  2211. end;
  2212. procedure TCTMemStats.SetItems(const Name: string; const AValue: PtrUint);
  2213. var
  2214. Node: TAVLTreeNode;
  2215. NewStat: TCTMemStat;
  2216. begin
  2217. Node:=Tree.FindKey(Pointer(Name),TListSortCompare(@CompareNameWithCTMemStat));
  2218. if Node<>nil then begin
  2219. if AValue<>0 then begin
  2220. TCTMemStat(Node.Data).Sum:=AValue;
  2221. end else begin
  2222. Tree.FreeAndDelete(Node);
  2223. end;
  2224. end else begin
  2225. if AValue<>0 then begin
  2226. NewStat:=TCTMemStat.Create;
  2227. NewStat.Name:=Name;
  2228. NewStat.Sum:=AValue;
  2229. Tree.Add(NewStat);
  2230. end;
  2231. end;
  2232. end;
  2233. constructor TCTMemStats.Create;
  2234. begin
  2235. Tree:=TAVLTree.Create(TListSortCompare(@CompareCTMemStat));
  2236. end;
  2237. destructor TCTMemStats.Destroy;
  2238. begin
  2239. Tree.FreeAndClear;
  2240. FreeAndNil(Tree);
  2241. inherited Destroy;
  2242. end;
  2243. procedure TCTMemStats.Add(const Name: string; Size: PtrUint);
  2244. var
  2245. Node: TAVLTreeNode;
  2246. NewStat: TCTMemStat;
  2247. begin
  2248. inc(Total,Size);
  2249. Node:=Tree.FindKey(Pointer(Name),TListSortCompare(@CompareNameWithCTMemStat));
  2250. if Node<>nil then begin
  2251. inc(TCTMemStat(Node.Data).Sum,Size);
  2252. end else begin
  2253. NewStat:=TCTMemStat.Create;
  2254. NewStat.Name:=Name;
  2255. NewStat.Sum:=Size;
  2256. Tree.Add(NewStat);
  2257. end;
  2258. end;
  2259. procedure TCTMemStats.WriteReport;
  2260. function ByteToStr(b: PtrUint): string;
  2261. const
  2262. Units = 'KMGTPE';
  2263. var
  2264. i: Integer;
  2265. begin
  2266. i:=0;
  2267. while b>10240 do begin
  2268. inc(i);
  2269. b:=b shr 10;
  2270. end;
  2271. Result:=dbgs(b);
  2272. if i>0 then
  2273. Result:=Result+Units[i];
  2274. end;
  2275. var
  2276. Node: TAVLTreeNode;
  2277. CurStat: TCTMemStat;
  2278. begin
  2279. DebugLn(['TCTMemStats.WriteReport Stats=',Tree.Count,' Total=',Total,' ',ByteToStr(Total)]);
  2280. Node:=Tree.FindLowest;
  2281. while Node<>nil do begin
  2282. CurStat:=TCTMemStat(Node.Data);
  2283. DebugLn([' ',CurStat.Name,'=',CurStat.Sum,' ',ByteToStr(CurStat.Sum)]);
  2284. Node:=Tree.FindSuccessor(Node);
  2285. end;
  2286. end;
  2287. initialization
  2288. {$IFDEF MEM_CHECK}CheckHeapWrtMemCnt('fileprocs.pas: initialization');{$ENDIF}
  2289. FileStateCache:=TFileStateCache.Create;
  2290. finalization
  2291. FileStateCache.Free;
  2292. FileStateCache:=nil;
  2293. FreeLineInfoCache;
  2294. end.