1 {
2 ***************************************************************************
3 * *
4 * This source is free software; you can redistribute it and/or modify *
5 * it under the terms of the GNU General Public License as published by *
6 * the Free Software Foundation; either version 2 of the License, or *
7 * (at your option) any later version. *
8 * *
9 * This code is distributed in the hope that it will be useful, but *
10 * WITHOUT ANY WARRANTY; without even the implied warranty of *
11 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU *
12 * General Public License for more details. *
13 * *
14 * A copy of the GNU General Public License is available on the World *
15 * Wide Web at <http://www.gnu.org/copyleft/gpl.html>. You can also *
16 * obtain it by writing to the Free Software Foundation, *
17 * Inc., 51 Franklin Street - Fifth Floor, Boston, MA 02110-1335, USA. *
18 * *
19 ***************************************************************************
20
21 Author: Mattias Gaertner
22
23 Abstract:
24 - simple file functions and fpc additions
25 - all functions are thread safe unless explicitely stated
26 }
27 unit FileProcs;
28
29 {$mode objfpc}{$H+}
30
31 interface
32
33 {$I codetools.inc}
34
35 uses
36 {$IFDEF MEM_CHECK}
37 MemCheck,
38 {$ENDIF}
39 {$IFDEF Windows}
40 Windows,
41 {$ENDIF}
42 // RTL + FCL
43 Classes, SysUtils, Laz_AVL_Tree,
44 // CodeTools
45 CodeToolsStrConsts,
46 // LazUtils
47 LazUtilities, LazLoggerBase, LazFileCache, LazFileUtils, LazUTF8, LazUTF8Classes;
48
49 type
50 TFPCStreamSeekType = int64;
51 TFPCMemStreamSeekType = integer;
52 PCharZ = Pointer;
53
54 {$IF defined(Windows) or defined(darwin) or defined(HASAMIGA)}
55 {$define CaseInsensitiveFilenames}
56 {$ENDIF}
57 {$IF defined(CaseInsensitiveFilenames)}
58 {$define NotLiteralFilenames}
59 {$ENDIF}
60
61 const
62 FilenamesCaseSensitive = {$IFDEF CaseInsensitiveFilenames}false{$ELSE}true{$ENDIF};// lower and upper letters are treated the same
63 FilenamesLiteral = {$IFDEF NotLiteralFilenames}false{$ELSE}true{$ENDIF};// file names can be compared using = string operator
64
65 SpecialChar = '#'; // used to use PathDelim, e.g. #\
66 FileMask = AllFilesMask;
67 {$IFDEF Windows}
68 ExeExt = '.exe';
69 {$ELSE}
70 {$IFDEF NetWare}
71 ExeExt = '.nlm';
72 {$ELSE}
73 ExeExt = '';
74 {$ENDIF}
75 {$ENDIF}
76
77 type
78 TCTSearchFileCase = (
79 ctsfcDefault, // e.g. case insensitive on windows
80 ctsfcLoUpCase, // also search for lower and upper case
81 ctsfcAllCase // search case insensitive
82 );
83 TCTFileAgeTime = longint;
84 PCTFileAgeTime = ^TCTFileAgeTime;
85
86 // file operations
FileDateToDateTimeDefnull87 function FileDateToDateTimeDef(aFileDate: TCTFileAgeTime; const Default: TDateTime = 0): TDateTime;
FilenameIsMatchingnull88 function FilenameIsMatching(const Mask, Filename: string; MatchExactly: boolean): boolean;
FindNextDirectoryInFilenamenull89 function FindNextDirectoryInFilename(const Filename: string; var Position: integer): string;
90
ClearFilenull91 function ClearFile(const Filename: string; RaiseOnError: boolean): boolean;
GetTempFilenamenull92 function GetTempFilename(const Path, Prefix: string): string;
SearchFileInDirnull93 function SearchFileInDir(const Filename, BaseDirectory: string;
94 SearchCase: TCTSearchFileCase): string; // not thread-safe
SearchFileInPathnull95 function SearchFileInPath(const Filename, BasePath, SearchPath, Delimiter: string;
96 SearchCase: TCTSearchFileCase): string; overload; // not thread-safe
FindDiskFilenamenull97 function FindDiskFilename(const Filename: string): string;
98
99 const
100 CTInvalidChangeStamp = LUInvalidChangeStamp;
101 CTInvalidChangeStamp64 = LUInvalidChangeStamp64; // using a value outside integer to spot wrong types early
102
CompareAnsiStringFilenamesnull103 function CompareAnsiStringFilenames(Data1, Data2: Pointer): integer;
CompareFilenameOnlynull104 function CompareFilenameOnly(Filename: PChar; FilenameLen: integer;
105 NameOnly: PChar; NameOnlyLen: integer; CaseSensitive: boolean): integer;
106
107 // searching .pas, .pp, .p
FilenameIsPascalUnitnull108 function FilenameIsPascalUnit(const Filename: string;
109 CaseSensitive: boolean = false): boolean;
FilenameIsPascalUnitnull110 function FilenameIsPascalUnit(Filename: PChar; FilenameLen: integer;
111 CaseSensitive: boolean = false): boolean;
ExtractFileUnitnamenull112 function ExtractFileUnitname(Filename: string; WithNameSpace: boolean): string;
IsPascalUnitExtnull113 function IsPascalUnitExt(FileExt: PChar; CaseSensitive: boolean = false): boolean;
SearchPascalUnitInDirnull114 function SearchPascalUnitInDir(const AnUnitName, BaseDirectory: string;
115 SearchCase: TCTSearchFileCase): string;
SearchPascalUnitInPathnull116 function SearchPascalUnitInPath(const AnUnitName, BasePath, SearchPath,
117 Delimiter: string; SearchCase: TCTSearchFileCase): string;
118
119 // searching .ppu
SearchPascalFileInDirnull120 function SearchPascalFileInDir(const ShortFilename, BaseDirectory: string;
121 SearchCase: TCTSearchFileCase): string;
SearchPascalFileInPathnull122 function SearchPascalFileInPath(const ShortFilename, BasePath, SearchPath,
123 Delimiter: string; SearchCase: TCTSearchFileCase): string;
124
ReadNextFPCParameternull125 function ReadNextFPCParameter(const CmdLine: string; var Position: integer;
126 out StartPos: integer): boolean;
ExtractFPCParameternull127 function ExtractFPCParameter(const CmdLine: string; StartPos: integer): string;
FindNextFPCParameternull128 function FindNextFPCParameter(const CmdLine, BeginsWith: string; var Position: integer): integer;
GetLastFPCParameternull129 function GetLastFPCParameter(const CmdLine, BeginsWith: string; CutBegins: boolean = true): string;
GetFPCParameterSrcFilenull130 function GetFPCParameterSrcFile(const CmdLine: string): string;
131
132 type
133 TCTPascalExtType = (petNone, petPAS, petPP, petP);
134
135 const
136 CTPascalExtension: array[TCTPascalExtType] of string =
137 ('', '.pas', '.pp', '.p');
138
139 // store date locale independent, thread safe
140 const DateAsCfgStrFormat='YYYYMMDD';
141 const DateTimeAsCfgStrFormat='YYYY/MM/DD HH:NN:SS';
DateToCfgStrnull142 function DateToCfgStr(const Date: TDateTime; const aFormat: string = DateAsCfgStrFormat): string;
CfgStrToDatenull143 function CfgStrToDate(const s: string; out Date: TDateTime; const aFormat: string = DateAsCfgStrFormat): boolean;
144
145 procedure CTIncreaseChangeStamp(var ChangeStamp: integer); inline;
146 procedure CTIncreaseChangeStamp64(var ChangeStamp: int64); inline;
SimpleFormatnull147 function SimpleFormat(const Fmt: String; const Args: Array of const): String;
148
149 // misc
FileAgeToStrnull150 function FileAgeToStr(aFileAge: longint): string;
AVLTreeHasDoublesnull151 function AVLTreeHasDoubles(Tree: TAVLTree): TAVLTreeNode;
152
153 // debugging
154 var
155 CTConsoleVerbosity: integer = {$IFDEF VerboseCodetools}1{$ELSE}0{$ENDIF}; // 0=quiet, 1=normal, 2=verbose
156
157 procedure RaiseCatchableException(const Msg: string);
158 procedure RaiseAndCatchException;
159
160 procedure DebugLn(Args: array of const);
161 procedure DebugLn(const S: String; Args: array of const);// similar to Format(s,Args)
162 procedure DebugLn; inline;
163 procedure DebugLn(const s: string); inline;
164 procedure DebugLn(const s1,s2: string); inline;
165 procedure DebugLn(const s1,s2,s3: string); inline;
166 procedure DebugLn(const s1,s2,s3,s4: string); inline;
167 procedure DebugLn(const s1,s2,s3,s4,s5: string); inline;
168 procedure DebugLn(const s1,s2,s3,s4,s5,s6: string); inline;
169 procedure DebugLn(const s1,s2,s3,s4,s5,s6,s7: string); inline;
170 procedure DebugLn(const s1,s2,s3,s4,s5,s6,s7,s8: string); inline;
171 procedure DebugLn(const s1,s2,s3,s4,s5,s6,s7,s8,s9: string); inline;
172 procedure DebugLn(const s1,s2,s3,s4,s5,s6,s7,s8,s9,s10: string); inline;
173 procedure DebugLn(const s1,s2,s3,s4,s5,s6,s7,s8,s9,s10,s11: string); inline;
174 procedure DebugLn(const s1,s2,s3,s4,s5,s6,s7,s8,s9,s10,s11,s12: string); inline;
175
176 procedure DbgOut(Args: array of const);
177 procedure DbgOut(const s: string); inline;
178 procedure DbgOut(const s1,s2: string); inline;
179 procedure DbgOut(const s1,s2,s3: string); inline;
180 procedure DbgOut(const s1,s2,s3,s4: string); inline;
181 procedure DbgOut(const s1,s2,s3,s4,s5: string); inline;
182 procedure DbgOut(const s1,s2,s3,s4,s5,s6: string); inline;
183
DbgSnull184 function DbgS(Args: array of const): string; overload;
DbgSnull185 function DbgS(const c: char): string; overload;
DbgSnull186 function DbgS(const c: cardinal): string; inline; overload;
DbgSnull187 function DbgS(const i: integer): string; inline; overload;
DbgSnull188 function DbgS(const i: QWord): string; inline; overload;
DbgSnull189 function DbgS(const i: int64): string; inline; overload;
DbgSnull190 function DbgS(const r: TRect): string; inline; overload;
DbgSnull191 function DbgS(const p: TPoint): string; inline; overload;
DbgSnull192 function DbgS(const p: pointer): string; inline; overload;
DbgSnull193 function DbgS(const e: extended; MaxDecimals: integer = 999): string; overload; inline;
DbgSnull194 function DbgS(const b: boolean): string; overload; inline;
DbgSnull195 function DbgS(const ms: TCustomMemoryStream; Count: PtrInt = -1): string; inline; overload;
DbgSNamenull196 function DbgSName(const p: TObject): string; overload; inline;
DbgSNamenull197 function DbgSName(const p: TClass): string; overload; inline;
dbgMemRangenull198 function dbgMemRange(P: PByte; Count: integer; Width: integer = 0): string; inline;
199
DbgSnull200 function DbgS(const i1,i2,i3,i4: integer): string; overload; inline;
DbgStrnull201 function DbgStr(const StringWithSpecialChars: string): string; overload;
DbgStrnull202 function DbgStr(const StringWithSpecialChars: string; StartPos, Len: PtrInt): string; overload;
DbgTextnull203 function DbgText(const StringWithSpecialChars: string;
204 KeepLines: boolean = true // true = add LineEnding for each line break
205 ): string; overload;
206
207 type
208 TCTMemStat = class
209 public
210 Name: string;
211 Sum: PtrUint;
212 end;
213
214 { TCTMemStats }
215
216 TCTMemStats = class
217 private
GetItemsnull218 function GetItems(const Name: string): PtrUint;
219 procedure SetItems(const Name: string; const AValue: PtrUint);
220 public
221 Tree: TAVLTree; // tree of TCTMemStat sorted for Name with CompareText
222 Total: PtrUInt;
223 constructor Create;
224 destructor Destroy; override;
225 property Items[const Name: string]: PtrUint read GetItems write SetItems; default;
226 procedure Add(const Name: string; Size: PtrUint);
227 procedure WriteReport;
228 end;
229
CompareCTMemStatnull230 function CompareCTMemStat(Stat1, Stat2: TCTMemStat): integer;
CompareNameWithCTMemStatnull231 function CompareNameWithCTMemStat(KeyAnsiString: Pointer; Stat: TCTMemStat): integer;
232
GetTicksnull233 function GetTicks: int64; // not thread-safe
234
235 type
236 TCTStackTracePointers = array of Pointer;
237 TCTLineInfoCacheItem = record
238 Addr: Pointer;
239 Info: string;
240 end;
241 PCTLineInfoCacheItem = ^TCTLineInfoCacheItem;
242
243 procedure CTDumpStack;
CTGetStackTracenull244 function CTGetStackTrace(UseCache: boolean): string;
245 procedure CTGetStackTracePointers(var AStack: TCTStackTracePointers);
CTStackTraceAsStringnull246 function CTStackTraceAsString(const AStack: TCTStackTracePointers;
247 UseCache: boolean): string;
CTGetLineInfonull248 function CTGetLineInfo(Addr: Pointer; UseCache: boolean): string; // not thread safe
CompareCTLineInfoCacheItemsnull249 function CompareCTLineInfoCacheItems(Data1, Data2: Pointer): integer;
CompareAddrWithCTLineInfoCacheItemnull250 function CompareAddrWithCTLineInfoCacheItem(Addr, Item: Pointer): integer;
251
252
253 implementation
254
255 // to get more detailed error messages consider the os
256 {$IF not (defined(Windows) or defined(HASAMIGA))}
257 uses
258 Unix;
259 {$ENDIF}
260
261 procedure CTIncreaseChangeStamp(var ChangeStamp: integer);
262 begin
263 LazFileCache.LUIncreaseChangeStamp(ChangeStamp);
264 end;
265
266 procedure CTIncreaseChangeStamp64(var ChangeStamp: int64);
267 begin
268 LazFileCache.LUIncreaseChangeStamp64(ChangeStamp);
269 end;
270
SimpleFormatnull271 function SimpleFormat(const Fmt: String; const Args: array of const): String;
272 var
273 Used: array of boolean;
274 p: Integer;
275 StartPos: Integer;
276
277 procedure ReplaceArg(i: integer; var s: string);
278 var
279 Arg: String;
280 begin
281 if (i<Low(Args)) or (i>High(Args)) then exit;
282 case Args[i].VType of
283 vtInteger: Arg:=dbgs(Args[i].vinteger);
284 vtInt64: Arg:=dbgs(Args[i].VInt64^);
285 vtQWord: Arg:=dbgs(Args[i].VQWord^);
286 vtBoolean: Arg:=dbgs(Args[i].vboolean);
287 vtExtended: Arg:=dbgs(Args[i].VExtended^);
288 vtString: Arg:=Args[i].VString^;
289 vtAnsiString: Arg:=AnsiString(Args[i].VAnsiString);
290 vtChar: Arg:=Args[i].VChar;
291 vtPChar: Arg:=Args[i].VPChar;
292 else exit;
293 end;
294 Used[i]:=true;
295 ReplaceSubstring(s,StartPos,p-StartPos,Arg);
296 p:=StartPos+length(Arg);
297 end;
298
299 var
300 RunIndex: Integer;
301 FixedIndex: Integer;
302 begin
303 Result:=Fmt;
304 if Low(Args)>High(Args) then exit;
305 SetLength(Used,High(Args)-Low(Args)+1);
306 for RunIndex:=Low(Args) to High(Args) do
307 Used[RunIndex]:=false;
308 RunIndex:=Low(Args);
309 p:=1;
310 while p<=length(Result) do
311 begin
312 if Result[p]='%' then
313 begin
314 StartPos:=p;
315 inc(p);
316 case Result[p] of
317 's':
318 begin
319 inc(p);
320 ReplaceArg(RunIndex,Result);
321 inc(RunIndex);
322 end;
323 '0'..'9':
324 begin
325 FixedIndex:=0;
326 while (p<=length(Result)) and (Result[p] in ['0'..'9']) do
327 begin
328 if FixedIndex<High(Args) then
329 FixedIndex:=FixedIndex*10+ord(Result[p])-ord('0');
330 inc(p);
331 end;
332 if (p<=length(Result)) and (Result[p]=':') then
333 begin
334 inc(p);
335 if (p<=length(Result)) and (Result[p]='s') then
336 inc(p);
337 end;
338 ReplaceArg(FixedIndex,Result);
339 end;
340 else
341 inc(p);
342 end;
343 end else
344 inc(p);
345 end;
346
347 // append all missing arguments
348 for RunIndex:=Low(Args) to High(Args) do
349 begin
350 if Used[RunIndex] then continue;
351 Result+=',';
352 StartPos:=length(Result)+1;
353 p:=StartPos;
354 ReplaceArg(RunIndex,Result);
355 end;
356 end;
357
358 procedure RaiseCatchableException(const Msg: string);
359 begin
360 { Raises an exception.
361 gdb does not catch fpc Exception objects, therefore this procedure raises
362 a standard AV which is catched by gdb. }
363 DebugLn('ERROR in CodeTools: ',Msg);
364 // creates an exception, that gdb catches:
365 DebugLn('Creating gdb catchable error:');
366 if (length(Msg) div (length(Msg) div 10000))=0 then ;
367 end;
368
369 procedure RaiseAndCatchException;
370 begin
371 try
372 if (length(ctsAddsDirToIncludePath) div (length(ctsAddsDirToIncludePath) div 10000))=0 then ;
373 except
374 end;
375 end;
376
377 var
378 LineInfoCache: TAVLTree = nil;
379 LastTick: int64 = 0;
380
FileDateToDateTimeDefnull381 function FileDateToDateTimeDef(aFileDate: TCTFileAgeTime; const Default: TDateTime
382 ): TDateTime;
383 begin
384 try
385 Result:=FileDateToDateTime(aFileDate);
386 except
387 Result:=Default;
388 end;
389 end;
390
391 {-------------------------------------------------------------------------------
392 function ClearFile(const Filename: string; RaiseOnError: boolean): boolean;
393 -------------------------------------------------------------------------------}
ClearFilenull394 function ClearFile(const Filename: string; RaiseOnError: boolean): boolean;
395 var
396 fs: TFileStreamUTF8;
397 begin
398 if FileExistsUTF8(Filename) then begin
399 try
400 InvalidateFileStateCache(Filename);
401 fs:=TFileStreamUTF8.Create(Filename,fmOpenWrite);
402 fs.Size:=0;
403 fs.Free;
404 except
405 on E: Exception do begin
406 Result:=false;
407 if RaiseOnError then raise;
408 exit;
409 end;
410 end;
411 end;
412 Result:=true;
413 end;
414
GetTempFilenamenull415 function GetTempFilename(const Path, Prefix: string): string;
416 var
417 i: Integer;
418 CurPath: String;
419 CurName: String;
420 begin
421 Result:=ExpandFileNameUTF8(Path);
422 CurPath:=AppendPathDelim(ExtractFilePath(Result));
423 CurName:=Prefix+ExtractFileNameOnly(Result);
424 i:=1;
425 repeat
426 Result:=CurPath+CurName+IntToStr(i)+'.tmp';
427 if not FileExistsUTF8(Result) then exit;
428 inc(i);
429 until false;
430 end;
431
FindDiskFilenamenull432 function FindDiskFilename(const Filename: string): string;
433 // Searches for the filename case on disk.
434 // if it does not exist, only the found path will be improved
435 // For example:
436 // If Filename='file' and there is only a 'File' then 'File' will be returned.
437 var
438 StartPos: Integer;
439 EndPos: LongInt;
440 FileInfo: TSearchRec;
441 CurDir: String;
442 CurFile: String;
443 AliasFile: String;
444 Ambiguous: Boolean;
445 FileNotFound: Boolean;
446 begin
447 Result:=Filename;
448 // check every directory and filename
449 StartPos:=1;
450 {$IFDEF Windows}
451 // uppercase Drive letter and skip it
452 if ((length(Result)>=2) and (Result[1] in ['A'..'Z','a'..'z'])
453 and (Result[2]=':')) then begin
454 StartPos:=3;
455 if Result[1] in ['a'..'z'] then
456 Result[1]:=FPUpChars[Result[1]];
457 end;
458 {$ENDIF}
459 FileNotFound:=false;
460 repeat
461 // skip PathDelim
462 while (StartPos<=length(Result)) and (Result[StartPos]=PathDelim) do
463 inc(StartPos);
464 // find end of filename part
465 EndPos:=StartPos;
466 while (EndPos<=length(Result)) and (Result[EndPos]<>PathDelim) do
467 inc(EndPos);
468 if EndPos>StartPos then begin
469 // search file
470 CurDir:=copy(Result,1,StartPos-1);
471 CurFile:=copy(Result,StartPos,EndPos-StartPos);
472 AliasFile:='';
473 Ambiguous:=false;
474 if FindFirstUTF8(CurDir+FileMask,faAnyFile,FileInfo)=0 then
475 begin
476 repeat
477 // check if special file
478 if (FileInfo.Name='.') or (FileInfo.Name='..') or (FileInfo.Name='')
479 then
480 continue;
481 if CompareFilenamesIgnoreCase(FileInfo.Name,CurFile)=0 then begin
482 //writeln('FindDiskFilename ',FileInfo.Name,' ',CurFile);
483 if FileInfo.Name=CurFile then begin
484 // file found, has already the correct name
485 AliasFile:='';
486 break;
487 end else begin
488 // alias found, but has not the correct name
489 if AliasFile='' then begin
490 AliasFile:=FileInfo.Name;
491 end else begin
492 // there are more than one candidate
493 Ambiguous:=true;
494 end;
495 end;
496 end;
497 until FindNextUTF8(FileInfo)<>0;
498 end else
499 FileNotFound:=true;
500 FindCloseUTF8(FileInfo);
501 if FileNotFound then break;
502 if (AliasFile<>'') and (not Ambiguous) then begin
503 // better filename found -> replace
504 Result:=CurDir+AliasFile+copy(Result,EndPos,length(Result));
505 end;
506 end;
507 StartPos:=EndPos+1;
508 until StartPos>length(Result);
509 end;
510
CompareAnsiStringFilenamesnull511 function CompareAnsiStringFilenames(Data1, Data2: Pointer): integer;
512 begin
513 Result:=CompareFilenames(AnsiString(Data1),AnsiString(Data2));
514 end;
515
CompareFilenameOnlynull516 function CompareFilenameOnly(Filename: PChar; FilenameLen: integer;
517 NameOnly: PChar; NameOnlyLen: integer; CaseSensitive: boolean): integer;
518 // compare only the filename (without extension and path)
519 var
520 EndPos: integer;
521 StartPos: LongInt;
522 p: Integer;
523 l: LongInt;
524 FilenameOnlyLen: Integer;
525 begin
526 StartPos:=FilenameLen;
527 while (StartPos>0) and (Filename[StartPos-1]<>PathDelim) do dec(StartPos);
528 EndPos:=FilenameLen;
529 while (EndPos>StartPos) and (Filename[EndPos]<>'.') do dec(EndPos);
530 if (EndPos=StartPos) and (EndPos<FilenameLen) and (Filename[EndPos]<>'.') then
531 EndPos:=FilenameLen;
532 FilenameOnlyLen:=EndPos-StartPos;
533 l:=FilenameOnlyLen;
534 if l>NameOnlyLen then
535 l:=NameOnlyLen;
536 //DebugLn('CompareFilenameOnly NameOnly="',copy(NameOnly,1,NameOnlyLen),'" FilenameOnly="',copy(Filename,StartPos,EndPos-StartPos),'"');
537 p:=0;
538 if CaseSensitive then begin
539 while p<l do begin
540 Result:=ord(Filename[StartPos+p])-ord(NameOnly[p]);
541 if Result<>0 then exit;
542 inc(p);
543 end;
544 end else begin
545 while p<l do begin
546 Result:=ord(FPUpChars[Filename[StartPos+p]])-ord(FPUpChars[NameOnly[p]]);
547 if Result<>0 then exit;
548 inc(p);
549 end;
550 end;
551 Result:=FilenameOnlyLen-NameOnlyLen;
552 end;
553
FilenameIsPascalUnitnull554 function FilenameIsPascalUnit(const Filename: string;
555 CaseSensitive: boolean): boolean;
556 begin
557 Result:=(Filename<>'')
558 and FilenameIsPascalUnit(PChar(Filename),length(Filename),CaseSensitive);
559 end;
560
FilenameIsPascalUnitnull561 function FilenameIsPascalUnit(Filename: PChar; FilenameLen: integer;
562 CaseSensitive: boolean): boolean;
563 var
564 ExtPos: LongInt;
565 ExtLen: Integer;
566 e: TCTPascalExtType;
567 i: Integer;
568 p: PChar;
569 begin
570 if (Filename=nil) or (FilenameLen<2) then exit(false);
571 ExtPos:=FilenameLen-1;
572 while (ExtPos>0) and (Filename[ExtPos]<>'.') do dec(ExtPos);
573 if ExtPos<=0 then exit(false);
574 // check extension
575 ExtLen:=FilenameLen-ExtPos;
576 for e:=Low(CTPascalExtension) to High(CTPascalExtension) do begin
577 if (CTPascalExtension[e]='') or (length(CTPascalExtension[e])<>ExtLen) then
578 continue;
579 i:=0;
580 p:=PChar(Pointer(CTPascalExtension[e]));// pointer type cast avoids #0 check
581 if CaseSensitive then begin
582 while (i<ExtLen) and (p^=Filename[ExtPos+i]) do begin
583 inc(i);
584 inc(p);
585 end;
586 end else begin
587 while (i<ExtLen) and (FPUpChars[p^]=FPUpChars[Filename[ExtPos+i]]) do
588 begin
589 inc(i);
590 inc(p);
591 end;
592 end;
593 if i<>ExtLen then continue;
594 // check name is dotted identifier
595 p:=@Filename[ExtPos];
596 while (p>Filename) and (p[-1]<>PathDelim) do dec(p);
597 repeat
598 if not (p^ in ['a'..'z','A'..'Z','_']) then exit(false);
599 inc(p);
600 while (p^ in ['a'..'z','A'..'Z','_','0'..'9']) do inc(p);
601 if p^<>'.' then exit(false);
602 if p-Filename=ExtPos then exit(true);
603 inc(p);
604 until false;
605 end;
606 Result:=false;
607 end;
608
ExtractFileUnitnamenull609 function ExtractFileUnitname(Filename: string; WithNameSpace: boolean): string;
610 var
611 p: Integer;
612 begin
613 Result:=ExtractFileNameOnly(Filename);
614 if (Result='') or WithNameSpace then exit;
615 // find last dot
616 p:=length(Result);
617 while p>0 do begin
618 if Result[p]='.' then begin
619 Delete(Result,1,p);
620 exit;
621 end;
622 dec(p);
623 end;
624 end;
625
IsPascalUnitExtnull626 function IsPascalUnitExt(FileExt: PChar; CaseSensitive: boolean): boolean;
627 // check if asciiz FileExt is a CTPascalExtension '.pp', '.pas'
628 var
629 ExtLen: Integer;
630 p: PChar;
631 e: TCTPascalExtType;
632 f: PChar;
633 begin
634 Result:=false;
635 if (FileExt=nil) then exit;
636 ExtLen:=strlen(FileExt);
637 if ExtLen=0 then exit;
638 for e:=Low(CTPascalExtension) to High(CTPascalExtension) do begin
639 if length(CTPascalExtension[e])<>ExtLen then
640 continue;
641 p:=PChar(Pointer(CTPascalExtension[e]));// pointer type cast avoids #0 check
642 f:=FileExt;
643 //debugln(['IsPascalUnitExt p="',dbgstr(p),'" f="',dbgstr(f),'"']);
644 if CaseSensitive then begin
645 while (p^=f^) and (p^<>#0) do begin
646 inc(p);
647 inc(f);
648 end;
649 end else begin
650 while (FPUpChars[p^]=FPUpChars[f^]) and (p^<>#0) do
651 begin
652 inc(p);
653 inc(f);
654 end;
655 end;
656 if p^=#0 then
657 exit(true);
658 end;
659 end;
660
SearchPascalUnitInDirnull661 function SearchPascalUnitInDir(const AnUnitName, BaseDirectory: string;
662 SearchCase: TCTSearchFileCase): string;
663
664 procedure RaiseNotImplemented;
665 begin
666 raise Exception.Create('not implemented');
667 end;
668
669 var
670 Base: String;
671 FileInfo: TSearchRec;
672 LowerCaseUnitname: String;
673 UpperCaseUnitname: String;
674 CurUnitName: String;
675 begin
676 Base:=AppendPathDelim(BaseDirectory);
677 Base:=TrimFilename(Base);
678 // search file
679 Result:='';
680 if SearchCase=ctsfcAllCase then
681 Base:=FindDiskFilename(Base);
682
683 if SearchCase in [ctsfcDefault,ctsfcLoUpCase] then begin
684 LowerCaseUnitname:=lowercase(AnUnitName);
685 UpperCaseUnitname:=uppercase(AnUnitName);
686 end else begin
687 LowerCaseUnitname:='';
688 UpperCaseUnitname:='';
689 end;
690
691 if FindFirstUTF8(Base+FileMask,faAnyFile,FileInfo)=0 then
692 begin
693 repeat
694 // check if special file
695 if (FileInfo.Name='.') or (FileInfo.Name='..') or (FileInfo.Name='')
696 then
697 continue;
698 if not FilenameIsPascalUnit(FileInfo.Name,false) then continue;
699 case SearchCase of
700 ctsfcDefault,ctsfcLoUpCase:
701 if (CompareFilenameOnly(PChar(Pointer(FileInfo.Name)),// pointer type cast avoids #0 check
702 length(FileInfo.Name),
703 PChar(Pointer(AnUnitName)),
704 length(AnUnitName),false)=0)
705 then begin
706 CurUnitName:=ExtractFileNameOnly(FileInfo.Name);
707 if CurUnitName=AnUnitName then begin
708 Result:=FileInfo.Name;
709 break;
710 end else if ((LowerCaseUnitname=CurUnitName)
711 or (UpperCaseUnitname=CurUnitName)) then begin
712 Result:=FileInfo.Name;
713 end;
714 end;
715
716 ctsfcAllCase:
717 if (CompareFilenameOnly(PChar(Pointer(FileInfo.Name)),// pointer type cast avoids #0 check
718 length(FileInfo.Name),
719 PChar(Pointer(AnUnitName)),length(AnUnitName),
720 false)=0)
721 then begin
722 Result:=FileInfo.Name;
723 CurUnitName:=ExtractFileNameOnly(FileInfo.Name);
724 if CurUnitName=AnUnitName then
725 break;
726 end;
727
728 else
729 RaiseNotImplemented;
730 end;
731 until FindNextUTF8(FileInfo)<>0;
732 end;
733 FindCloseUTF8(FileInfo);
734 if Result<>'' then Result:=Base+Result;
735 end;
736
SearchPascalUnitInPathnull737 function SearchPascalUnitInPath(const AnUnitName, BasePath, SearchPath,
738 Delimiter: string; SearchCase: TCTSearchFileCase): string;
739 var
740 p, StartPos, l: integer;
741 CurPath, Base: string;
742 begin
743 Base:=AppendPathDelim(ExpandFileNameUTF8(BasePath));
744 // search in current directory
745 Result:=SearchPascalUnitInDir(AnUnitName,Base,SearchCase);
746 if Result<>'' then exit;
747 // search in search path
748 StartPos:=1;
749 l:=length(SearchPath);
750 while StartPos<=l do begin
751 p:=StartPos;
752 while (p<=l) and (pos(SearchPath[p],Delimiter)<1) do inc(p);
753 CurPath:=Trim(copy(SearchPath,StartPos,p-StartPos));
754 if CurPath<>'' then begin
755 if not FilenameIsAbsolute(CurPath) then
756 CurPath:=Base+CurPath;
757 CurPath:=AppendPathDelim(ResolveDots(CurPath));
758 Result:=SearchPascalUnitInDir(AnUnitName,CurPath,SearchCase);
759 if Result<>'' then exit;
760 end;
761 StartPos:=p+1;
762 end;
763 Result:='';
764 end;
765
SearchPascalFileInDirnull766 function SearchPascalFileInDir(const ShortFilename, BaseDirectory: string;
767 SearchCase: TCTSearchFileCase): string;
768
769 procedure RaiseNotImplemented;
770 begin
771 raise Exception.Create('not implemented');
772 end;
773
774 var
775 Base: String;
776 FileInfo: TSearchRec;
777 LowerCaseFilename: string;
778 UpperCaseFilename: string;
779 begin
780 Base:=AppendPathDelim(BaseDirectory);
781 Base:=TrimFilename(Base);
782 // search file
783 Result:='';
784 if SearchCase=ctsfcAllCase then
785 Base:=FindDiskFilename(Base);
786
787 if SearchCase in [ctsfcDefault,ctsfcLoUpCase] then begin
788 LowerCaseFilename:=lowercase(ShortFilename);
789 UpperCaseFilename:=uppercase(ShortFilename);
790 end else begin
791 LowerCaseFilename:='';
792 UpperCaseFilename:='';
793 end;
794
795 if FindFirstUTF8(Base+FileMask,faAnyFile,FileInfo)=0 then
796 begin
797 repeat
798 // check if special file
799 if (FileInfo.Name='.') or (FileInfo.Name='..') or (FileInfo.Name='')
800 then
801 continue;
802 case SearchCase of
803 ctsfcDefault,ctsfcLoUpCase:
804 if (ShortFilename=FileInfo.Name) then begin
805 Result:=FileInfo.Name;
806 break;
807 end else if (LowerCaseFilename=FileInfo.Name)
808 or (UpperCaseFilename=FileInfo.Name)
809 then
810 Result:=FileInfo.Name;
811
812 ctsfcAllCase:
813 // do not use CompareFilenamesIgnoreCase
814 if SysUtils.CompareText(ShortFilename,FileInfo.Name)=0 then begin
815 Result:=FileInfo.Name;
816 if ShortFilename=FileInfo.Name then break;
817 end;
818
819 else
820 RaiseNotImplemented;
821 end;
822 until FindNextUTF8(FileInfo)<>0;
823 end;
824 FindCloseUTF8(FileInfo);
825 if Result<>'' then Result:=Base+Result;
826 end;
827
SearchPascalFileInPathnull828 function SearchPascalFileInPath(const ShortFilename, BasePath, SearchPath,
829 Delimiter: string; SearchCase: TCTSearchFileCase): string;
830 // search in each directory, first normal case, then lower case, then upper case
831 var
832 p, StartPos, l: integer;
833 CurPath, Base: string;
834 begin
835 Base:=AppendPathDelim(LazFileUtils.ExpandFileNameUTF8(BasePath));
836 // search in current directory
837 if not FilenameIsAbsolute(Base) then
838 Base:='';
839 if Base<>'' then begin
840 Result:=SearchPascalFileInDir(ShortFilename,Base,SearchCase);
841 if Result<>'' then exit;
842 end;
843 // search in search path
844 StartPos:=1;
845 l:=length(SearchPath);
846 while StartPos<=l do begin
847 p:=StartPos;
848 while (p<=l) and (pos(SearchPath[p],Delimiter)<1) do inc(p);
849 CurPath:=Trim(copy(SearchPath,StartPos,p-StartPos));
850 if CurPath<>'' then begin
851 if not FilenameIsAbsolute(CurPath) then
852 CurPath:=Base+CurPath;
853 CurPath:=AppendPathDelim(ResolveDots(CurPath));
854 if FilenameIsAbsolute(CurPath) then begin
855 Result:=SearchPascalFileInDir(ShortFilename,CurPath,SearchCase);
856 if Result<>'' then exit;
857 end;
858 end;
859 StartPos:=p+1;
860 end;
861 Result:='';
862 end;
863
ReadNextFPCParameternull864 function ReadNextFPCParameter(const CmdLine: string; var Position: integer; out
865 StartPos: integer): boolean;
866 // reads till start of next FPC command line parameter, parses quotes ' and "
867 var
868 c: Char;
869 begin
870 StartPos:=Position;
871 while (StartPos<=length(CmdLine)) and (CmdLine[StartPos] in [' ',#9,#10,#13]) do
872 inc(StartPos);
873 Position:=StartPos;
874 while (Position<=length(CmdLine)) do begin
875 c:=CmdLine[Position];
876 case c of
877 ' ',#9,#10,#13: break;
878 '''','"':
879 repeat
880 inc(Position);
881 until (Position>length(CmdLine)) or (CmdLine[Position]=c);
882 end;
883 inc(Position);
884 end;
885 Result:=StartPos<=length(CmdLine);
886 end;
887
888 function ExtractFPCParameter(const CmdLine: string; StartPos: integer): string;
889 // returns a single FPC command line parameter, resolves quotes ' and "
890 var
891 p: Integer;
892 c: Char;
893
894 procedure Add;
895 begin
896 Result:=Result+copy(CmdLine,StartPos,p-StartPos);
897 end;
898
899 begin
900 Result:='';
901 p:=StartPos;
902 while (p<=length(CmdLine)) do begin
903 c:=CmdLine[p];
904 case c of
905 ' ',#9,#10,#13: break;
906 '''','"':
907 begin
908 Add;
909 inc(p);
910 StartPos:=p;
911 while (p<=length(CmdLine)) do begin
912 if CmdLine[p]=c then begin
913 Add;
914 inc(p);
915 StartPos:=p;
916 break;
917 end;
918 inc(p);
919 end;
920 end;
921 end;
922 inc(p);
923 end;
924 Add;
925 end;
926
FindNextFPCParameternull927 function FindNextFPCParameter(const CmdLine, BeginsWith: string;
928 var Position: integer): integer;
929 begin
930 if BeginsWith='' then
931 exit(-1);
932 while ReadNextFPCParameter(CmdLine,Position,Result) do
933 if LeftStr(ExtractFPCParameter(CmdLine,Result),length(BeginsWith))=BeginsWith
934 then
935 exit;
936 Result:=-1;
937 end;
938
GetLastFPCParameternull939 function GetLastFPCParameter(const CmdLine, BeginsWith: string;
940 CutBegins: boolean): string;
941 var
942 Param: String;
943 p: Integer;
944 StartPos: integer;
945 begin
946 Result:='';
947 if BeginsWith='' then
948 exit;
949 p:=1;
950 while ReadNextFPCParameter(CmdLine,p,StartPos) do begin
951 Param:=ExtractFPCParameter(CmdLine,StartPos);
952 if LeftStr(Param,length(BeginsWith))=BeginsWith then begin
953 Result:=Param;
954 if CutBegins then
955 System.Delete(Result,1,length(BeginsWith));
956 end;
957 end;
958 end;
959
GetFPCParameterSrcFilenull960 function GetFPCParameterSrcFile(const CmdLine: string): string;
961 // the source file is the last parameter not starting with minus
962 var
963 p: Integer;
964 StartPos: integer;
965 begin
966 p:=1;
967 while ReadNextFPCParameter(CmdLine,p,StartPos) do begin
968 if (CmdLine[StartPos]='-') then continue;
969 Result:=ExtractFPCParameter(CmdLine,StartPos);
970 if (Result='') or (Result[1]='-') then continue;
971 exit;
972 end;
973 Result:='';
974 end;
975
SearchFileInDirnull976 function SearchFileInDir(const Filename, BaseDirectory: string;
977 SearchCase: TCTSearchFileCase): string;
978
979 procedure RaiseNotImplemented;
980 begin
981 raise Exception.Create('not implemented');
982 end;
983
984 var
985 Base: String;
986 ShortFile: String;
987 FileInfo: TSearchRec;
988 begin
989 Result:='';
990 Base:=AppendPathDelim(BaseDirectory);
991 ShortFile:=Filename;
992 if System.Pos(PathDelim,ShortFile)>0 then begin
993 Base:=Base+ExtractFilePath(ShortFile);
994 ShortFile:=ExtractFilename(ShortFile);
995 end;
996 Base:=TrimFilename(Base);
997 case SearchCase of
998 ctsfcDefault:
999 begin
1000 Result:=Base+ShortFile;
1001 if not LazFileCache.FileExistsCached(Result) then Result:='';
1002 end;
1003 ctsfcLoUpCase:
1004 begin
1005 Result:=Base+ShortFile;
1006 if not LazFileCache.FileExistsCached(Result) then begin
1007 Result:=lowercase(Result);
1008 if not LazFileCache.FileExistsCached(Result) then begin
1009 Result:=uppercase(Result);
1010 if not LazFileCache.FileExistsCached(Result) then Result:='';
1011 end;
1012 end;
1013 end;
1014 ctsfcAllCase:
1015 begin
1016 // search file
1017 Base:=FindDiskFilename(Base);
1018 if FindFirstUTF8(Base+FileMask,faAnyFile,FileInfo)=0 then
1019 begin
1020 repeat
1021 // check if special file
1022 if (FileInfo.Name='.') or (FileInfo.Name='..') or (FileInfo.Name='')
1023 then
1024 continue;
1025 if (SysUtils.CompareText(FileInfo.Name,ShortFile)=0)
1026 or (CompareFilenamesIgnoreCase(FileInfo.Name,ShortFile)=0) then begin
1027 if FileInfo.Name=ShortFile then begin
1028 // file found, with correct name
1029 Result:=FileInfo.Name;
1030 break;
1031 end else begin
1032 // alias found, but has not the correct name
1033 Result:=FileInfo.Name;
1034 end;
1035 end;
1036 until FindNextUTF8(FileInfo)<>0;
1037 end;
1038 FindCloseUTF8(FileInfo);
1039 if Result<>'' then Result:=Base+Result;
1040 end;
1041 else
1042 RaiseNotImplemented;
1043 end;
1044 end;
1045
SearchFileInPathnull1046 function SearchFileInPath(const Filename, BasePath, SearchPath,
1047 Delimiter: string; SearchCase: TCTSearchFileCase): string;
1048 var
1049 p, StartPos, l: integer;
1050 CurPath, Base: string;
1051 begin
1052 //debugln('[SearchFileInPath] Filename="',Filename,'" BasePath="',BasePath,'" SearchPath="',SearchPath,'" Delimiter="',Delimiter,'"');
1053 if (Filename='') then begin
1054 Result:='';
1055 exit;
1056 end;
1057 // check if filename absolute
1058 if FilenameIsAbsolute(Filename) then begin
1059 if SearchCase=ctsfcDefault then begin
1060 Result:=ResolveDots(Filename);
1061 if not LazFileCache.FileExistsCached(Result) then
1062 Result:='';
1063 end else
1064 Result:=SearchFileInPath(ExtractFilename(Filename),
1065 ExtractFilePath(BasePath),'',';',SearchCase);
1066 exit;
1067 end;
1068 Base:=AppendPathDelim(ExpandFileNameUTF8(BasePath));
1069 // search in current directory
1070 Result:=SearchFileInDir(Filename,Base,SearchCase);
1071 if Result<>'' then exit;
1072 // search in search path
1073 StartPos:=1;
1074 l:=length(SearchPath);
1075 while StartPos<=l do begin
1076 p:=StartPos;
1077 while (p<=l) and (pos(SearchPath[p],Delimiter)<1) do inc(p);
1078 CurPath:=Trim(copy(SearchPath,StartPos,p-StartPos));
1079 if CurPath<>'' then begin
1080 if not FilenameIsAbsolute(CurPath) then
1081 CurPath:=Base+CurPath;
1082 CurPath:=AppendPathDelim(ResolveDots(CurPath));
1083 Result:=SearchFileInDir(Filename,CurPath,SearchCase);
1084 if Result<>'' then exit;
1085 end;
1086 StartPos:=p+1;
1087 end;
1088 Result:='';
1089 end;
1090
FilenameIsMatchingnull1091 function FilenameIsMatching(const Mask, Filename: string; MatchExactly: boolean
1092 ): boolean;
1093 (*
1094 check if Filename matches Mask
1095 if MatchExactly then the complete Filename must match, else only the
1096 start
1097
1098 Filename matches exactly or is a file/directory in a subdirectory of mask.
1099 Mask can contain the wildcards * and ? and the set operator {,}.
1100 The wildcards will *not* match PathDelim.
1101 You can nest the {} sets.
1102 If you need the asterisk, the question mark or the PathDelim as character
1103 just put the SpecialChar character in front of it (e.g. #*, #? #/).
1104
1105 Examples:
1106 /abc matches /abc, /abc/, /abc/p, /abc/xyz/filename
1107 but not /abcd
1108 /abc/ matches /abc, /abc/, /abc//, but not /abc/.
1109 /abc/x?z/www matches /abc/xyz/www, /abc/xaz/www
1110 but not /abc/x/z/www
1111 /abc/x*z/www matches /abc/xz/www, /abc/xyz/www, /abc/xAAAz/www
1112 but not /abc/x/z/www
1113 /abc/x#*z/www matches /abc/x*z/www, /abc/x*z/www/ttt
1114 /a{b,c,d}e matches /abe, /ace, /ade
1115 *.p{as,p,} matches a.pas, unit1.pp, b.p but not b.inc
1116 *.{p{as,p,},inc} matches a.pas, unit1.pp, b.p, b.inc but not c.lfm
1117 *)
1118 {off $DEFINE VerboseFilenameIsMatching}
1119
Checknull1120 function Check(MaskP, FileP: PChar): boolean;
1121 var
1122 Level: Integer;
1123 MaskStart: PChar;
1124 FileStart: PChar;
1125 begin
1126 {$IFDEF VerboseFilenameIsMatching}
1127 debugln([' Check Mask="',MaskP,'" FileP="',FileP,'"']);
1128 {$ENDIF}
1129 Result:=false;
1130 repeat
1131 case MaskP^ of
1132 #0:
1133 begin
1134 // the whole Mask fits the start of Filename
1135 // trailing PathDelim in FileP are ok
1136 {$IFDEF VerboseFilenameIsMatching}
1137 debugln([' Check END Mask="',MaskP,'" FileP="',FileP,'"']);
1138 {$ENDIF}
1139 if FileP^=#0 then exit(true);
1140 if FileP^<>PathDelim then exit(false);
1141 while FileP^=PathDelim do inc(FileP);
1142 Result:=(FileP^=#0) or (not MatchExactly);
1143 exit;
1144 end;
1145 SpecialChar:
1146 begin
1147 // match on character
1148 {$IFDEF VerboseFilenameIsMatching}
1149 debugln([' Check specialchar Mask="',MaskP,'" FileP="',FileP,'"']);
1150 {$ENDIF}
1151 inc(MaskP);
1152 if MaskP^=#0 then exit;
1153 if MaskP^<>FileP^ then exit;
1154 inc(MaskP);
1155 inc(FileP);
1156 end;
1157 PathDelim:
1158 begin
1159 // match PathDelim(s) or end of filename
1160 {$IFDEF VerboseFilenameIsMatching}
1161 debugln([' Check PathDelim Mask="',MaskP,'" FileP="',FileP,'"']);
1162 {$ENDIF}
1163 if not (FileP^ in [#0,PathDelim]) then exit;
1164 // treat several PathDelim as one
1165 while MaskP^=PathDelim do inc(MaskP);
1166 while FileP^=PathDelim do inc(FileP);
1167 if MaskP^=#0 then
1168 exit((FileP^=#0) or not MatchExactly);
1169 end;
1170 '?':
1171 begin
1172 // match any one character, but PathDelim
1173 {$IFDEF VerboseFilenameIsMatching}
1174 debugln([' Check any one char Mask="',MaskP,'" FileP="',FileP,'"']);
1175 {$ENDIF}
1176 if FileP^ in [#0,PathDelim] then exit;
1177 inc(MaskP);
1178 inc(FileP,UTF8CodepointSize(FileP));
1179 end;
1180 '*':
1181 begin
1182 // match 0 or more characters, but PathDelim
1183 {$IFDEF VerboseFilenameIsMatching}
1184 debugln([' Check any chars Mask="',MaskP,'" FileP="',FileP,'"']);
1185 {$ENDIF}
1186 while MaskP^='*' do inc(MaskP);
1187 repeat
1188 if Check(MaskP,FileP) then exit(true);
1189 if FileP^ in [#0,PathDelim] then exit;
1190 inc(FileP);
1191 until false;
1192 end;
1193 '{':
1194 begin
1195 // OR options separated by comma
1196 {$IFDEF VerboseFilenameIsMatching}
1197 debugln([' Check { Mask="',MaskP,'" FileP="',FileP,'"']);
1198 {$ENDIF}
1199 inc(MaskP);
1200 repeat
1201 if Check(MaskP,FileP) then begin
1202 {$IFDEF VerboseFilenameIsMatching}
1203 debugln([' Check { option fits -> end']);
1204 {$ENDIF}
1205 exit(true);
1206 end;
1207 {$IFDEF VerboseFilenameIsMatching}
1208 debugln([' Check { skip to next option ...']);
1209 {$ENDIF}
1210 // skip to next option in MaskP
1211 Level:=1;
1212 repeat
1213 case MaskP^ of
1214 #0: exit;
1215 SpecialChar:
1216 begin
1217 inc(MaskP);
1218 if MaskP^=#0 then exit;
1219 inc(MaskP);
1220 end;
1221 '{': inc(Level);
1222 '}':
1223 begin
1224 dec(Level);
1225 if Level=0 then exit; // no option fits
1226 end;
1227 ',':
1228 if Level=1 then break;
1229 end;
1230 inc(MaskP);
1231 until false;
1232 {$IFDEF VerboseFilenameIsMatching}
1233 debugln([' Check { next option: "',MaskP,'"']);
1234 {$ENDIF}
1235 inc(MaskP)
1236 until false;
1237 end;
1238 '}':
1239 begin
1240 {$IFDEF VerboseFilenameIsMatching}
1241 debugln([' Check } Mask="',MaskP,'" FileP="',FileP,'"']);
1242 {$ENDIF}
1243 inc(MaskP);
1244 end;
1245 ',':
1246 begin
1247 // OR option fits => continue behind the {}
1248 {$IFDEF VerboseFilenameIsMatching}
1249 debugln([' Check Skipping to end of {} Mask="',MaskP,'" ...']);
1250 {$ENDIF}
1251 Level:=1;
1252 repeat
1253 inc(MaskP);
1254 case MaskP^ of
1255 #0: exit;
1256 SpecialChar:
1257 begin
1258 inc(MaskP);
1259 if MaskP^=#0 then exit;
1260 inc(MaskP);
1261 end;
1262 '{': inc(Level);
1263 '}':
1264 begin
1265 dec(Level);
1266 if Level=0 then break;
1267 end;
1268 end;
1269 until false;
1270 {$IFDEF VerboseFilenameIsMatching}
1271 debugln([' Check Skipped to end of {} Mask="',MaskP,'"']);
1272 {$ENDIF}
1273 inc(MaskP);
1274 end;
1275 #128..#255:
1276 begin
1277 // match UTF-8 characters
1278 {$IFDEF VerboseFilenameIsMatching}
1279 debugln([' Check UTF-8 chars Mask="',MaskP,'" FileP="',FileP,'"']);
1280 {$ENDIF}
1281 MaskStart:=MaskP;
1282 FileStart:=FileP;
1283 while not (MaskP^ in [#0,SpecialChar,PathDelim,'?','*','{',',','}']) do
1284 begin
1285 if FileP^ in [#0,PathDelim] then exit;
1286 inc(MaskP,UTF8CodepointSize(MaskP));
1287 inc(FileP,UTF8CodepointSize(FileP));
1288 end;
1289 if CompareFilenames(MaskStart,MaskP-MaskStart,FileStart,FileP-FileStart)<>0 then
1290 exit;
1291 end;
1292 else
1293 // match ASCII characters
1294 repeat
1295 case MaskP^ of
1296 #0,SpecialChar,PathDelim,'?','*','{',',','}': break;
1297 {$IFDEF CaseInsensitiveFilenames}
1298 'a'..'z','A'..'Z':
1299 if FPUpChars[MaskP^]<>FPUpChars[FileP^] then exit;
1300 {$ENDIF}
1301 else
1302 if MaskP^<>FileP^ then exit;
1303 end;
1304 inc(MaskP);
1305 inc(FileP);
1306 until false;
1307 end;
1308 until false;
1309 end;
1310
1311 begin
1312 if Filename='' then exit(false);
1313 if Mask='' then exit(true);
1314 {$IFDEF VerboseFilenameIsMatching}
1315 debugln(['FilenameIsMatching2 Mask="',Mask,'" File="',Filename,'" Exactly=',MatchExactly]);
1316 {$ENDIF}
1317
1318 Result:=Check(PChar(Mask),PChar(Filename));
1319 end;
1320
FindNextDirectoryInFilenamenull1321 function FindNextDirectoryInFilename(const Filename: string;
1322 var Position: integer): string;
1323 { for example:
1324 Unix:
1325 '/a/b' -> returns first 'a', then 'b'
1326 '/a/' -> returns 'a', then ''
1327 '/a//' -> returns 'a', then '', then ''
1328 'a/b.pas' -> returns first 'a', then 'b.pas'
1329 Windows
1330 'C:\a\b.pas' -> returns first 'C:\', then 'a', then 'b.pas'
1331 'C:\a\' -> returns first 'C:\', then 'a', then ''
1332 'C:\a\\' -> returns first 'C:\', then 'a', then '', then ''
1333 }
1334 var
1335 StartPos: Integer;
1336 begin
1337 if Position>length(Filename) then exit('');
1338 {$IFDEF Windows}
1339 if Position=1 then begin
1340 Result := ExtractUNCVolume(Filename);
1341 if Result<>'' then begin
1342 // is it like \\?\C:\Directory? then also include the "C:\" part
1343 if (Result = '\\?\') and (Length(FileName) > 6) and
1344 (FileName[5] in ['a'..'z','A'..'Z']) and (FileName[6] = ':') and (FileName[7] = PathDelim)
1345 then
1346 Result := Copy(FileName, 1, 7);
1347 Position:=length(Result)+1;
1348 exit;
1349 end;
1350 end;
1351 {$ENDIF}
1352 if Filename[Position]=PathDelim then
1353 inc(Position);
1354 StartPos:=Position;
1355 while (Position<=length(Filename)) and (Filename[Position]<>PathDelim) do
1356 inc(Position);
1357 Result:=copy(Filename,StartPos,Position-StartPos);
1358 end;
1359
AVLTreeHasDoublesnull1360 function AVLTreeHasDoubles(Tree: TAVLTree): TAVLTreeNode;
1361 var
1362 Next: TAVLTreeNode;
1363 begin
1364 if Tree=nil then exit(nil);
1365 Result:=Tree.FindLowest;
1366 while Result<>nil do begin
1367 Next:=Tree.FindSuccessor(Result);
1368 if (Next<>nil) and (Tree.OnCompare(Result.Data,Next.Data)=0) then exit;
1369 Result:=Next;
1370 end;
1371 end;
1372
DateToCfgStrnull1373 function DateToCfgStr(const Date: TDateTime; const aFormat: string): string;
1374 var
1375 NeedDate: Boolean;
1376 NeedTime: Boolean;
1377 Year: word;
1378 Month: word;
1379 Day: word;
1380 Hour: word;
1381 Minute: word;
1382 Second: word;
1383 MilliSecond: word;
1384 p: Integer;
1385 w: Word;
1386 StartP: Integer;
1387 s: String;
1388 l: Integer;
1389 begin
1390 Result:=aFormat;
1391 NeedDate:=false;
1392 NeedTime:=false;
1393 for p:=1 to length(aFormat) do
1394 case aFormat[p] of
1395 'Y','M','D': NeedDate:=true;
1396 'H','N','S','Z': NeedTime:=true;
1397 end;
1398 if NeedDate then
1399 DecodeDate(Date,Year,Month,Day);
1400 if NeedTime then
1401 DecodeTime(Date,Hour,Minute,Second,MilliSecond);
1402 p:=1;
1403 while p<=length(aFormat) do begin
1404 case aFormat[p] of
1405 'Y': w:=Year;
1406 'M': w:=Month;
1407 'D': w:=Day;
1408 'H': w:=Hour;
1409 'N': w:=Minute;
1410 'S': w:=Second;
1411 'Z': w:=MilliSecond;
1412 else
1413 inc(p);
1414 continue;
1415 end;
1416 StartP:=p;
1417 repeat
1418 inc(p);
1419 until (p>length(aFormat)) or (aFormat[p]<>aFormat[p-1]);
1420 l:=p-StartP;
1421 s:=IntToStr(w);
1422 if length(s)<l then
1423 s:=StringOfChar('0',l-length(s))+s
1424 else if length(s)>l then
1425 raise Exception.Create('date format does not fit');
1426 ReplaceSubstring(Result,StartP,l,s);
1427 p:=StartP+length(s);
1428 end;
1429 //debugln('DateToCfgStr "',Result,'"');
1430 end;
1431
CfgStrToDatenull1432 function CfgStrToDate(const s: string; out Date: TDateTime;
1433 const aFormat: string): boolean;
1434
1435 procedure AddDecimal(var d: word; c: char); inline;
1436 begin
1437 d:=d*10+ord(c)-ord('0');
1438 end;
1439
1440 var
1441 i: Integer;
1442 Year, Month, Day, Hour, Minute, Second, MilliSecond: word;
1443 begin
1444 //debugln('CfgStrToDate "',s,'"');
1445 if length(s)<>length(aFormat) then begin
1446 Date:=0.0;
1447 exit(false);
1448 end;
1449 try
1450 Year:=0;
1451 Month:=0;
1452 Day:=0;
1453 Hour:=0;
1454 Minute:=0;
1455 Second:=0;
1456 MilliSecond:=0;
1457 for i:=1 to length(aFormat) do begin
1458 case aFormat[i] of
1459 'Y': AddDecimal(Year,s[i]);
1460 'M': AddDecimal(Month,s[i]);
1461 'D': AddDecimal(Day,s[i]);
1462 'H': AddDecimal(Hour,s[i]);
1463 'N': AddDecimal(Minute,s[i]);
1464 'S': AddDecimal(Second,s[i]);
1465 'Z': AddDecimal(MilliSecond,s[i]);
1466 end;
1467 end;
1468 Date:=ComposeDateTime(EncodeDate(Year,Month,Day),EncodeTime(Hour,Minute,Second,MilliSecond));
1469 Result:=true;
1470 except
1471 Result:=false;
1472 end;
1473 end;
1474
1475 procedure DebugLn(Args: array of const);
1476 begin
1477 LazLoggerBase.Debugln(Args);
1478 end;
1479
1480 procedure DebugLn(const S: String; Args: array of const);
1481 begin
1482 LazLoggerBase.DebugLn(Format(S, Args));
1483 end;
1484
1485 procedure DebugLn;
1486 begin
1487 LazLoggerBase.DebugLn('');
1488 end;
1489
1490 procedure DebugLn(const s: string);
1491 begin
1492 LazLoggerBase.Debugln(s);
1493 end;
1494
1495 procedure DebugLn(const s1, s2: string);
1496 begin
1497 LazLoggerBase.Debugln(s1,s2);
1498 end;
1499
1500 procedure DebugLn(const s1, s2, s3: string);
1501 begin
1502 LazLoggerBase.Debugln(s1,s2,s3);
1503 end;
1504
1505 procedure DebugLn(const s1, s2, s3, s4: string);
1506 begin
1507 LazLoggerBase.Debugln(s1,s2,s3,s4);
1508 end;
1509
1510 procedure DebugLn(const s1, s2, s3, s4, s5: string);
1511 begin
1512 LazLoggerBase.Debugln(s1,s2,s3,s4,s5);
1513 end;
1514
1515 procedure DebugLn(const s1, s2, s3, s4, s5, s6: string);
1516 begin
1517 LazLoggerBase.Debugln(s1,s2,s3,s4,s5,s6);
1518 end;
1519
1520 procedure DebugLn(const s1, s2, s3, s4, s5, s6, s7: string);
1521 begin
1522 LazLoggerBase.Debugln(s1,s2,s3,s4,s5,s6,s7);
1523 end;
1524
1525 procedure DebugLn(const s1, s2, s3, s4, s5, s6, s7, s8: string);
1526 begin
1527 LazLoggerBase.Debugln(s1,s2,s3,s4,s5,s6,s7,s8);
1528 end;
1529
1530 procedure DebugLn(const s1, s2, s3, s4, s5, s6, s7, s8, s9: string);
1531 begin
1532 LazLoggerBase.Debugln(s1,s2,s3,s4,s5,s6,s7,s8,s9);
1533 end;
1534
1535 procedure DebugLn(const s1, s2, s3, s4, s5, s6, s7, s8, s9, s10: string);
1536 begin
1537 LazLoggerBase.Debugln(s1,s2,s3,s4,s5,s6,s7,s8,s9,s10);
1538 end;
1539
1540 procedure DebugLn(const s1, s2, s3, s4, s5, s6, s7, s8, s9, s10, s11: string);
1541 begin
1542 LazLoggerBase.Debugln(s1,s2,s3,s4,s5,s6,s7,s8,s9,s10,s11);
1543 end;
1544
1545 procedure DebugLn(const s1, s2, s3, s4, s5, s6, s7, s8, s9, s10, s11,
1546 s12: string);
1547 begin
1548 LazLoggerBase.Debugln(s1,s2,s3,s4,s5,s6,s7,s8,s9,s10,s11,s12);
1549 end;
1550
1551 procedure DbgOut(Args: array of const);
1552 begin
1553 LazLoggerBase.DbgOut(dbgs(Args));
1554 end;
1555
1556 procedure DbgOut(const s: string);
1557 begin
1558 LazLoggerBase.DbgOut(s);
1559 end;
1560
1561 procedure DbgOut(const s1, s2: string);
1562 begin
1563 LazLoggerBase.DbgOut(s1,s2);
1564 end;
1565
1566 procedure DbgOut(const s1, s2, s3: string);
1567 begin
1568 LazLoggerBase.DbgOut(s1,s2,s3);
1569 end;
1570
1571 procedure DbgOut(const s1, s2, s3, s4: string);
1572 begin
1573 LazLoggerBase.DbgOut(s1,s2,s3,s4);
1574 end;
1575
1576 procedure DbgOut(const s1, s2, s3, s4, s5: string);
1577 begin
1578 LazLoggerBase.DbgOut(s1,s2,s3,s4,s5);
1579 end;
1580
1581 procedure DbgOut(const s1, s2, s3, s4, s5, s6: string);
1582 begin
1583 LazLoggerBase.DbgOut(s1,s2,s3,s4,s5,s6);
1584 end;
1585
DbgSnull1586 function DbgS(Args: array of const): string;
1587 var
1588 i: Integer;
1589 begin
1590 Result:='';
1591 for i:=Low(Args) to High(Args) do begin
1592 case Args[i].VType of
1593 vtInteger: Result:=Result+dbgs(Args[i].vinteger);
1594 vtInt64: Result:=Result+dbgs(Args[i].VInt64^);
1595 vtQWord: Result:=Result+dbgs(Args[i].VQWord^);
1596 vtBoolean: Result:=Result+dbgs(Args[i].vboolean);
1597 vtExtended: Result:=Result+dbgs(Args[i].VExtended^);
1598 {$ifdef FPC_CURRENCY_IS_INT64}
1599 // MWE:
1600 // fpc 2.x has troubles in choosing the right dbgs()
1601 // so we convert here
1602 vtCurrency: Result:=Result+dbgs(int64(Args[i].vCurrency^)/10000 , 4);
1603 {$else}
1604 vtCurrency: Result:=Result+dbgs(Args[i].vCurrency^);
1605 {$endif}
1606 vtString: Result:=Result+Args[i].VString^;
1607 vtAnsiString: Result:=Result+AnsiString(Args[i].VAnsiString);
1608 vtChar: Result:=Result+Args[i].VChar;
1609 vtPChar: Result:=Result+Args[i].VPChar;
1610 vtPWideChar: Result:=Result+UnicodeToUTF8(ord(Args[i].VPWideChar^));
1611 vtWideChar: Result:=Result+UnicodeToUTF8(ord(Args[i].VWideChar));
1612 vtWidestring: Result:=Result+UTF8Encode(WideString(Args[i].VWideString));
1613 vtObject: Result:=Result+DbgSName(Args[i].VObject);
1614 vtClass: Result:=Result+DbgSName(Args[i].VClass);
1615 vtPointer: Result:=Result+Dbgs(Args[i].VPointer);
1616 else
1617 Result:=Result+'?unknown variant?';
1618 end;
1619 end;
1620 end;
1621
DbgSnull1622 function DbgS(const c: char): string;
1623 begin
1624 case c of
1625 ' '..#126: Result:=c;
1626 else
1627 Result:='#'+IntToStr(ord(c));
1628 end;
1629 end;
1630
DbgSnull1631 function DbgS(const c: cardinal): string;
1632 begin
1633 Result:=LazLoggerBase.DbgS(c);
1634 end;
1635
DbgSnull1636 function DbgS(const i: integer): string;
1637 begin
1638 Result:=LazLoggerBase.DbgS(i);
1639 end;
1640
DbgSnull1641 function DbgS(const i: QWord): string;
1642 begin
1643 Result:=LazLoggerBase.DbgS(i);
1644 end;
1645
DbgSnull1646 function DbgS(const i: int64): string;
1647 begin
1648 Result:=LazLoggerBase.DbgS(i);
1649 end;
1650
DbgSnull1651 function DbgS(const r: TRect): string;
1652 begin
1653 Result:=LazLoggerBase.DbgS(r);
1654 end;
1655
DbgSnull1656 function DbgS(const p: TPoint): string;
1657 begin
1658 Result:=LazLoggerBase.DbgS(p);
1659 end;
1660
DbgSnull1661 function DbgS(const p: pointer): string;
1662 begin
1663 Result:=LazLoggerBase.DbgS(p);
1664 end;
1665
DbgSnull1666 function DbgS(const e: extended; MaxDecimals: integer = 999): string;
1667 begin
1668 Result:=LazLoggerBase.DbgS(e,MaxDecimals);
1669 end;
1670
DbgSnull1671 function DbgS(const b: boolean): string;
1672 begin
1673 Result:=LazLoggerBase.DbgS(b);
1674 end;
1675
DbgSnull1676 function DbgS(const i1, i2, i3, i4: integer): string;
1677 begin
1678 Result:=LazLoggerBase.DbgS(i1,i2,i3,i4);
1679 end;
1680
DbgSnull1681 function DbgS(const ms: TCustomMemoryStream; Count: PtrInt): string;
1682 begin
1683 Result:=dbgMemStream(ms,Count);
1684 end;
1685
DbgSNamenull1686 function DbgSName(const p: TObject): string;
1687 begin
1688 Result:=LazLoggerBase.DbgSName(p);
1689 end;
1690
DbgSNamenull1691 function DbgSName(const p: TClass): string;
1692 begin
1693 Result:=LazLoggerBase.DbgSName(p);
1694 end;
1695
dbgMemRangenull1696 function dbgMemRange(P: PByte; Count: integer; Width: integer): string;
1697 begin
1698 Result:=LazLoggerBase.dbgMemRange(P,Count,Width);
1699 end;
1700
DbgStrnull1701 function DbgStr(const StringWithSpecialChars: string): string;
1702 var
1703 i: Integer;
1704 s: String;
1705 begin
1706 Result:=StringWithSpecialChars;
1707 i:=length(Result);
1708 while (i>0) do begin
1709 case Result[i] of
1710 ' '..#126: ;
1711 else
1712 s:='#'+IntToStr(ord(Result[i]));
1713 ReplaceSubstring(Result,i,1,s);
1714 end;
1715 dec(i);
1716 end;
1717 end;
1718
DbgStrnull1719 function DbgStr(const StringWithSpecialChars: string; StartPos, Len: PtrInt): string;
1720 begin
1721 Result:=dbgstr(copy(StringWithSpecialChars,StartPos,Len));
1722 end;
1723
DbgTextnull1724 function DbgText(const StringWithSpecialChars: string; KeepLines: boolean): string;
1725 var
1726 i: Integer;
1727 s: String;
1728 c: Char;
1729 l: Integer;
1730 begin
1731 Result:=StringWithSpecialChars;
1732 i:=1;
1733 while (i<=length(Result)) do begin
1734 c:=Result[i];
1735 case c of
1736 ' '..#126: inc(i);
1737 else
1738 if KeepLines and (c in [#10,#13]) then begin
1739 // replace line ending with system line ending
1740 if (i<length(Result)) and (Result[i+1] in [#10,#13])
1741 and (c<>Result[i+1]) then
1742 l:=2
1743 else
1744 l:=1;
1745 ReplaceSubstring(Result,i,l,LineEnding);
1746 inc(i,length(LineEnding));
1747 end else begin
1748 s:='#'+IntToStr(ord(c));
1749 ReplaceSubstring(Result,i,1,s);
1750 inc(i,length(s));
1751 end;
1752 end;
1753 end;
1754 end;
1755
CompareCTMemStatnull1756 function CompareCTMemStat(Stat1, Stat2: TCTMemStat): integer;
1757 begin
1758 Result:=SysUtils.CompareText(Stat1.Name,Stat2.Name);
1759 end;
1760
CompareNameWithCTMemStatnull1761 function CompareNameWithCTMemStat(KeyAnsiString: Pointer; Stat: TCTMemStat): integer;
1762 begin
1763 Result:=SysUtils.CompareText(AnsiString(KeyAnsiString),Stat.Name);
1764 end;
1765
GetTicksnull1766 function GetTicks: int64;
1767 var
1768 CurTick: Int64;
1769 begin
1770 CurTick:=round(Now*86400000);
1771 Result:=CurTick-LastTick;
1772 LastTick:=CurTick;
1773 end;
1774
1775 procedure CTDumpStack;
1776 begin
1777 DebugLn(CTGetStackTrace(true));
1778 end;
1779
CTGetStackTracenull1780 function CTGetStackTrace(UseCache: boolean): string;
1781 var
1782 bp: Pointer;
1783 addr: Pointer;
1784 oldbp: Pointer;
1785 CurAddress: Shortstring;
1786 begin
1787 Result:='';
1788 { retrieve backtrace info }
1789 bp:=get_caller_frame(get_frame);
1790 while bp<>nil do begin
1791 addr:=get_caller_addr(bp);
1792 CurAddress:=CTGetLineInfo(addr,UseCache);
1793 //DebugLn('GetStackTrace ',CurAddress);
1794 Result:=Result+CurAddress+LineEnding;
1795 oldbp:=bp;
1796 bp:=get_caller_frame(bp);
1797 if (bp<=oldbp) or (bp>(StackBottom + StackLength)) then
1798 bp:=nil;
1799 end;
1800 end;
1801
1802 procedure CTGetStackTracePointers(var AStack: TCTStackTracePointers);
1803 var
1804 Depth: Integer;
1805 bp: Pointer;
1806 oldbp: Pointer;
1807 begin
1808 // get stack depth
1809 Depth:=0;
1810 bp:=get_caller_frame(get_frame);
1811 while bp<>nil do begin
1812 inc(Depth);
1813 oldbp:=bp;
1814 bp:=get_caller_frame(bp);
1815 if (bp<=oldbp) or (bp>(StackBottom + StackLength)) then
1816 bp:=nil;
1817 end;
1818 SetLength(AStack,Depth);
1819 if Depth>0 then begin
1820 Depth:=0;
1821 bp:=get_caller_frame(get_frame);
1822 while bp<>nil do begin
1823 AStack[Depth]:=get_caller_addr(bp);
1824 inc(Depth);
1825 oldbp:=bp;
1826 bp:=get_caller_frame(bp);
1827 if (bp<=oldbp) or (bp>(StackBottom + StackLength)) then
1828 bp:=nil;
1829 end;
1830 end;
1831 end;
1832
CTStackTraceAsStringnull1833 function CTStackTraceAsString(const AStack: TCTStackTracePointers; UseCache: boolean
1834 ): string;
1835 var
1836 i: Integer;
1837 CurAddress: String;
1838 begin
1839 Result:='';
1840 for i:=0 to length(AStack)-1 do begin
1841 CurAddress:=CTGetLineInfo(AStack[i],UseCache);
1842 Result:=Result+CurAddress+LineEnding;
1843 end;
1844 end;
1845
CTGetLineInfonull1846 function CTGetLineInfo(Addr: Pointer; UseCache: boolean): string;
1847 var
1848 ANode: TAVLTreeNode;
1849 Item: PCTLineInfoCacheItem;
1850 begin
1851 if UseCache then begin
1852 if LineInfoCache=nil then
1853 LineInfoCache:=TAVLTree.Create(@CompareCTLineInfoCacheItems);
1854 ANode:=LineInfoCache.FindKey(Addr,@CompareAddrWithCTLineInfoCacheItem);
1855 if ANode=nil then begin
1856 Result:=BackTraceStrFunc(Addr);
1857 New(Item);
1858 Item^.Addr:=Addr;
1859 Item^.Info:=Result;
1860 LineInfoCache.Add(Item);
1861 end else begin
1862 Result:=PCTLineInfoCacheItem(ANode.Data)^.Info;
1863 end;
1864 end else
1865 Result:=BackTraceStrFunc(Addr);
1866 end;
1867
CompareCTLineInfoCacheItemsnull1868 function CompareCTLineInfoCacheItems(Data1, Data2: Pointer): integer;
1869 begin
1870 Result:=LazUtilities.ComparePointers(PCTLineInfoCacheItem(Data1)^.Addr,
1871 PCTLineInfoCacheItem(Data2)^.Addr);
1872 end;
1873
CompareAddrWithCTLineInfoCacheItemnull1874 function CompareAddrWithCTLineInfoCacheItem(Addr, Item: Pointer): integer;
1875 begin
1876 Result:=LazUtilities.ComparePointers(Addr,PCTLineInfoCacheItem(Item)^.Addr);
1877 end;
1878
FileAgeToStrnull1879 function FileAgeToStr(aFileAge: longint): string;
1880 begin
1881 Result:=DateTimeToStr(FileDateToDateTimeDef(aFileAge));
1882 end;
1883
1884 //------------------------------------------------------------------------------
1885
1886 procedure FreeLineInfoCache;
1887 var
1888 ANode: TAVLTreeNode;
1889 Item: PCTLineInfoCacheItem;
1890 begin
1891 if LineInfoCache=nil then exit;
1892 ANode:=LineInfoCache.FindLowest;
1893 while ANode<>nil do begin
1894 Item:=PCTLineInfoCacheItem(ANode.Data);
1895 Dispose(Item);
1896 ANode:=LineInfoCache.FindSuccessor(ANode);
1897 end;
1898 LineInfoCache.Free;
1899 LineInfoCache:=nil;
1900 end;
1901
1902 { TCTMemStats }
1903
TCTMemStats.GetItemsnull1904 function TCTMemStats.GetItems(const Name: string): PtrUint;
1905 var
1906 Node: TAVLTreeNode;
1907 begin
1908 Node:=Tree.FindKey(Pointer(Name),TListSortCompare(@CompareNameWithCTMemStat));
1909 if Node<>nil then
1910 Result:=TCTMemStat(Node.Data).Sum
1911 else
1912 Result:=0;
1913 end;
1914
1915 procedure TCTMemStats.SetItems(const Name: string; const AValue: PtrUint);
1916 var
1917 Node: TAVLTreeNode;
1918 NewStat: TCTMemStat;
1919 begin
1920 Node:=Tree.FindKey(Pointer(Name),TListSortCompare(@CompareNameWithCTMemStat));
1921 if Node<>nil then begin
1922 if AValue<>0 then begin
1923 TCTMemStat(Node.Data).Sum:=AValue;
1924 end else begin
1925 Tree.FreeAndDelete(Node);
1926 end;
1927 end else begin
1928 if AValue<>0 then begin
1929 NewStat:=TCTMemStat.Create;
1930 NewStat.Name:=Name;
1931 NewStat.Sum:=AValue;
1932 Tree.Add(NewStat);
1933 end;
1934 end;
1935 end;
1936
1937 constructor TCTMemStats.Create;
1938 begin
1939 Tree:=TAVLTree.Create(TListSortCompare(@CompareCTMemStat));
1940 end;
1941
1942 destructor TCTMemStats.Destroy;
1943 begin
1944 Tree.FreeAndClear;
1945 FreeAndNil(Tree);
1946 inherited Destroy;
1947 end;
1948
1949 procedure TCTMemStats.Add(const Name: string; Size: PtrUint);
1950 var
1951 Node: TAVLTreeNode;
1952 NewStat: TCTMemStat;
1953 begin
1954 inc(Total,Size);
1955 Node:=Tree.FindKey(Pointer(Name),TListSortCompare(@CompareNameWithCTMemStat));
1956 if Node<>nil then begin
1957 inc(TCTMemStat(Node.Data).Sum,Size);
1958 end else begin
1959 NewStat:=TCTMemStat.Create;
1960 NewStat.Name:=Name;
1961 NewStat.Sum:=Size;
1962 Tree.Add(NewStat);
1963 end;
1964 end;
1965
1966 procedure TCTMemStats.WriteReport;
1967
ByteToStrnull1968 function ByteToStr(b: PtrUint): string;
1969 const
1970 Units = 'KMGTPE';
1971 var
1972 i: Integer;
1973 begin
1974 i:=0;
1975 while b>10240 do begin
1976 inc(i);
1977 b:=b shr 10;
1978 end;
1979 Result:=dbgs(b);
1980 if i>0 then
1981 Result:=Result+Units[i];
1982 end;
1983
1984 var
1985 Node: TAVLTreeNode;
1986 CurStat: TCTMemStat;
1987 begin
1988 DebugLn(['TCTMemStats.WriteReport Stats=',Tree.Count,' Total=',Total,' ',ByteToStr(Total)]);
1989 Node:=Tree.FindLowest;
1990 while Node<>nil do begin
1991 CurStat:=TCTMemStat(Node.Data);
1992 DebugLn([' ',CurStat.Name,'=',CurStat.Sum,' ',ByteToStr(CurStat.Sum)]);
1993 Node:=Tree.FindSuccessor(Node);
1994 end;
1995 end;
1996
1997 initialization
1998 {$IFDEF MEM_CHECK}CheckHeapWrtMemCnt('fileprocs.pas: initialization');{$ENDIF}
1999 FileStateCache:=TFileStateCache.Create;
2000
2001 finalization
2002 FileStateCache.Free;
2003 FileStateCache:=nil;
2004 FreeLineInfoCache;
2005
2006 end.
2007
2008
2009