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 TCodeCache is an AVL Tree of TCodeBuffer. It can load and save files.
25
26 TCodeBuffer is a descendent of TSourceLog and manages a single file.
27 }
28 unit CodeCache;
29
30 {$ifdef fpc}{$mode objfpc}{$endif}{$H+}
31
32 interface
33
34 {$I codetools.inc}
35
36 uses
37 {$IFDEF MEM_CHECK}
38 MemCheck,
39 {$ENDIF}
40 Classes, SysUtils, Laz_Avl_Tree,
41 // Codetools
42 SourceLog, LinkScanner, FileProcs, DirectoryCacher,
43 // LazUtils
44 LazFileUtils, LazFileCache, Laz2_XMLCfg, LazDbgLog;
45
46 const
47 IncludeLinksFileVersion = 2;
48 type
49 TCodeCache = class;
50
51 { TCodeBuffer }
52
53 TCodeBuffer = class(TSourceLog)
54 private
55 FFilename: string;
56 FReferenceCount: integer;
57 FScanner: TLinkScanner;
58 FOnSetScanner: TNotifyEvent;
59 FOnSetFilename: TNotifyEvent;
60 FFileChangeStep: integer;
61 FLoadDateValid: boolean;
62 FLoadDate: longint;
63 FLastIncludedByFile: string;
64 FCodeCache: TCodeCache;
65 FIsVirtual: boolean;
66 FIsDeleted: boolean;
67 FAutoDiskRevertLock: integer;
68 FGlobalWriteLockStepOnLastLoad: integer;
GetLastIncludedByFilenull69 function GetLastIncludedByFile: string;
70 procedure SetFilename(Value: string);
71 procedure SetScanner(const Value: TLinkScanner);
72 procedure SetIsDeleted(const NewValue: boolean);
73 protected
74 procedure DoSourceChanged; override;
75 procedure DecodeLoaded(const AFilename: string;
76 var ASource, ADiskEncoding, AMemEncoding: string); override;
77 procedure EncodeSaving(const AFilename: string; var ASource: string); override;
78 public
79 constructor Create;
80 destructor Destroy; override;
81 procedure Clear; override;
82 procedure ConsistencyCheck;
83 procedure WriteDebugReport;
CalcMemSizenull84 function CalcMemSize: PtrUInt; override;
LoadFromFilenull85 function LoadFromFile(const AFilename: string): boolean; override;
Reloadnull86 function Reload: boolean; // = LoadFromFile(Filename)
Revertnull87 function Revert: boolean; // ignore changes and reload source
SaveToFilenull88 function SaveToFile(const AFilename: string): boolean; override;
Savenull89 function Save: boolean;
FileDateOnDisknull90 function FileDateOnDisk: longint;
FileNeedsUpdatenull91 function FileNeedsUpdate(IgnoreModifiedFlag: Boolean = False): boolean; // needs loading
FileOnDiskNeedsUpdatenull92 function FileOnDiskNeedsUpdate: boolean;
FileOnDiskHasChangednull93 function FileOnDiskHasChanged(IgnoreModifiedFlag: Boolean = False): boolean;
FileOnDiskIsEqualnull94 function FileOnDiskIsEqual: boolean;
AutoRevertFromDisknull95 function AutoRevertFromDisk: boolean;
96 procedure LockAutoDiskRevert;
97 procedure UnlockAutoDiskRevert;
98 procedure IncrementRefCount;
99 procedure ReleaseRefCount;
100 procedure MakeFileDateValid;
101 procedure InvalidateLoadDate;
SourceIsTextnull102 function SourceIsText: boolean;
103 public
104 property CodeCache: TCodeCache read FCodeCache write FCodeCache;
105 property Filename: string read FFilename write SetFilename;
106 property GlobalWriteLockStepOnLastLoad: integer
107 read FGlobalWriteLockStepOnLastLoad write FGlobalWriteLockStepOnLastLoad;
108 property IsDeleted: boolean read FIsDeleted write SetIsDeleted;
109 property IsVirtual: boolean read FIsVirtual;
110 property LastIncludedByFile: string read GetLastIncludedByFile
111 write FLastIncludedByFile;
112 property LoadDate: longint read FLoadDate;
113 property LoadDateValid: boolean read FLoadDateValid;
114 property FileChangeStep: integer read FFileChangeStep; // last loaded/saved changestep, only valid if LoadDateValid=true
115 property OnSetFilename: TNotifyEvent read FOnSetFilename write FOnSetFilename;
116 property OnSetScanner: TNotifyEvent read FOnSetScanner write FOnSetScanner;
117 property Scanner: TLinkScanner read FScanner write SetScanner;
118 property ReferenceCount: integer read FReferenceCount;
119 end;
120
121 { TIncludedByLink }
122
123 TIncludedByLink = class
124 public
125 IncludeFilename: string;
126 IncludedByFile: string;
127 LastTimeUsed: TDateTime;
128 constructor Create(const AnIncludeFilename,AnIncludedByFile: string;
129 ALastTimeUsed: TDateTime);
CalcMemSizenull130 function CalcMemSize: PtrUInt;
131 end;
132
133 TOnCodeCacheDecodeLoaded = procedure(Code: TCodeBuffer; const Filename: string;
134 var Source, DiskEncoding, MemEncoding: string) of object;
135 TOnCodeCacheEncodeSaving = procedure(Code: TCodeBuffer;
136 const Filename: string; var Source: string) of object;
137
138 { TCodeCache }
139
140 TCodeCache = class(TObject)
141 private
142 FChangeStamp: int64;
143 FDefaultEncoding: string;
144 FDirectoryCachePool: TCTDirectoryCachePool;
145 FItems: TAVLTree; // tree of TCodeBuffer
146 FIncludeLinks: TAVLTree; // tree of TIncludedByLink
147 FDestroying: boolean;
148 FExpirationTimeInDays: integer;
149 FGlobalWriteLockIsSet: boolean;
150 FGlobalWriteLockStep: integer;
151 fLastIncludeLinkFile: string;
152 fLastIncludeLinkFileAge: integer;
153 fLastIncludeLinkFileValid: boolean;
154 fLastIncludeLinkFileChangeStep: integer;
155 fChangeStep: integer;
156 FOnDecodeLoaded: TOnCodeCacheDecodeLoaded;
157 FOnEncodeSaving: TOnCodeCacheEncodeSaving;
FindIncludeLinknull158 function FindIncludeLink(const IncludeFilename: string): string;
FindIncludeLinkNodenull159 function FindIncludeLinkNode(const IncludeFilename: string): TIncludedByLink;
FindIncludeLinkAVLNodenull160 function FindIncludeLinkAVLNode(const IncludeFilename: string): TAVLTreeNode;
OnScannerCheckFileOnDisknull161 function OnScannerCheckFileOnDisk(Code: pointer): boolean; // true if code changed
OnScannerGetFileNamenull162 function OnScannerGetFileName(Sender: TObject; Code: pointer): string;
OnScannerGetSourcenull163 function OnScannerGetSource(Sender: TObject; Code: pointer): TSourceLog;
OnScannerLoadSourcenull164 function OnScannerLoadSource(Sender: TObject; const AFilename: string;
165 OnlyIfExists: boolean): pointer;
166 procedure OnScannerDeleteSource(Sender: TObject; Code: Pointer;
167 Pos, Len: integer);
168 procedure OnScannerGetSourceStatus(Sender: TObject; Code:Pointer;
169 var ReadOnly: boolean);
170 procedure OnScannerIncludeCode(ParentCode, IncludeCode: pointer);
171 procedure UpdateIncludeLinks;
172 procedure IncreaseChangeStep;
173 procedure DecodeLoaded(Code: TCodeBuffer; const AFilename: string;
174 var ASource, ADiskEncoding, AMemEncoding: string);
175 procedure EncodeSaving(Code: TCodeBuffer;
176 const AFilename: string; var ASource: string);
177 public
178 constructor Create;
179 destructor Destroy; override;
180 procedure ConsistencyCheck;
Countnull181 function Count: integer;
CreateFilenull182 function CreateFile(const AFilename: string): TCodeBuffer;
FindFilenull183 function FindFile(AFilename: string): TCodeBuffer;
LastIncludedByFilenull184 function LastIncludedByFile(const IncludeFilename: string): string;
LoadFilenull185 function LoadFile(AFilename: string): TCodeBuffer;
186 procedure RemoveCodeBuffer(Buffer: TCodeBuffer);
187 procedure LoadIncludeLinksDataFromList(List: TStrings);
LoadIncludeLinksFromFilenull188 function LoadIncludeLinksFromFile(const AFilename: string): boolean;
LoadIncludeLinksFromXMLnull189 function LoadIncludeLinksFromXML(XMLConfig: TXMLConfig;
190 const XMLPath: string): boolean;
SaveBufferAsnull191 function SaveBufferAs(OldBuffer: TCodeBuffer; const AFilename: string;
192 out NewBuffer: TCodeBuffer): boolean;
193 procedure SaveIncludeLinksDataToList(List: TStrings);
SaveIncludeLinksToFilenull194 function SaveIncludeLinksToFile(const AFilename: string;
195 OnlyIfChanged: boolean): boolean;
SaveIncludeLinksToXMLnull196 function SaveIncludeLinksToXML(XMLConfig: TXMLConfig;
197 const XMLPath: string): boolean;
198 procedure Clear;
199 procedure ClearAllSourceLogEntries;
200 procedure ClearIncludedByEntry(const IncludeFilename: string);
201 procedure ClearAllModified;
202 procedure OnBufferSetFileName(Sender: TCodeBuffer;
203 const OldFilename: string);
204 procedure OnBufferSetScanner(Sender: TCodeBuffer);
205 procedure WriteAllFileNames;
206 procedure WriteDebugReport;
CalcMemSizenull207 function CalcMemSize(Stats: TCTMemStats): PtrUInt;
208 procedure IncreaseChangeStamp; inline;
209 public
210 property ExpirationTimeInDays: integer
211 read FExpirationTimeInDays write FExpirationTimeInDays;
212 property GlobalWriteLockIsSet: boolean
213 read FGlobalWriteLockIsSet write FGlobalWriteLockIsSet;
214 property GlobalWriteLockStep: integer
215 read FGlobalWriteLockStep write FGlobalWriteLockStep;
216 property OnDecodeLoaded: TOnCodeCacheDecodeLoaded read FOnDecodeLoaded
217 write FOnDecodeLoaded;
218 property OnEncodeSaving: TOnCodeCacheEncodeSaving read FOnEncodeSaving
219 write FOnEncodeSaving;
220 property DefaultEncoding: string read FDefaultEncoding write FDefaultEncoding;
221 property ChangeStamp: int64 read FChangeStamp;
222 property DirectoryCachePool: TCTDirectoryCachePool read FDirectoryCachePool
223 write FDirectoryCachePool;
224 end;
225
226 type
227 TCodePosition = packed record
228 Code: TCodeBuffer;
229 P: integer;
230 end;
231 PCodePosition = ^TCodePosition;
232
233 TCodeXYPosition = packed record
234 Code: TCodeBuffer;
235 X, Y: integer;
236 end;
237 PCodeXYPosition = ^TCodeXYPosition;
238 const
239 CleanCodeXYPosition: TCodeXYPosition = (Code:nil; X:0; Y:0);
240
241 type
242 { TCodeXYPositions - a list of PCodeXYPosition }
243
244 TCodeXYPositions = class
245 private
246 FItems: TFPList; // list of PCodeXYPosition, can be nil
GetCaretsXYnull247 function GetCaretsXY(Index: integer): TPoint;
GetCodesnull248 function GetCodes(Index: integer): TCodeBuffer;
GetItemsnull249 function GetItems(Index: integer): PCodeXYPosition;
250 procedure SetCaretsXY(Index: integer; const AValue: TPoint);
251 procedure SetCodes(Index: integer; const AValue: TCodeBuffer);
252 procedure SetItems(Index: integer; const AValue: PCodeXYPosition);
253 public
254 constructor Create;
255 destructor Destroy; override;
256 procedure Clear;
Addnull257 function Add(const Position: TCodeXYPosition): integer;
Addnull258 function Add(X,Y: integer; Code: TCodeBuffer): integer;
259 procedure Assign(Source: TCodeXYPositions);
IsEqualnull260 function IsEqual(Source: TCodeXYPositions): boolean;
Countnull261 function Count: integer;
262 procedure Delete(Index: integer);
CreateCopynull263 function CreateCopy: TCodeXYPositions;
CalcMemSizenull264 function CalcMemSize: PtrUint;
265 public
266 property Items[Index: integer]: PCodeXYPosition
267 read GetItems write SetItems; default;
268 property CaretsXY[Index: integer]: TPoint read GetCaretsXY write SetCaretsXY;
269 property Codes[Index: integer]: TCodeBuffer read GetCodes write SetCodes;
270 end;
271
272
CompareCodeBuffersnull273 function CompareCodeBuffers(NodeData1, NodeData2: pointer): integer;
CompareAnsistringWithCodeBuffernull274 function CompareAnsistringWithCodeBuffer(AString, ABuffer: pointer): integer;
CompareIncludedByLinknull275 function CompareIncludedByLink(NodeData1, NodeData2: pointer): integer;
CompareAnsiStringWithIncludedByLinknull276 function CompareAnsiStringWithIncludedByLink(Key, Data: pointer): integer;
277
CodePositionnull278 function CodePosition(P: integer; Code: TCodeBuffer): TCodePosition;
CodeXYPositionnull279 function CodeXYPosition(X, Y: integer; Code: TCodeBuffer): TCodeXYPosition;
CompareCodeXYPositionsnull280 function CompareCodeXYPositions(Pos1, Pos2: PCodeXYPosition): integer;
281
CompareCodePositionsnull282 function CompareCodePositions(Pos1, Pos2: PCodePosition): integer;
283
284 procedure AddCodePosition(var ListOfPCodeXYPosition: TFPList;
285 const NewCodePos: TCodeXYPosition);
IndexOfCodePositionnull286 function IndexOfCodePosition(var ListOfPCodeXYPosition: TFPList;
287 const APosition: PCodeXYPosition): integer;
288 procedure FreeListOfPCodeXYPosition(ListOfPCodeXYPosition: TFPList);
289
CreateTreeOfPCodeXYPositionnull290 function CreateTreeOfPCodeXYPosition: TAVLTree;
291 procedure AddCodePosition(var TreeOfPCodeXYPosition: TAVLTree;
292 const NewCodePos: TCodeXYPosition);
293 procedure FreeTreeOfPCodeXYPosition(TreeOfPCodeXYPosition: TAVLTree);
294 procedure AddListToTreeOfPCodeXYPosition(SrcList: TFPList;
295 DestTree: TAVLTree; ClearList, CreateCopies: boolean);
ListOfPCodeXYPositionToStrnull296 function ListOfPCodeXYPositionToStr(const ListOfPCodeXYPosition: TFPList): string;
297
Dbgsnull298 function Dbgs(const p: TCodeXYPosition): string; overload;
Dbgsnull299 function Dbgs(const p: TCodePosition): string; overload;
300
301 implementation
302
303
CompareCodeBuffersnull304 function CompareCodeBuffers(NodeData1, NodeData2: pointer): integer;
305 var
306 CodeBuf1: TCodeBuffer absolute NodeData1;
307 CodeBuf2: TCodeBuffer absolute NodeData2;
308 begin
309 Result:=CompareFilenames(CodeBuf1.Filename,CodeBuf2.Filename);
310 end;
311
CompareAnsistringWithCodeBuffernull312 function CompareAnsistringWithCodeBuffer(AString, ABuffer: pointer): integer;
313 var
314 Code: TCodeBuffer absolute ABuffer;
315 Filename: String;
316 begin
317 Filename:=AnsiString(AString);
318 Result:=CompareFilenames(Filename,Code.Filename);
319 end;
320
CompareIncludedByLinknull321 function CompareIncludedByLink(NodeData1, NodeData2: pointer): integer;
322 var
323 Link1: TIncludedByLink absolute NodeData1;
324 Link2: TIncludedByLink absolute NodeData2;
325 begin
326 Result:=CompareFilenames(Link1.IncludeFilename,Link2.IncludeFilename);
327 end;
328
CompareAnsiStringWithIncludedByLinknull329 function CompareAnsiStringWithIncludedByLink(Key, Data: pointer): integer;
330 begin
331 Result:=CompareFilenames(AnsiString(Key),
332 TIncludedByLink(Data).IncludeFilename);
333 end;
334
CodePositionnull335 function CodePosition(P: integer; Code: TCodeBuffer): TCodePosition;
336 begin
337 Result.P:=P;
338 Result.Code:=Code;
339 end;
340
CodeXYPositionnull341 function CodeXYPosition(X, Y: integer; Code: TCodeBuffer): TCodeXYPosition;
342 begin
343 Result.X:=X;
344 Result.Y:=Y;
345 Result.Code:=Code;
346 end;
347
CompareCodeXYPositionsnull348 function CompareCodeXYPositions(Pos1, Pos2: PCodeXYPosition): integer;
349 begin
350 if Pointer(Pos1^.Code)>Pointer(Pos2^.Code) then Result:=1
351 else if Pointer(Pos1^.Code)<Pointer(Pos2^.Code) then Result:=-1
352 else if Pos1^.Y<Pos2^.Y then Result:=1
353 else if Pos1^.Y>Pos2^.Y then Result:=-1
354 else if Pos1^.X<Pos2^.X then Result:=1
355 else if Pos1^.Y<Pos2^.Y then Result:=-1
356 else Result:=0;
357 end;
358
CompareCodePositionsnull359 function CompareCodePositions(Pos1, Pos2: PCodePosition): integer;
360 begin
361 if Pointer(Pos1^.Code)>Pointer(Pos2^.Code) then Result:=1
362 else if Pointer(Pos1^.Code)<Pointer(Pos2^.Code) then Result:=-1
363 else if Pos1^.P<Pos2^.P then Result:=1
364 else if Pos1^.P>Pos2^.P then Result:=-1
365 else Result:=0;
366 end;
367
368 procedure AddCodePosition(var ListOfPCodeXYPosition: TFPList;
369 const NewCodePos: TCodeXYPosition);
370 var
371 AddCodePos: PCodeXYPosition;
372 begin
373 if ListOfPCodeXYPosition=nil then ListOfPCodeXYPosition:=TFPList.Create;
374 New(AddCodePos);
375 AddCodePos^:=NewCodePos;
376 ListOfPCodeXYPosition.Add(AddCodePos);
377 end;
378
IndexOfCodePositionnull379 function IndexOfCodePosition(var ListOfPCodeXYPosition: TFPList;
380 const APosition: PCodeXYPosition): integer;
381 begin
382 if ListOfPCodeXYPosition=nil then
383 Result:=-1
384 else begin
385 Result:=ListOfPCodeXYPosition.Count-1;
386 while (Result>=0)
387 and (CompareCodeXYPositions(APosition,
388 PCodeXYPosition(ListOfPCodeXYPosition[Result]))<>0)
389 do
390 dec(Result);
391 end;
392 end;
393
394 procedure FreeListOfPCodeXYPosition(ListOfPCodeXYPosition: TFPList);
395 var
396 CurCodePos: PCodeXYPosition;
397 i: Integer;
398 begin
399 if ListOfPCodeXYPosition=nil then exit;
400 for i:=0 to ListOfPCodeXYPosition.Count-1 do begin
401 CurCodePos:=PCodeXYPosition(ListOfPCodeXYPosition[i]);
402 Dispose(CurCodePos);
403 end;
404 ListOfPCodeXYPosition.Free;
405 end;
406
CreateTreeOfPCodeXYPositionnull407 function CreateTreeOfPCodeXYPosition: TAVLTree;
408 begin
409 Result:=TAVLTree.Create(TListSortCompare(@CompareCodeXYPositions));
410 end;
411
412 procedure AddCodePosition(var TreeOfPCodeXYPosition: TAVLTree;
413 const NewCodePos: TCodeXYPosition);
414 var
415 AddCodePos: PCodeXYPosition;
416 begin
417 if TreeOfPCodeXYPosition=nil then
418 TreeOfPCodeXYPosition:=TAVLTree.Create(TListSortCompare(@CompareCodeXYPositions));
419 New(AddCodePos);
420 AddCodePos^:=NewCodePos;
421 TreeOfPCodeXYPosition.Add(AddCodePos);
422 end;
423
424 procedure FreeTreeOfPCodeXYPosition(TreeOfPCodeXYPosition: TAVLTree);
425 var
426 ANode: TAVLTreeNode;
427 CursorPos: PCodeXYPosition;
428 begin
429 if TreeOfPCodeXYPosition=nil then exit;
430 ANode:=TreeOfPCodeXYPosition.FindLowest;
431 while ANode<>nil do begin
432 CursorPos:=PCodeXYPosition(ANode.Data);
433 if CursorPos<>nil then
434 Dispose(CursorPos);
435 ANode:=TreeOfPCodeXYPosition.FindSuccessor(ANode);
436 end;
437 TreeOfPCodeXYPosition.Free;
438 end;
439
440 procedure AddListToTreeOfPCodeXYPosition(SrcList: TFPList; DestTree: TAVLTree;
441 ClearList, CreateCopies: boolean);
442 var
443 i: Integer;
444 CodePos: PCodeXYPosition;
445 NewCodePos: PCodeXYPosition;
446 begin
447 if SrcList=nil then exit;
448 for i:=SrcList.Count-1 downto 0 do begin
449 CodePos:=PCodeXYPosition(SrcList[i]);
450 if DestTree.Find(CodePos)=nil then begin
451 // new position -> add
452 if CreateCopies and (not ClearList) then begin
453 // list items should be kept and copies should be added to the tree
454 New(NewCodePos);
455 NewCodePos^:=CodePos^;
456 end else
457 NewCodePos:=CodePos;
458 DestTree.Add(NewCodePos);
459 end else if ClearList then begin
460 // position already exists and items should be deleted
461 Dispose(CodePos);
462 end;
463 end;
464 if ClearList then
465 SrcList.Clear;
466 end;
467
ListOfPCodeXYPositionToStrnull468 function ListOfPCodeXYPositionToStr(const ListOfPCodeXYPosition: TFPList
469 ): string;
470 var
471 p: TCodeXYPosition;
472 i: Integer;
473 begin
474 if ListOfPCodeXYPosition=nil then
475 Result:='nil'
476 else begin
477 Result:='';
478 for i:=0 to ListOfPCodeXYPosition.Count-1 do begin
479 p:=PCodeXYPosition(ListOfPCodeXYPosition[i])^;
480 Result:=Result+' '+Dbgs(p)+LineEnding;
481 end;
482 end;
483 end;
484
Dbgsnull485 function Dbgs(const p: TCodeXYPosition): string;
486 begin
487 if p.Code=nil then
488 Result:='(none)'
489 else
490 Result:=p.Code.Filename+'(y='+dbgs(p.y)+',x='+dbgs(p.x)+')';
491 end;
492
Dbgsnull493 function Dbgs(const p: TCodePosition): string;
494 var
495 CodeXYPosition: TCodeXYPosition;
496 begin
497 FillChar(CodeXYPosition{%H-},SizeOf(TCodeXYPosition),0);
498 CodeXYPosition.Code:=p.Code;
499 if CodeXYPosition.Code<>nil then begin
500 CodeXYPosition.Code.AbsoluteToLineCol(p.P,CodeXYPosition.Y,CodeXYPosition.X);
501 end;
502 Result:=Dbgs(CodeXYPosition);
503 end;
504
505 { TCodeCache }
506
507 procedure TCodeCache.Clear;
508 begin
509 FItems.FreeAndClear;
510 end;
511
512 procedure TCodeCache.ClearAllSourceLogEntries;
513 var
514 ANode: TAVLTreeNode;
515 begin
516 ANode:=FItems.FindLowest;
517 while ANode<>nil do begin
518 TCodeBuffer(ANode.Data).ClearEntries;
519 ANode:=FItems.FindSuccessor(ANode);
520 end;
521 end;
522
523 procedure TCodeCache.ClearIncludedByEntry(const IncludeFilename: string);
524 var Code: TCodeBuffer;
525 Node: TAVLTreeNode;
526 begin
527 Code:=FindFile(IncludeFilename);
528 if Code<>nil then
529 Code.LastIncludedByFile:=''
530 else begin
531 Node:=FindIncludeLinkAVLNode(IncludeFilename);
532 if Node<>nil then
533 FIncludeLinks.FreeAndDelete(Node);
534 end;
535 end;
536
537 procedure TCodeCache.ClearAllModified;
538 var
539 Code: TCodeBuffer;
540 ANode: TAVLTreeNode;
541 begin
542 ANode:=FItems.FindLowest;
543 while ANode<>nil do begin
544 Code:=TCodeBuffer(ANode.Data);
545 if Code.Modified then
546 Code.Clear;
547 ANode:=FItems.FindSuccessor(ANode);
548 end;
549 end;
550
TCodeCache.Countnull551 function TCodeCache.Count: integer;
552 begin
553 Result:=FItems.Count;
554 end;
555
556 constructor TCodeCache.Create;
557 begin
558 inherited Create;
559 FItems:=TAVLTree.Create(@CompareCodeBuffers);
560 FIncludeLinks:=TAVLTree.Create(@CompareIncludedByLink);
561 end;
562
563 destructor TCodeCache.Destroy;
564 begin
565 FDestroying:=true;
566 Clear;
567 FIncludeLinks.FreeAndClear;
568 FIncludeLinks.Free;
569 FItems.Free;
570 inherited Destroy;
571 end;
572
TCodeCache.FindFilenull573 function TCodeCache.FindFile(AFilename: string): TCodeBuffer;
574 var c: integer;
575 ANode: TAVLTreeNode;
576 begin
577 AFilename:=TrimFilename(AFilename);
578 ANode:=FItems.Root;
579 while ANode<>nil do begin
580 Result:=TCodeBuffer(ANode.Data);
581 c:=CompareFilenames(AFilename,Result.Filename);
582 {$IFDEF CTDEBUG}
583 if c=0 then DebugLn(' File found !!! ',Result.Filename);
584 {$ENDIF}
585 if c<0 then ANode:=ANode.Left
586 else if c>0 then ANode:=ANode.Right
587 else exit;
588 end;
589 Result:=nil;
590 end;
591
LoadFilenull592 function TCodeCache.LoadFile(AFilename: string): TCodeBuffer;
593 var
594 DiskFilename: String;
595
596 procedure FindDiskFilenameInconsistent;
597 var
598 s: String;
599 begin
600 s:='[TCodeCache.LoadFile] Inconsistency found: AFilename="'+AFilename+'" FindDiskFilename="'+DiskFilename+'"';
601 s:=s+' CompareFilenames='+dbgs(CompareFilenames(AFilename,DiskFilename));
602 raise Exception.Create(s);
603 end;
604
605 begin
606 AFilename:=TrimFilename(AFilename);
607 Result:=FindFile(AFilename);
608 if FilenameIsAbsolute(AFilename) then begin
609 if Result=nil then begin
610 // load new buffer
611 if (not FileExistsCached(AFilename)) then exit;
612 if DirectoryCachePool<>nil then
613 DiskFilename:=DirectoryCachePool.FindDiskFilename(AFilename)
614 else
615 DiskFilename:=FindDiskFilename(AFilename);
616 if FindFile(DiskFilename)<>nil then
617 FindDiskFilenameInconsistent;
618 Result:=TCodeBuffer.Create;
619 Result.Filename:=DiskFilename;
620 Result.FCodeCache:=Self;
621 if (not Result.LoadFromFile(Result.Filename)) then begin
622 Result.FCodeCache:=nil;
623 Result.Free;
624 Result:=nil;
625 exit;
626 end;
627 FItems.Add(Result);
628 with Result do begin
629 LastIncludedByFile:=FindIncludeLink(Result.Filename);
630 ReadOnly:=not FileIsWritable(Result.Filename);
631 end;
632 end else if Result.IsDeleted then begin
633 // file in cache, but marked as deleted -> load from disk
634 if (not FileExistsCached(AFilename))
635 or (not Result.LoadFromFile(AFilename)) then
636 begin
637 Result:=nil;
638 end;
639 end;
640 end else begin
641 // virtual file
642 if (Result <> nil) and Result.IsDeleted then begin
643 // file in cache, but marked as deleted -> no virtual file
644 Result:=nil;
645 end;
646 end;
647 end;
648
649 procedure TCodeCache.RemoveCodeBuffer(Buffer: TCodeBuffer);
650 begin
651 if not FDestroying then
652 FItems.Remove(Buffer);
653 end;
654
655 procedure TCodeCache.LoadIncludeLinksDataFromList(List: TStrings);
656 { First line is the base date as DateToCfgStr
657
658 The following lines are compressed. Each line starting with a number of
659 characters to use from the previous line. Then a colon and the rest of the
660 line.
661 Each include link has two lines, the first is the IncludeFilename, the
662 second the the IncludedByFile plus semicolon and the age in days.
663 }
664 var
665 BaseDate: TDateTime;
666 LastLine: string;
667 Index: integer;
668
NextLinenull669 function NextLine: string;
670 begin
671 // skip empty lines
672 repeat
673 if Index>=List.Count then begin
674 Result:='';
675 exit;
676 end;
677 Result:=List[Index];
678 inc(Index);
679 until Result<>'';
680 end;
681
NextUncompressedLinenull682 function NextUncompressedLine: string;
683 var
684 p: Integer;
685 Same: Integer;
686 begin
687 Result:=NextLine;
688 p:=1;
689 Same:=0;
690 while (p<=length(Result)) and (Result[p] in ['0'..'9']) do begin
691 Same:=Same*10+ord(Result[p])-ord('0');
692 inc(p);
693 end;
694 while (p<=length(Result)) and (Result[p]<>':') do inc(p);
695 Result:=copy(LastLine,1,Same)+copy(Result,p+1,length(Result));
696 LastLine:=Result;
697 //debugln(['NextUncompressedLine "',Result,'"']);
698 end;
699
700 var
701 IncludeFilename: String;
702 IncludedByFile: String;
703 p: Longint;
704 Days: LongInt;
705 Link: TIncludedByLink;
706 LastTimeUsed: TDateTime;
707 CurrDate: TDateTime;
708 begin
709 FIncludeLinks.FreeAndClear;
710 Index:=0;
711 CurrDate:=Date;
712 LastLine:='';
713 if not CfgStrToDate(NextLine,BaseDate) then BaseDate:=Date;
714 repeat
715 IncludeFilename:=TrimFilename(NextUncompressedLine);
716 if IncludeFilename='' then exit;
717 IncludedByFile:=TrimFilename(NextUncompressedLine);
718 if IncludedByFile='' then begin
719 debugln(['TCodeCache.LoadIncludeLinksDataFromList missing IncludedByFile: IncludeFilename=',IncludeFilename,' line=',Index]);
720 exit;
721 end;
722 if not FilenameIsAbsolute(IncludedByFile) then begin
723 debugln(['TCodeCache.LoadIncludeLinksDataFromList ignoring relative IncludedByFile: IncludeFilename=',IncludeFilename,' line=',Index]);
724 exit;
725 end;
726 p:=System.Pos(';',IncludedByFile);
727 if p<1 then begin
728 debugln(['TCodeCache.LoadIncludeLinksDataFromList missing age in IncludedByFile line: ',IncludedByFile,' line=',Index]);
729 exit;
730 end;
731 Days:=StrToIntDef(copy(IncludedByFile,p+1,length(IncludedByFile)),0);
732 IncludedByFile:=copy(IncludedByFile,1,p-1);
733 LastTimeUsed:=BaseDate-Days;
734 //debugln(['TCodeCache.LoadIncludeLinksDataFromList ',IncludeFilename,' ',IncludedByFile,' ',LastTimeUsed]);
735 if (FExpirationTimeInDays<=0)
736 or (CurrDate-LastTimeUsed<=FExpirationTimeInDays) then begin
737 Link:=FindIncludeLinkNode(IncludeFilename);
738 if Link=nil then begin
739 Link:=TIncludedByLink.Create(IncludeFilename,IncludedByFile,
740 BaseDate-Days);
741 FIncludeLinks.Add(Link);
742 end else if Link.LastTimeUsed<=LastTimeUsed then begin
743 Link.IncludedByFile:=IncludedByFile;
744 Link.LastTimeUsed:=LastTimeUsed;
745 end;
746 end;
747 until false;
748 end;
749
CreateFilenull750 function TCodeCache.CreateFile(const AFilename: string): TCodeBuffer;
751 begin
752 Result:=FindFile(AFileName);
753 if Result<>nil then begin
754 Result.Clear;
755 end else begin
756 Result:=TCodeBuffer.Create;
757 Result.FileName:=AFileName;
758 FItems.Add(Result);
759 Result.FCodeCache:=Self;// must be called after FileName:=
760 Result.LastIncludedByFile:=FindIncludeLink(Result.Filename);
761 end;
762 Result.DiskEncoding:=DefaultEncoding;
763 Result.MemEncoding:=Result.DiskEncoding;
764 end;
765
SaveBufferAsnull766 function TCodeCache.SaveBufferAs(OldBuffer: TCodeBuffer;
767 const AFilename: string; out NewBuffer: TCodeBuffer): boolean;
768 begin
769 //DebugLn('[TCodeCache.SaveBufferAs] ',OldBuffer.Filename,' ',AFilename);
770 if (OldBuffer=nil) then begin
771 NewBuffer:=nil;
772 Result:=false;
773 exit;
774 end;
775 if OldBuffer.Filename=AFilename then begin // do not use CompareFilenames() !
776 NewBuffer:=OldBuffer;
777 Result:=OldBuffer.Save;
778 exit;
779 end;
780 NewBuffer:=FindFile(AFilename);
781 //DebugLn('[TCodeCache.SaveBufferAs] B ',NewBuffer=nil);
782 //WriteAllFileNames;
783 if NewBuffer=nil then begin
784 NewBuffer:=TCodeBuffer.Create;
785 NewBuffer.FileName:=AFilename;
786 NewBuffer.Source:=OldBuffer.Source;
787 NewBuffer.DiskEncoding:=NewBuffer.DiskEncoding;
788 NewBuffer.MemEncoding:=NewBuffer.MemEncoding;
789 NewBuffer.FCodeCache:=Self;
790 Result:=NewBuffer.IsVirtual or NewBuffer.Save;
791 //DebugLn('[TCodeCache.SaveBufferAs] C ',Result,' ',NewBuffer.IsVirtual);
792 if not Result then begin
793 NewBuffer.FCodeCache:=nil;
794 NewBuffer.Free;
795 NewBuffer:=nil;
796 exit;
797 end;
798 FItems.Add(NewBuffer);
799 NewBuffer.LastIncludedByFile:=FindIncludeLink(AFilename);
800 end else begin
801 NewBuffer.Source:=OldBuffer.Source;
802 NewBuffer.IsDeleted:=false;
803 Result:=NewBuffer.Save;
804 end;
805 if not Result then exit;
806 if (OldBuffer<>NewBuffer) then begin
807 OldBuffer.IsDeleted:=true;
808 OldBuffer.Source:='';
809 end;
810 end;
811
812 procedure TCodeCache.SaveIncludeLinksDataToList(List: TStrings);
813 { First line is the base date as DateToCfgStr
814
815 The following lines are compressed. Each line starting with a number of
816 characters to use from the previous line. Then a colon and the rest of the
817 line.
818 Each include link has two lines, the first is the IncludeFilename, the
819 second the the IncludedByFile plus semicolon and the age in days.
820 }
821 var
822 LastLine: String;
823 CurrDate: TDateTime;
824 ExpirationTime: TDateTime;
825 Node: TAVLTreeNode;
826
827 procedure AddLine(Line: string);
828 var
829 p1: PChar;
830 p2: PChar;
831 p: PtrUint;
832 begin
833 p1:=PChar(Line);
834 p2:=PChar(LastLine);
835 while (p1^=p2^) and (p1^<>#0) do begin
836 inc(p1);
837 inc(p2);
838 end;
839 p:=p1-PChar(Line);
840 List.Add(IntToStr(p)+':'+copy(Line,p+1,length(Line)));
841 LastLine:=Line;
842 end;
843
844 var
845 ALink: TIncludedByLink;
846 DiffTime: TDateTime;
847 begin
848 UpdateIncludeLinks;
849 if FIncludeLinks.Count=0 then exit;
850 ExpirationTime:=TDateTime(FExpirationTimeInDays);
851 LastLine:='';
852 CurrDate:=Date;
853 List.Add(DateToCfgStr(CurrDate));
854 Node:=FIncludeLinks.FindLowest;
855 while Node<>nil do begin
856 ALink:=TIncludedByLink(Node.Data);
857 DiffTime:=CurrDate-ALink.LastTimeUsed;
858 if (FExpirationTimeInDays<=0) or (DiffTime<ExpirationTime) then begin
859 AddLine(ALink.IncludeFilename);
860 AddLine(ALink.IncludedByFile+';'+IntToStr(round(CurrDate-ALink.LastTimeUsed)));
861 end;
862 Node:=FIncludeLinks.FindSuccessor(Node);
863 end;
864 end;
865
LastIncludedByFilenull866 function TCodeCache.LastIncludedByFile(const IncludeFilename: string): string;
867 var Code: TCodeBuffer;
868 begin
869 Code:=FindFile(IncludeFilename);
870 if Code<>nil then
871 Result:=Code.LastIncludedByFile
872 else begin
873 Result:=FindIncludeLink(IncludeFilename);
874 end;
875 end;
876
877 procedure TCodeCache.OnBufferSetScanner(Sender: TCodeBuffer);
878 var
879 s: TLinkScanner;
880 begin
881 s:=Sender.Scanner;
882 if s=nil then exit;
883 s.OnGetSource:=@Self.OnScannerGetSource;
884 s.OnGetFileName:=@Self.OnScannerGetFileName;
885 s.OnLoadSource:=@Self.OnScannerLoadSource;
886 s.OnCheckFileOnDisk:=@Self.OnScannerCheckFileOnDisk;
887 s.OnIncludeCode:=@Self.OnScannerIncludeCode;
888 s.OnGetSourceStatus:=@Self.OnScannerGetSourceStatus;
889 s.OnDeleteSource:=@Self.OnScannerDeleteSource;
890 end;
891
892 procedure TCodeCache.OnBufferSetFileName(Sender: TCodeBuffer;
893 const OldFilename: string);
894 begin
895 FItems.Delete(FItems.Find(FindFile(OldFilename)));
896 if FindFile(Sender.Filename)=nil then
897 FItems.Add(Sender);
898 end;
899
TCodeCache.OnScannerGetFileNamenull900 function TCodeCache.OnScannerGetFileName(Sender: TObject;
901 Code: pointer): string;
902 begin
903 if (Code<>nil) then
904 Result:=TCodeBuffer(Code).Filename
905 else
906 raise Exception.Create('[TCodeCache.OnScannerGetFilename] Code=nil');
907 end;
908
OnScannerGetSourcenull909 function TCodeCache.OnScannerGetSource(Sender: TObject;
910 Code: pointer): TSourceLog;
911 begin
912 //DebugLn('[TCodeCache.OnScannerGetSource] A ',DbgS(Code),'/',Count);
913 if (Code<>nil) then
914 Result:=TSourceLog(Code)
915 else
916 raise Exception.Create('[TCodeCache.OnScannerGetFilename] Code=nil');
917 end;
918
TCodeCache.OnScannerLoadSourcenull919 function TCodeCache.OnScannerLoadSource(Sender: TObject;
920 const AFilename: string; OnlyIfExists: boolean): pointer;
921 begin
922 if OnlyIfExists then begin
923 Result:=FindFile(AFilename);
924 if (Result=nil)
925 and (FilenameIsAbsolute(AFilename) and FileExistsCached(AFilename)) then
926 Result:=LoadFile(AFilename);
927 end else
928 Result:=LoadFile(AFilename);
929 //debugln(['TCodeCache.OnScannerLoadSource ']);
930 if Result<>nil then
931 OnScannerCheckFileOnDisk(Result);
932 end;
933
TCodeCache.OnScannerCheckFileOnDisknull934 function TCodeCache.OnScannerCheckFileOnDisk(Code: pointer): boolean;
935 var Buf: TCodeBuffer;
936 begin
937 Result:=false;
938 Buf:=TCodeBuffer(Code);
939 //DebugLn(['OnScannerCheckFileOnDisk A ',Buf.Filename,' AutoRev=',Buf.AutoRevertFromDisk,' WriteLock=',GlobalWriteLockIsSet,' DiskChg=',Buf.FileOnDiskHasChanged,' IsDeleted=',Buf.IsDeleted]);
940 if Buf.AutoRevertFromDisk or Buf.IsDeleted then begin
941 if GlobalWriteLockIsSet then begin
942 if GlobalWriteLockStep<>Buf.GlobalWriteLockStepOnLastLoad then begin
943 Buf.GlobalWriteLockStepOnLastLoad:=GlobalWriteLockStep;
944 if Buf.FileNeedsUpdate then
945 Result:=true;
946 end;
947 end else begin
948 if Buf.FileNeedsUpdate then
949 Result:=true;
950 end;
951 end else begin
952 //DebugLn(['TCodeCache.OnScannerCheckFileOnDisk AutoRevertFromDisk=',Buf.AutoRevertFromDisk,' ',Buf.Filename]);
953 end;
954 if Result then
955 Buf.Revert;
956 //if buf.IsDeleted then debugln(['TCodeCache.OnScannerCheckFileOnDisk ',Buf.Filename,' still deleted']);
957 end;
958
959 procedure TCodeCache.OnScannerIncludeCode(ParentCode, IncludeCode: pointer);
960 var
961 CodeBuffer: TCodeBuffer;
962 begin
963 if (ParentCode<>nil) and (IncludeCode<>nil) and (ParentCode<>IncludeCode) then
964 begin
965 CodeBuffer:=TCodeBuffer(IncludeCode);
966 if CodeBuffer.LastIncludedByFile=TCodeBuffer(ParentCode).Filename then exit;
967 CodeBuffer.LastIncludedByFile:=TCodeBuffer(ParentCode).Filename;
968 IncreaseChangeStep;
969 end;
970 end;
971
972 procedure TCodeCache.OnScannerGetSourceStatus(Sender: TObject; Code:Pointer;
973 var ReadOnly: boolean);
974 begin
975 ReadOnly:=TCodeBuffer(Code).ReadOnly;
976 end;
977
978 procedure TCodeCache.OnScannerDeleteSource(Sender: TObject; Code: Pointer;
979 Pos, Len: integer);
980 begin
981 TCodeBuffer(Code).Delete(Pos,Len);
982 end;
983
FindIncludeLinkNodenull984 function TCodeCache.FindIncludeLinkNode(const IncludeFilename: string
985 ): TIncludedByLink;
986 var
987 ANode: TAVLTreeNode;
988 cmp: integer;
989 begin
990 ANode:=FIncludeLinks.Root;
991 while ANode<>nil do begin
992 Result:=TIncludedByLink(ANode.Data);
993 cmp:=CompareFilenames(IncludeFilename,Result.IncludeFilename);
994 if cmp<0 then ANode:=ANode.Left
995 else if cmp>0 then ANode:=ANode.Right
996 else begin
997 exit;
998 end;
999 end;
1000 Result:=nil;
1001 end;
1002
TCodeCache.FindIncludeLinkAVLNodenull1003 function TCodeCache.FindIncludeLinkAVLNode(const IncludeFilename: string
1004 ): TAVLTreeNode;
1005 begin
1006 Result:=FIncludeLinks.FindKey(Pointer(IncludeFilename),
1007 @CompareAnsiStringWithIncludedByLink);
1008 end;
1009
TCodeCache.FindIncludeLinknull1010 function TCodeCache.FindIncludeLink(const IncludeFilename: string): string;
1011 var Link: TIncludedByLink;
1012 begin
1013 Link:=FindIncludeLinkNode(IncludeFilename);
1014 if Link<>nil then begin
1015 Result:=Link.IncludedByFile;
1016 if CompareFilenames(Result,IncludeFilename)=0 then Result:='';
1017 end else
1018 Result:='';
1019 end;
1020
1021 procedure TCodeCache.UpdateIncludeLinks;
1022 var CodeNode: TAVLTreeNode;
1023 IncludeNode: TIncludedByLink;
1024 Code: TCodeBuffer;
1025 CurrDate: TDateTime;
1026 begin
1027 CodeNode:=FItems.FindLowest;
1028 CurrDate:=Date;
1029 while CodeNode<>nil do begin
1030 Code:=TCodeBuffer(CodeNode.Data);
1031 IncludeNode:=FindIncludeLinkNode(Code.Filename);
1032 if IncludeNode<>nil then begin
1033 // there is already an entry for this file -> update it
1034 IncludeNode.IncludedByFile:=Code.LastIncludedByFile;
1035 IncludeNode.LastTimeUsed:=CurrDate;
1036 end else if Code.LastIncludedByFile<>'' then begin
1037 // there is no entry for this include file -> add one
1038 FIncludeLinks.Add(TIncludedByLink.Create(Code.Filename,
1039 Code.LastIncludedByFile,CurrDate));
1040 end;
1041 CodeNode:=FItems.FindSuccessor(CodeNode);
1042 end;
1043 end;
1044
1045 procedure TCodeCache.IncreaseChangeStep;
1046 begin
1047 inc(fChangeStep);
1048 if fChangeStep=$7fffffff then fChangeStep:=-$7fffffff;
1049 end;
1050
1051 procedure TCodeCache.DecodeLoaded(Code: TCodeBuffer; const AFilename: string;
1052 var ASource, ADiskEncoding, AMemEncoding: string);
1053 begin
1054 if Assigned(OnDecodeLoaded) then
1055 OnDecodeLoaded(Code,AFilename,ASource,ADiskEncoding,AMemEncoding);
1056 end;
1057
1058 procedure TCodeCache.EncodeSaving(Code: TCodeBuffer; const AFilename: string;
1059 var ASource: string);
1060 begin
1061 if Assigned(OnEncodeSaving) then
1062 OnEncodeSaving(Code,AFilename,ASource);
1063 end;
1064
SaveIncludeLinksToFilenull1065 function TCodeCache.SaveIncludeLinksToFile(const AFilename: string;
1066 OnlyIfChanged: boolean): boolean;
1067 var XMLConfig: TXMLConfig;
1068 begin
1069 try
1070 if OnlyIfChanged and fLastIncludeLinkFileValid
1071 and (fLastIncludeLinkFileChangeStep=fChangeStep)
1072 and (fLastIncludeLinkFile=AFilename)
1073 and FileExistsCached(AFilename)
1074 and (FileAgeCached(AFilename)=fLastIncludeLinkFileAge)
1075 then begin
1076 //debugln(['TCodeCache.SaveIncludeLinksToFile file valid']);
1077 exit;
1078 end;
1079 XMLConfig:=TXMLConfig.CreateClean(AFilename);
1080 try
1081 Result:=SaveIncludeLinksToXML(XMLConfig,'');
1082 fLastIncludeLinkFile:=AFilename;
1083 fLastIncludeLinkFileAge:=FileAgeCached(AFilename);
1084 fLastIncludeLinkFileChangeStep:=fChangeStep;
1085 fLastIncludeLinkFileValid:=true;
1086 finally
1087 XMLConfig.Free;
1088 end;
1089 except
1090 fLastIncludeLinkFileValid:=false;
1091 Result:=false;
1092 end;
1093 end;
1094
LoadIncludeLinksFromFilenull1095 function TCodeCache.LoadIncludeLinksFromFile(const AFilename: string): boolean;
1096 var XMLConfig: TXMLConfig;
1097 begin
1098 try
1099 XMLConfig:=TXMLConfig.Create(AFilename);
1100 try
1101 Result:=LoadIncludeLinksFromXML(XMLConfig,'');
1102 fLastIncludeLinkFile:=AFilename;
1103 fLastIncludeLinkFileAge:=FileAgeCached(AFilename);
1104 fLastIncludeLinkFileChangeStep:=fChangeStep;
1105 fLastIncludeLinkFileValid:=true;
1106 finally
1107 XMLConfig.Free;
1108 end;
1109 except
1110 fLastIncludeLinkFileValid:=false;
1111 Result:=false;
1112 end;
1113 end;
1114
SaveIncludeLinksToXMLnull1115 function TCodeCache.SaveIncludeLinksToXML(XMLConfig: TXMLConfig;
1116 const XMLPath: string): boolean;
1117 var
1118 List: TStringList;
1119 begin
1120 UpdateIncludeLinks;
1121 XMLConfig.SetValue(XMLPath+'IncludeLinks/Version',IncludeLinksFileVersion);
1122 XMLConfig.SetDeleteValue(XMLPath+'IncludeLinks/ExpirationTimeInDays',
1123 FExpirationTimeInDays,0);
1124 List:=TStringList.Create;
1125 try
1126 SaveIncludeLinksDataToList(List);
1127 XMLConfig.SetDeleteValue(XMLPath+'IncludeLinks/Data',List.Text,'');
1128 finally
1129 List.Free;
1130 end;
1131 Result:=true;
1132 end;
1133
LoadIncludeLinksFromXMLnull1134 function TCodeCache.LoadIncludeLinksFromXML(XMLConfig: TXMLConfig;
1135 const XMLPath: string): boolean;
1136 var LinkCnt, i: integer;
1137 LastTimeUsed, CurrDate: TDateTime;
1138 IncludeFilename, IncludedByFile, APath: string;
1139 NewLink: TIncludedByLink;
1140 CurrDateStr: String;
1141 FileVersion: longint;
1142 List: TStringList;
1143 begin
1144 FIncludeLinks.FreeAndClear;
1145
1146 FileVersion:=XMLConfig.GetValue(XMLPath+'IncludeLinks/Version',IncludeLinksFileVersion);
1147 FExpirationTimeInDays:=XMLConfig.GetValue(
1148 XMLPath+'IncludeLinks/ExpirationTimeInDays',
1149 FExpirationTimeInDays);
1150 if FileVersion>=2 then begin
1151 List:=TStringList.Create;
1152 try
1153 List.Text:=XMLConfig.GetValue(XMLPath+'IncludeLinks/Data','');
1154 LoadIncludeLinksDataFromList(List);
1155 finally
1156 List.Free;
1157 end;
1158 end else if FileVersion<=1 then begin
1159 CurrDate:=Date;
1160 CurrDateStr:=DateToCfgStr(CurrDate);
1161 LinkCnt:=XMLConfig.GetValue(XMLPath+'IncludeLinks/Count',0);
1162 for i:=0 to LinkCnt-1 do begin
1163 APath:=XMLPath+'IncludeLinks/Link'+IntToStr(i)+'/';
1164 if not CfgStrToDate(XMLConfig.GetValue(APath+'LastTimeUsed/Value',
1165 CurrDateStr),LastTimeUsed)
1166 then begin
1167 debugln(['TCodeCache.LoadIncludeLinksFromXML invalid date: ',XMLConfig.GetValue(APath+'LastTimeUsed/Value','')]);
1168 LastTimeUsed:=CurrDate;
1169 end;
1170 // ToDo: check if link has expired
1171
1172 IncludeFilename:=XMLConfig.GetValue(APath+'IncludeFilename/Value','');
1173 //debugln(['TCodeCache.LoadIncludeLinksFromXML CurrDate=',DateToStr(CurrDate),' xml=',XMLConfig.GetValue(APath+'LastTimeUsed/Value',''),' Days=',CurrDate-LastTimeUsed,' ',IncludeFilename]);
1174 if IncludeFilename='' then continue;
1175 IncludedByFile:=XMLConfig.GetValue(APath+'IncludedByFilename/Value','');
1176 if (FExpirationTimeInDays<=0)
1177 or (CurrDate-LastTimeUsed<=FExpirationTimeInDays) then begin
1178 NewLink:=TIncludedByLink.Create(IncludeFilename,IncludedByFile,
1179 LastTimeUsed);
1180 FIncludeLinks.Add(NewLink);
1181 end;
1182 end;
1183 end;
1184 Result:=true;
1185 end;
1186
1187 procedure TCodeCache.ConsistencyCheck;
1188 // 0 = ok
1189 var ANode: TAVLTreeNode;
1190 begin
1191 FItems.ConsistencyCheck;
1192 FIncludeLinks.ConsistencyCheck;
1193 ANode:=FItems.FindLowest;
1194 while ANode<>nil do begin
1195 if ANode.Data=nil then
1196 RaiseCatchableException('');
1197 TCodeBuffer(ANode.Data).ConsistencyCheck;
1198 ANode:=FItems.FindSuccessor(ANode);
1199 end;
1200 ANode:=FIncludeLinks.FindLowest;
1201 while ANode<>nil do begin
1202 if ANode.Data=nil then
1203 RaiseCatchableException('');
1204 ANode:=FIncludeLinks.FindSuccessor(ANode);
1205 end;
1206 end;
1207
1208 procedure TCodeCache.WriteDebugReport;
1209 begin
1210 DebugLn('[TCodeCache.WriteDebugReport]');
1211 DebugLn(FItems.ReportAsString);
1212 DebugLn(FIncludeLinks.ReportAsString);
1213 ConsistencyCheck;
1214 end;
1215
CalcMemSizenull1216 function TCodeCache.CalcMemSize(Stats: TCTMemStats): PtrUInt;
1217 var
1218 m: PtrUInt;
1219 Node: TAVLTreeNode;
1220 IncLink: TIncludedByLink;
1221 Buf: TCodeBuffer;
1222 begin
1223 Result:=PtrUInt(InstanceSize)
1224 +MemSizeString(FDefaultEncoding)
1225 +MemSizeString(fLastIncludeLinkFile);
1226 Stats.Add('TCodeCache',Result);
1227 if FItems<>nil then begin
1228 m:=FItems.Count*SizeOf(Node);
1229 Node:=FItems.FindLowest;
1230 while Node<>nil do begin
1231 Buf:=TCodeBuffer(Node.Data);
1232 inc(m,Buf.CalcMemSize);
1233 Node:=FItems.FindSuccessor(Node);
1234 end;
1235 Stats.Add('TCodeCache.Items.Count',FItems.Count);
1236 Stats.Add('TCodeCache.Items',m);
1237 inc(Result,m);
1238 end;
1239 if FIncludeLinks<>nil then begin
1240 m:=FIncludeLinks.Count*SizeOf(Node);
1241 Node:=FIncludeLinks.FindLowest;
1242 while Node<>nil do begin
1243 IncLink:=TIncludedByLink(Node.Data);
1244 inc(m,IncLink.CalcMemSize);
1245 Node:=FIncludeLinks.FindSuccessor(Node);
1246 end;
1247 Stats.Add('TCodeCache.FIncludeLinks.Count',FIncludeLinks.Count);
1248 Stats.Add('TCodeCache.FIncludeLinks',m);
1249 inc(Result,m);
1250 end;
1251 end;
1252
1253 procedure TCodeCache.IncreaseChangeStamp;
1254 begin
1255 //debugln(['TCodeCache.IncreaseChangeStamp ']);
1256 CTIncreaseChangeStamp64(FChangeStamp);
1257 end;
1258
1259 procedure TCodeCache.WriteAllFileNames;
1260 procedure WriteNode(ANode: TAVLTreeNode);
1261 begin
1262 if ANode=nil then exit;
1263 WriteNode(ANode.Left);
1264 DebugLn(' ',TCodeBuffer(ANode.Data).Filename);
1265 WriteNode(ANode.Right);
1266 end;
1267
1268 begin
1269 DebugLn('TCodeCache.WriteAllFileNames: ',dbgs(FItems.Count));
1270 WriteNode(FItems.Root);
1271 end;
1272
1273 { TCodeBuffer }
1274
1275 constructor TCodeBuffer.Create;
1276 begin
1277 inherited Create('');
1278 FFilename:='';
1279 FLastIncludedByFile:='';
1280 FLoadDateValid:=false;
1281 FIsVirtual:=true;
1282 FIsDeleted:=false;
1283 end;
1284
1285 destructor TCodeBuffer.Destroy;
1286 begin
1287 if Scanner<>nil then Scanner.Free;
1288 if FCodeCache<>nil then FCodeCache.RemoveCodeBuffer(Self);
1289 inherited Destroy;
1290 end;
1291
1292 procedure TCodeBuffer.Clear;
1293 begin
1294 FIsDeleted:=false;
1295 FLoadDateValid:=false;
1296 inherited Clear;
1297 end;
1298
LoadFromFilenull1299 function TCodeBuffer.LoadFromFile(const AFilename: string): boolean;
1300 begin
1301 //DebugLn('[TCodeBuffer.LoadFromFile] WriteLock=',WriteLock,' ReadOnly=',ReadOnly,
1302 //' IsVirtual=',IsVirtual,' Old="',Filename,'" ',CompareFilenames(AFilename,Filename));
1303 if (WriteLock>0) or ReadOnly then begin
1304 Result:=false;
1305 exit;
1306 end;
1307 if (not IsVirtual) or (Filename='') then begin
1308 if CompareFilenames(AFilename,Filename)=0 then begin
1309 //DebugLn('[TCodeBuffer.LoadFromFile] ',Filename,' FileDateValid=',FileDateValid,' ',FFileDate,',',FileAgeUTF8(Filename),',',FFileChangeStep,',',ChangeStep,', NeedsUpdate=',FileNeedsUpdate);
1310 if FileNeedsUpdate then begin
1311 Result:=inherited LoadFromFile(AFilename);
1312 if Result then MakeFileDateValid;
1313 end else
1314 Result:=true;
1315 end else begin
1316 Result:=inherited LoadFromFile(AFilename);
1317 if Result then MakeFileDateValid;
1318 end;
1319 if Result then IsDeleted:=false;
1320 end else
1321 Result:=false;
1322 end;
1323
SaveToFilenull1324 function TCodeBuffer.SaveToFile(const AFilename: string): boolean;
1325 begin
1326 Result:=inherited SaveToFile(AFilename);
1327 //DebugLn(['TCodeBuffer.SaveToFile ',Filename,' -> ',AFilename,' ',Result]);
1328 if CompareFilenames(AFilename,Filename)=0 then begin
1329 if Result then begin
1330 IsDeleted:=false;
1331 MakeFileDateValid;
1332 Modified:=false;
1333 end;
1334 end;
1335 //debugln(['TCodeBuffer.SaveToFile FileOnDiskHasChanged=',FileOnDiskHasChanged,' LoadDate=',LoadDate,' FileAgeCached=',FileAgeCached(Filename)]);
1336 end;
1337
TCodeBuffer.Reloadnull1338 function TCodeBuffer.Reload: boolean;
1339 begin
1340 Result:=LoadFromFile(Filename);
1341 end;
1342
Revertnull1343 function TCodeBuffer.Revert: boolean;
1344 // ignore changes and reload source
1345 begin
1346 if not IsVirtual then begin
1347 Result:=inherited LoadFromFile(Filename);
1348 if Result then MakeFileDateValid;
1349 end else
1350 Result:=false;
1351 end;
1352
TCodeBuffer.Savenull1353 function TCodeBuffer.Save: boolean;
1354 begin
1355 if not IsVirtual then
1356 Result:=SaveToFile(Filename)
1357 else
1358 Result:=false;
1359 end;
1360
GetLastIncludedByFilenull1361 function TCodeBuffer.GetLastIncludedByFile: string;
1362 begin
1363 Result:=FLastIncludedByFile;
1364 if Result=Filename then Result:='';
1365 end;
1366
1367 procedure TCodeBuffer.SetFilename(Value: string);
1368 var OldFilename: string;
1369 begin
1370 Value:=TrimFilename(Value);
1371 if FFilename=Value then exit;
1372 OldFilename:=FFilename;
1373 FFilename := Value;
1374 FIsVirtual:=not FilenameIsAbsolute(Filename);
1375 if CompareFilenames(OldFileName,Value)<>0 then begin
1376 FLoadDateValid:=false;
1377 end;
1378 FLastIncludedByFile:='';
1379 if FCodeCache<>nil then FCodeCache.OnBufferSetFilename(Self,OldFilename);
1380 if Assigned(FOnSetFilename) then FOnSetFilename(Self);
1381 end;
1382
1383 procedure TCodeBuffer.SetScanner(const Value: TLinkScanner);
1384 begin
1385 if FScanner=Value then exit;
1386 FScanner := Value;
1387 if Assigned(FOnSetScanner) then FOnSetScanner(Self);
1388 if FCodeCache<>nil then FCodeCache.OnBufferSetScanner(Self);
1389 if FScanner<>nil then
1390 FScanner.MainCode:=Self;
1391 end;
1392
1393 procedure TCodeBuffer.SetIsDeleted(const NewValue: boolean);
1394 begin
1395 if FIsDeleted=NewValue then exit;
1396 //debugln(['TCodeBuffer.SetIsDeleted ',Filename,' ',NewValue]);
1397 IncreaseChangeStep;
1398 FIsDeleted:=NewValue;
1399 if FIsDeleted then begin
1400 Clear;
1401 FIsDeleted:=true;
1402 //DebugLn(['TCodeBuffer.SetIsDeleted ',Filename,' ',FileNeedsUpdate]);
1403 end;
1404 end;
1405
1406 procedure TCodeBuffer.DoSourceChanged;
1407 begin
1408 //debugln(['TCodeBuffer.DoSourceChanged ',Filename]);
1409 inherited DoSourceChanged;
1410 if FCodeCache<>nil then
1411 FCodeCache.IncreaseChangeStamp;
1412 end;
1413
1414 procedure TCodeBuffer.DecodeLoaded(const AFilename: string; var ASource,
1415 ADiskEncoding, AMemEncoding: string);
1416 begin
1417 inherited DecodeLoaded(AFilename,ASource,ADiskEncoding,AMemEncoding);
1418 if CodeCache<>nil then
1419 CodeCache.DecodeLoaded(Self,AFilename,ASource,ADiskEncoding,AMemEncoding);
1420 end;
1421
1422 procedure TCodeBuffer.EncodeSaving(const AFilename: string; var ASource: string);
1423 begin
1424 inherited EncodeSaving(AFilename,ASource);
1425 if CodeCache<>nil then
1426 CodeCache.EncodeSaving(Self,AFilename,ASource);
1427 end;
1428
1429 procedure TCodeBuffer.MakeFileDateValid;
1430 begin
1431 FFileChangeStep:=ChangeStep;
1432 FLoadDateValid:=true;
1433 FLoadDate:=FileAgeCached(Filename);
1434 end;
1435
1436 procedure TCodeBuffer.InvalidateLoadDate;
1437 begin
1438 FLoadDateValid:=false;
1439 end;
1440
TCodeBuffer.SourceIsTextnull1441 function TCodeBuffer.SourceIsText: boolean;
1442 var
1443 l: LongInt;
1444 i: Integer;
1445 s: String;
1446 begin
1447 l:=SourceLength;
1448 if l>1024 then l:=1024;
1449 s:=Source;
1450 for i:=1 to l do
1451 if s[i] in [#0..#8,#11..#12,#14..#31] then exit(false);
1452 Result:=true;
1453 end;
1454
FileDateOnDisknull1455 function TCodeBuffer.FileDateOnDisk: longint;
1456 begin
1457 Result:=FileAgeCached(Filename);
1458 end;
1459
FileNeedsUpdatenull1460 function TCodeBuffer.FileNeedsUpdate(IgnoreModifiedFlag: Boolean): boolean;
1461 // file needs update (to be loaded), if file is not modified and file on disk has changed
1462 begin
1463 if IgnoreModifiedFlag then
1464 begin
1465 if IsVirtual then exit(false);
1466 Result:=FileDateOnDisk<>LoadDate; // ignore LoadDateValid because it is set to false after edit
1467 end else
1468 begin
1469 if Modified or IsVirtual then exit(false);
1470 if LoadDateValid then
1471 Result:=(FFileChangeStep=ChangeStep) and (FileDateOnDisk<>LoadDate)
1472 else
1473 Result:=true;
1474 end;
1475 end;
1476
FileOnDiskNeedsUpdatenull1477 function TCodeBuffer.FileOnDiskNeedsUpdate: boolean;
1478 // file on disk needs update (= file needs to be saved), if memory is modified or file does not exist
1479 begin
1480 if IsVirtual or IsDeleted then exit(false);
1481 Result:=Modified
1482 or (not LoadDateValid) // file was created in memory, but not yet saved to disk
1483 or (FFileChangeStep<>ChangeStep) // file was modified since last load/save
1484 or (not FileExistsCached(Filename));
1485 end;
1486
TCodeBuffer.FileOnDiskHasChangednull1487 function TCodeBuffer.FileOnDiskHasChanged(IgnoreModifiedFlag: Boolean): boolean;
1488 // file on disk has changed since last load/save
1489 begin
1490 if IsVirtual then exit(false);
1491 if IgnoreModifiedFlag then
1492 begin
1493 if FileExistsCached(Filename) then
1494 Result:=(FileDateOnDisk<>LoadDate) // ignore LoadDateValid because it is set to false after edit
1495 else
1496 Result:=false;
1497 end else
1498 begin
1499 if LoadDateValid and FileExistsCached(Filename) then
1500 Result:=(FileDateOnDisk<>LoadDate)
1501 else
1502 Result:=false;
1503 end;
1504 end;
1505
TCodeBuffer.FileOnDiskIsEqualnull1506 function TCodeBuffer.FileOnDiskIsEqual: boolean;
1507 begin
1508 if IsVirtual then
1509 exit(true);
1510 if IsDeleted then
1511 exit(not FileExistsCached(Filename));
1512 if (not LoadDateValid)
1513 or Modified or (FFileChangeStep<>ChangeStep)
1514 or (not FileExistsCached(Filename))
1515 or (FileDateOnDisk<>LoadDate)
1516 then
1517 exit(false);
1518 Result:=true;
1519 end;
1520
AutoRevertFromDisknull1521 function TCodeBuffer.AutoRevertFromDisk: boolean;
1522 begin
1523 Result:=FAutoDiskRevertLock=0;
1524 end;
1525
1526 procedure TCodeBuffer.LockAutoDiskRevert;
1527 begin
1528 inc(FAutoDiskRevertLock);
1529 end;
1530
1531 procedure TCodeBuffer.UnlockAutoDiskRevert;
1532 begin
1533 if FAutoDiskRevertLock>0 then dec(FAutoDiskRevertLock);
1534 end;
1535
1536 procedure TCodeBuffer.IncrementRefCount;
1537 begin
1538 inc(FReferenceCount);
1539 end;
1540
1541 procedure TCodeBuffer.ReleaseRefCount;
1542 begin
1543 if FReferenceCount=0 then
1544 raise Exception.Create('TCodeBuffer.ReleaseRefCount');
1545 dec(FReferenceCount);
1546 end;
1547
1548 procedure TCodeBuffer.ConsistencyCheck;
1549 begin
1550 if FScanner<>nil then
1551 FScanner.ConsistencyCheck;
1552 end;
1553
1554 procedure TCodeBuffer.WriteDebugReport;
1555 begin
1556 DebugLn('[TCodeBuffer.WriteDebugReport] ');
1557 ConsistencyCheck;
1558 end;
1559
CalcMemSizenull1560 function TCodeBuffer.CalcMemSize: PtrUInt;
1561 begin
1562 Result:=(inherited CalcMemSize)
1563 +MemSizeString(FFilename)
1564 +MemSizeString(FLastIncludedByFile);
1565 end;
1566
1567 { TIncludedByLink }
1568
1569 constructor TIncludedByLink.Create(const AnIncludeFilename,
1570 AnIncludedByFile: string; ALastTimeUsed: TDateTime);
1571 begin
1572 inherited Create;
1573 IncludeFilename:=AnIncludeFilename;
1574 IncludedByFile:=AnIncludedByFile;
1575 LastTimeUsed:=ALastTimeUsed;
1576 end;
1577
CalcMemSizenull1578 function TIncludedByLink.CalcMemSize: PtrUInt;
1579 begin
1580 Result:=PtrUInt(InstanceSize)
1581 +MemSizeString(IncludedByFile)
1582 +MemSizeString(IncludeFilename);
1583 end;
1584
1585 { TCodeXYPositions }
1586
TCodeXYPositions.GetItemsnull1587 function TCodeXYPositions.GetItems(Index: integer): PCodeXYPosition;
1588 begin
1589 Result:=PCodeXYPosition(FItems[Index]);
1590 end;
1591
GetCaretsXYnull1592 function TCodeXYPositions.GetCaretsXY(Index: integer): TPoint;
1593 var
1594 Item: PCodeXYPosition;
1595 begin
1596 Item:=Items[Index];
1597 Result:=Point(Item^.X,Item^.Y);
1598 end;
1599
TCodeXYPositions.GetCodesnull1600 function TCodeXYPositions.GetCodes(Index: integer): TCodeBuffer;
1601 var
1602 Item: PCodeXYPosition;
1603 begin
1604 Item:=Items[Index];
1605 Result:=Item^.Code;
1606 end;
1607
1608 procedure TCodeXYPositions.SetCaretsXY(Index: integer; const AValue: TPoint);
1609 var
1610 Item: PCodeXYPosition;
1611 begin
1612 Item:=Items[Index];
1613 Item^.X:=AValue.X;
1614 Item^.Y:=AValue.Y;
1615 end;
1616
1617 procedure TCodeXYPositions.SetCodes(Index: integer; const AValue: TCodeBuffer);
1618 var
1619 Item: PCodeXYPosition;
1620 begin
1621 Item:=Items[Index];
1622 Item^.Code:=AValue;
1623 end;
1624
1625 procedure TCodeXYPositions.SetItems(Index: integer;
1626 const AValue: PCodeXYPosition);
1627 begin
1628 FItems[Index]:=AValue;
1629 end;
1630
1631 constructor TCodeXYPositions.Create;
1632 begin
1633
1634 end;
1635
1636 destructor TCodeXYPositions.Destroy;
1637 begin
1638 Clear;
1639 FItems.Free;
1640 FItems:=nil;
1641 inherited Destroy;
1642 end;
1643
1644 procedure TCodeXYPositions.Clear;
1645 var
1646 i: Integer;
1647 Item: PCodeXYPosition;
1648 begin
1649 if FItems<>nil then begin
1650 for i:=0 to FItems.Count-1 do begin
1651 Item:=Items[i];
1652 Dispose(Item);
1653 end;
1654 FItems.Clear;
1655 end;
1656 end;
1657
Addnull1658 function TCodeXYPositions.Add(const Position: TCodeXYPosition): integer;
1659 var
1660 NewItem: PCodeXYPosition;
1661 begin
1662 New(NewItem);
1663 NewItem^:=Position;
1664 if FItems=nil then FItems:=TFPList.Create;
1665 Result:=FItems.Add(NewItem);
1666 end;
1667
Addnull1668 function TCodeXYPositions.Add(X, Y: integer; Code: TCodeBuffer): integer;
1669 var
1670 NewItem: TCodeXYPosition;
1671 begin
1672 NewItem.X:=X;
1673 NewItem.Y:=Y;
1674 NewItem.Code:=Code;
1675 Result:=Add(NewItem);
1676 end;
1677
1678 procedure TCodeXYPositions.Assign(Source: TCodeXYPositions);
1679 var
1680 i: Integer;
1681 begin
1682 if IsEqual(Source) then exit;
1683 Clear;
1684 for i:=0 to Source.Count-1 do
1685 Add(Source[i]^);
1686 end;
1687
TCodeXYPositions.IsEqualnull1688 function TCodeXYPositions.IsEqual(Source: TCodeXYPositions): boolean;
1689 var
1690 SrcItem: TCodeXYPosition;
1691 CurItem: TCodeXYPosition;
1692 i: Integer;
1693 begin
1694 if Source=Self then
1695 Result:=true
1696 else if (Source=nil) or (Source.Count<>Count) then
1697 Result:=false
1698 else begin
1699 for i:=0 to Count-1 do begin
1700 SrcItem:=Source[i]^;
1701 CurItem:=Items[i]^;
1702 if (SrcItem.X<>CurItem.X)
1703 or (SrcItem.Y<>CurItem.Y)
1704 or (SrcItem.Code<>CurItem.Code)
1705 then begin
1706 Result:=false;
1707 exit;
1708 end;
1709 end;
1710 Result:=true;
1711 end;
1712 end;
1713
TCodeXYPositions.Countnull1714 function TCodeXYPositions.Count: integer;
1715 begin
1716 if FItems<>nil then
1717 Result:=FItems.Count
1718 else
1719 Result:=0;
1720 end;
1721
1722 procedure TCodeXYPositions.Delete(Index: integer);
1723 var
1724 Item: PCodeXYPosition;
1725 begin
1726 Item:=Items[Index];
1727 Dispose(Item);
1728 FItems.Delete(Index);
1729 end;
1730
CreateCopynull1731 function TCodeXYPositions.CreateCopy: TCodeXYPositions;
1732 begin
1733 Result:=TCodeXYPositions.Create;
1734 Result.Assign(Self);
1735 end;
1736
CalcMemSizenull1737 function TCodeXYPositions.CalcMemSize: PtrUint;
1738 begin
1739 Result:=PtrUInt(InstanceSize);
1740 if FItems<>nil then
1741 inc(Result,PtrUInt(FItems.InstanceSize)
1742 +PtrUInt(FItems.Capacity)*SizeOf(TCodeXYPosition));
1743 end;
1744
1745 end.
1746
1747