← Back to branch summary

~ubuntu-branches/ubuntu/saucy/lazarus/saucy

« back to all changes in this revision

Viewing changes to components/codetools/codecache.pas

  • Committer: Package Import Robot
  • Author(s): Paul Gevers, Abou Al Montacir, Bart Martens, Paul Gevers
  • Date: 2013-06-08 14:12:17 UTC
  • mfrom: (1.1.9)
  • Revision ID: package-import@ubuntu.com-20130608141217-7k0cy9id8ifcnutc
Tags: 1.0.8+dfsg-1
http://bugs.debian.org/708695
[ Abou Al Montacir ]
* New upstream major release and multiple maintenace release offering many
  fixes and new features marking a new milestone for the Lazarus development
  and its stability level.
  - The detailed list of changes can be found here:
    http://wiki.lazarus.freepascal.org/Lazarus_1.0_release_notes
    http://wiki.lazarus.freepascal.org/Lazarus_1.0_fixes_branch
* LCL changes:
  - LCL is now a normal package.
      + Platform independent parts of the LCL are now in the package LCLBase
      + LCL is automatically recompiled when switching the target platform,
        unless pre-compiled binaries for this target are already installed.
      + No impact on existing projects.
      + Linker options needed by LCL are no more added to projects that do
        not use the LCL package.
  - Minor changes in LCL basic classes behaviour
      + TCustomForm.Create raises an exception if a form resource is not
        found.
      + TNotebook and TPage: a new implementation of these classes was added.
      + TDBNavigator: It is now possible to have focusable buttons by setting
        Options = [navFocusableButtons] and TabStop = True, useful for
        accessibility and for devices with neither mouse nor touch screen.
      + Names of TControlBorderSpacing.GetSideSpace and GetSpace were swapped
        and are now consistent. GetSideSpace = Around + GetSpace.
      + TForm.WindowState=wsFullscreen was added
      + TCanvas.TextFitInfo was added to calculate how many characters will
        fit into a specified Width. Useful for word-wrapping calculations.
      + TControl.GetColorResolvingParent and
        TControl.GetRGBColorResolvingParent were added, simplifying the work
        to obtain the final color of the control while resolving clDefault
        and the ParentColor.
      + LCLIntf.GetTextExtentExPoint now has a good default implementation
        which works in any platform not providing a specific implementation.
        However, Widgetset specific implementation is better, when available.
      + TTabControl was reorganized. Now it has the correct class hierarchy
        and inherits from TCustomTabControl as it should.
  - New unit in the LCL:
      + lazdialogs.pas: adds non-native versions of various native dialogs,
        for example TLazOpenDialog, TLazSaveDialog, TLazSelectDirectoryDialog.
        It is used by widgetsets which either do not have a native dialog, or
        do not wish to use it because it is limited. These dialogs can also be
        used by user applications directly.
      + lazdeviceapis.pas: offers an interface to more hardware devices such
        as the accelerometer, GPS, etc. See LazDeviceAPIs
      + lazcanvas.pas: provides a TFPImageCanvas descendent implementing
        drawing in a LCL-compatible way, but 100% in Pascal.
      + lazregions.pas. LazRegions is a wholly Pascal implementation of
        regions for canvas clipping, event clipping, finding in which control
        of a region tree one an event should reach, for drawing polygons, etc.
      + customdrawncontrols.pas, customdrawndrawers.pas,
        customdrawn_common.pas, customdrawn_android.pas and
        customdrawn_winxp.pas: are the Lazarus Custom Drawn Controls -controls
        which imitate the standard LCL ones, but with the difference that they
        are non-native and support skinning.
  - New APIs added to the LCL to improve support of accessibility software
    such as screen readers.
* IDE changes:
  - Many improvments.
  - The detailed list of changes can be found here:
    http://wiki.lazarus.freepascal.org/New_IDE_features_since#v1.0_.282012-08-29.29
    http://wiki.lazarus.freepascal.org/Lazarus_1.0_release_notes#IDE_Changes
* Debugger / Editor changes:
  - Added pascal sources and breakpoints to the disassembler
  - Added threads dialog.
* Components changes:
  - TAChart: many fixes and new features
  - CodeTool: support Delphi style generics and new syntax extensions.
  - AggPas: removed to honor free licencing. (Closes: Bug#708695)
[Bart Martens]
* New debian/watch file fixing issues with upstream RC release.
[Abou Al Montacir]
* Avoid changing files in .pc hidden directory, these are used by quilt for
  internal purpose and could lead to surprises during build.
[Paul Gevers]
* Updated get-orig-source target and it compinion script orig-tar.sh so that they
  repack the source file, allowing bug 708695 to be fixed.

Show diffs side-by-side

added added

removed removed

Lines of Context:
components/codetools/codecache.pas
38
38
  {$IFDEF MEM_CHECK}
39
39
  MemCheck,
40
40
  {$ENDIF}
41
 
  Classes, SysUtils, SourceLog, LinkScanner, FileProcs,
42
 
  Avl_Tree, Laz_XMLCfg;
 
41
  Classes, SysUtils, SourceLog, LinkScanner, FileProcs, DirectoryCacher,
 
42
  Avl_Tree, Laz2_XMLCfg;
43
43
 
44
44
const
45
45
  IncludeLinksFileVersion = 2;
69
69
    procedure SetScanner(const Value: TLinkScanner);
70
70
    procedure SetIsDeleted(const NewValue: boolean);
71
71
  protected
72
 
    procedure IncreaseChangeStep; override;
 
72
    procedure DoSourceChanged; override;
73
73
    procedure DecodeLoaded(const AFilename: string;
74
74
                    var ASource, ADiskEncoding, AMemEncoding: string); override;
75
75
    procedure EncodeSaving(const AFilename: string; var ASource: string); override;
86
86
    function SaveToFile(const AFilename: string): boolean; override;
87
87
    function Save: boolean;
88
88
    function FileDateOnDisk: longint;
89
 
    function FileNeedsUpdate: boolean;
 
89
    function FileNeedsUpdate: boolean; // needs loading
90
90
    function FileOnDiskNeedsUpdate: boolean;
91
91
    function FileOnDiskHasChanged: boolean;
92
92
    function FileOnDiskIsEqual: boolean;
108
108
                                        write FLastIncludedByFile;
109
109
    property LoadDate: longint read FLoadDate;
110
110
    property LoadDateValid: boolean read FLoadDateValid;
 
111
    property FileChangeStep: integer read FFileChangeStep; // last loaded/saved changestep, only valid if LoadDateValid=true
111
112
    property OnSetFilename: TNotifyEvent read FOnSetFilename write FOnSetFilename;
112
113
    property OnSetScanner: TNotifyEvent read FOnSetScanner write FOnSetScanner;
113
114
    property Scanner: TLinkScanner read FScanner write SetScanner;
137
138
  private
138
139
    FChangeStamp: int64;
139
140
    FDefaultEncoding: string;
 
141
    FDirectoryCachePool: TCTDirectoryCachePool;
140
142
    FItems: TAVLTree;  // tree of TCodeBuffer
141
143
    FIncludeLinks: TAVLTree; // tree of TIncludedByLink
142
144
    FDestroying: boolean;
153
155
    function FindIncludeLink(const IncludeFilename: string): string;
154
156
    function FindIncludeLinkNode(const IncludeFilename: string): TIncludedByLink;
155
157
    function FindIncludeLinkAVLNode(const IncludeFilename: string): TAVLTreeNode;
156
 
    function OnScannerCheckFileOnDisk(Code: pointer): boolean;
 
158
    function OnScannerCheckFileOnDisk(Code: pointer): boolean; // true if code changed
157
159
    function OnScannerGetFileName(Sender: TObject; Code: pointer): string;
158
160
    function OnScannerGetSource(Sender: TObject; Code: pointer): TSourceLog;
159
161
    function OnScannerLoadSource(Sender: TObject; const AFilename: string;
199
201
    procedure WriteAllFileNames;
200
202
    procedure WriteDebugReport;
201
203
    function CalcMemSize(Stats: TCTMemStats): PtrUInt;
202
 
    procedure IncreaseChangeStamp;
 
204
    procedure IncreaseChangeStamp; inline;
203
205
  public
204
206
    property ExpirationTimeInDays: integer
205
207
          read FExpirationTimeInDays write FExpirationTimeInDays;
213
215
                                                      write FOnEncodeSaving;
214
216
    property DefaultEncoding: string read FDefaultEncoding write FDefaultEncoding;
215
217
    property ChangeStamp: int64 read FChangeStamp;
216
 
  end;
217
 
 
 
218
    property DirectoryCachePool: TCTDirectoryCachePool read FDirectoryCachePool
 
219
                                                      write FDirectoryCachePool;
 
220
  end;
 
221
 
 
222
type
 
223
  TCodePosition = packed record
 
224
    Code: TCodeBuffer;
 
225
    P: integer;
 
226
  end;
 
227
  PCodePosition = ^TCodePosition;
 
228
 
 
229
  TCodeXYPosition = packed record
 
230
    Code: TCodeBuffer;
 
231
    X, Y: integer;
 
232
  end;
 
233
  PCodeXYPosition = ^TCodeXYPosition;
 
234
const
 
235
  CleanCodeXYPosition: TCodeXYPosition = (Code:nil; X:0; Y:0);
 
236
 
 
237
type
 
238
  { TCodeXYPositions - a list of PCodeXYPosition }
 
239
 
 
240
  TCodeXYPositions = class
 
241
  private
 
242
    FItems: TFPList; // list of PCodeXYPosition, can be nil
 
243
    function GetCaretsXY(Index: integer): TPoint;
 
244
    function GetCodes(Index: integer): TCodeBuffer;
 
245
    function GetItems(Index: integer): PCodeXYPosition;
 
246
    procedure SetCaretsXY(Index: integer; const AValue: TPoint);
 
247
    procedure SetCodes(Index: integer; const AValue: TCodeBuffer);
 
248
    procedure SetItems(Index: integer; const AValue: PCodeXYPosition);
 
249
  public
 
250
    constructor Create;
 
251
    destructor Destroy; override;
 
252
    procedure Clear;
 
253
    function Add(const Position: TCodeXYPosition): integer;
 
254
    function Add(X,Y: integer; Code: TCodeBuffer): integer;
 
255
    procedure Assign(Source: TCodeXYPositions);
 
256
    function IsEqual(Source: TCodeXYPositions): boolean;
 
257
    function Count: integer;
 
258
    procedure Delete(Index: integer);
 
259
    function CreateCopy: TCodeXYPositions;
 
260
    function CalcMemSize: PtrUint;
 
261
  public
 
262
    property Items[Index: integer]: PCodeXYPosition
 
263
                                          read GetItems write SetItems; default;
 
264
    property CaretsXY[Index: integer]: TPoint read GetCaretsXY write SetCaretsXY;
 
265
    property Codes[Index: integer]: TCodeBuffer read GetCodes write SetCodes;
 
266
  end;
 
267
 
 
268
 
 
269
function CompareCodeBuffers(NodeData1, NodeData2: pointer): integer;
 
270
function CompareAnsistringWithCodeBuffer(AString, ABuffer: pointer): integer;
 
271
function CompareIncludedByLink(NodeData1, NodeData2: pointer): integer;
 
272
function CompareAnsiStringWithIncludedByLink(Key, Data: pointer): integer;
 
273
 
 
274
function CodePosition(P: integer; Code: TCodeBuffer): TCodePosition;
 
275
function CodeXYPosition(X, Y: integer; Code: TCodeBuffer): TCodeXYPosition;
 
276
function CompareCodeXYPositions(Pos1, Pos2: PCodeXYPosition): integer;
 
277
 
 
278
function CompareCodePositions(Pos1, Pos2: PCodePosition): integer;
 
279
 
 
280
procedure AddCodePosition(var ListOfPCodeXYPosition: TFPList;
 
281
                          const NewCodePos: TCodeXYPosition);
 
282
function IndexOfCodePosition(var ListOfPCodeXYPosition: TFPList;
 
283
                             const APosition: PCodeXYPosition): integer;
 
284
procedure FreeListOfPCodeXYPosition(ListOfPCodeXYPosition: TFPList);
 
285
 
 
286
function CreateTreeOfPCodeXYPosition: TAVLTree;
 
287
procedure AddCodePosition(var TreeOfPCodeXYPosition: TAVLTree;
 
288
                          const NewCodePos: TCodeXYPosition);
 
289
procedure FreeTreeOfPCodeXYPosition(TreeOfPCodeXYPosition: TAVLTree);
 
290
procedure AddListToTreeOfPCodeXYPosition(SrcList: TFPList;
 
291
                          DestTree: TAVLTree; ClearList, CreateCopies: boolean);
 
292
function ListOfPCodeXYPositionToStr(const ListOfPCodeXYPosition: TFPList): string;
 
293
 
 
294
function Dbgs(const p: TCodeXYPosition): string; overload;
 
295
function Dbgs(const p: TCodePosition): string; overload;
218
296
 
219
297
implementation
220
298
 
221
299
 
222
300
function CompareCodeBuffers(NodeData1, NodeData2: pointer): integer;
223
 
var CodeBuf1, CodeBuf2: TCodeBuffer;
 
301
var
 
302
  CodeBuf1: TCodeBuffer absolute NodeData1;
 
303
  CodeBuf2: TCodeBuffer absolute NodeData2;
224
304
begin
225
 
  CodeBuf1:=TCodeBuffer(NodeData1);
226
 
  CodeBuf2:=TCodeBuffer(NodeData2);
227
305
  Result:=CompareFilenames(CodeBuf1.Filename,CodeBuf2.Filename);
228
306
end;
229
307
 
 
308
function CompareAnsistringWithCodeBuffer(AString, ABuffer: pointer): integer;
 
309
var
 
310
  Code: TCodeBuffer absolute ABuffer;
 
311
  Filename: String;
 
312
begin
 
313
  Filename:=AnsiString(AString);
 
314
  Result:=CompareFilenames(Filename,Code.Filename);
 
315
end;
 
316
 
230
317
function CompareIncludedByLink(NodeData1, NodeData2: pointer): integer;
231
 
var Link1, Link2: TIncludedByLink;
 
318
var
 
319
  Link1: TIncludedByLink absolute NodeData1;
 
320
  Link2: TIncludedByLink absolute NodeData2;
232
321
begin
233
 
  Link1:=TIncludedByLink(NodeData1);
234
 
  Link2:=TIncludedByLink(NodeData2);
235
322
  Result:=CompareFilenames(Link1.IncludeFilename,Link2.IncludeFilename);
236
323
end;
237
324
 
238
 
function ComparePAnsiStringWithIncludedByLink(Key, Data: pointer): integer;
 
325
function CompareAnsiStringWithIncludedByLink(Key, Data: pointer): integer;
239
326
begin
240
 
  Result:=CompareFilenames(PAnsiString(Key)^,
 
327
  Result:=CompareFilenames(AnsiString(Key),
241
328
                           TIncludedByLink(Data).IncludeFilename);
242
329
end;
243
330
 
 
331
function CodePosition(P: integer; Code: TCodeBuffer): TCodePosition;
 
332
begin
 
333
  Result.P:=P;
 
334
  Result.Code:=Code;
 
335
end;
 
336
 
 
337
function CodeXYPosition(X, Y: integer; Code: TCodeBuffer): TCodeXYPosition;
 
338
begin
 
339
  Result.X:=X;
 
340
  Result.Y:=Y;
 
341
  Result.Code:=Code;
 
342
end;
 
343
 
 
344
function CompareCodeXYPositions(Pos1, Pos2: PCodeXYPosition): integer;
 
345
begin
 
346
  if Pointer(Pos1^.Code)>Pointer(Pos2^.Code) then Result:=1
 
347
  else if Pointer(Pos1^.Code)<Pointer(Pos2^.Code) then Result:=-1
 
348
  else if Pos1^.Y<Pos2^.Y then Result:=1
 
349
  else if Pos1^.Y>Pos2^.Y then Result:=-1
 
350
  else if Pos1^.X<Pos2^.X then Result:=1
 
351
  else if Pos1^.Y<Pos2^.Y then Result:=-1
 
352
  else Result:=0;
 
353
end;
 
354
 
 
355
function CompareCodePositions(Pos1, Pos2: PCodePosition): integer;
 
356
begin
 
357
  if Pointer(Pos1^.Code)>Pointer(Pos2^.Code) then Result:=1
 
358
  else if Pointer(Pos1^.Code)<Pointer(Pos2^.Code) then Result:=-1
 
359
  else if Pos1^.P<Pos2^.P then Result:=1
 
360
  else if Pos1^.P>Pos2^.P then Result:=-1
 
361
  else Result:=0;
 
362
end;
 
363
 
 
364
procedure AddCodePosition(var ListOfPCodeXYPosition: TFPList;
 
365
  const NewCodePos: TCodeXYPosition);
 
366
var
 
367
  AddCodePos: PCodeXYPosition;
 
368
begin
 
369
  if ListOfPCodeXYPosition=nil then ListOfPCodeXYPosition:=TFPList.Create;
 
370
  New(AddCodePos);
 
371
  AddCodePos^:=NewCodePos;
 
372
  ListOfPCodeXYPosition.Add(AddCodePos);
 
373
end;
 
374
 
 
375
function IndexOfCodePosition(var ListOfPCodeXYPosition: TFPList;
 
376
  const APosition: PCodeXYPosition): integer;
 
377
begin
 
378
  if ListOfPCodeXYPosition=nil then
 
379
    Result:=-1
 
380
  else begin
 
381
    Result:=ListOfPCodeXYPosition.Count-1;
 
382
    while (Result>=0)
 
383
    and (CompareCodeXYPositions(APosition,
 
384
                             PCodeXYPosition(ListOfPCodeXYPosition[Result]))<>0)
 
385
    do
 
386
      dec(Result);
 
387
  end;
 
388
end;
 
389
 
 
390
procedure FreeListOfPCodeXYPosition(ListOfPCodeXYPosition: TFPList);
 
391
var
 
392
  CurCodePos: PCodeXYPosition;
 
393
  i: Integer;
 
394
begin
 
395
  if ListOfPCodeXYPosition=nil then exit;
 
396
  for i:=0 to ListOfPCodeXYPosition.Count-1 do begin
 
397
    CurCodePos:=PCodeXYPosition(ListOfPCodeXYPosition[i]);
 
398
    Dispose(CurCodePos);
 
399
  end;
 
400
  ListOfPCodeXYPosition.Free;
 
401
end;
 
402
 
 
403
function CreateTreeOfPCodeXYPosition: TAVLTree;
 
404
begin
 
405
  Result:=TAVLTree.Create(TListSortCompare(@CompareCodeXYPositions));
 
406
end;
 
407
 
 
408
procedure AddCodePosition(var TreeOfPCodeXYPosition: TAVLTree;
 
409
  const NewCodePos: TCodeXYPosition);
 
410
var
 
411
  AddCodePos: PCodeXYPosition;
 
412
begin
 
413
  if TreeOfPCodeXYPosition=nil then
 
414
    TreeOfPCodeXYPosition:=TAVLTree.Create(TListSortCompare(@CompareCodeXYPositions));
 
415
  New(AddCodePos);
 
416
  AddCodePos^:=NewCodePos;
 
417
  TreeOfPCodeXYPosition.Add(AddCodePos);
 
418
end;
 
419
 
 
420
procedure FreeTreeOfPCodeXYPosition(TreeOfPCodeXYPosition: TAVLTree);
 
421
var
 
422
  ANode: TAVLTreeNode;
 
423
  CursorPos: PCodeXYPosition;
 
424
begin
 
425
  if TreeOfPCodeXYPosition=nil then exit;
 
426
  ANode:=TreeOfPCodeXYPosition.FindLowest;
 
427
  while ANode<>nil do begin
 
428
    CursorPos:=PCodeXYPosition(ANode.Data);
 
429
    if CursorPos<>nil then
 
430
      Dispose(CursorPos);
 
431
    ANode:=TreeOfPCodeXYPosition.FindSuccessor(ANode);
 
432
  end;
 
433
  TreeOfPCodeXYPosition.Free;
 
434
end;
 
435
 
 
436
procedure AddListToTreeOfPCodeXYPosition(SrcList: TFPList; DestTree: TAVLTree;
 
437
  ClearList, CreateCopies: boolean);
 
438
var
 
439
  i: Integer;
 
440
  CodePos: PCodeXYPosition;
 
441
  NewCodePos: PCodeXYPosition;
 
442
begin
 
443
  if SrcList=nil then exit;
 
444
  for i:=SrcList.Count-1 downto 0 do begin
 
445
    CodePos:=PCodeXYPosition(SrcList[i]);
 
446
    if DestTree.Find(CodePos)=nil then begin
 
447
      // new position -> add
 
448
      if CreateCopies and (not ClearList) then begin
 
449
        // list items should be kept and copies should be added to the tree
 
450
        New(NewCodePos);
 
451
        NewCodePos^:=CodePos^;
 
452
      end else
 
453
        NewCodePos:=CodePos;
 
454
      DestTree.Add(NewCodePos);
 
455
    end else if ClearList then begin
 
456
      // position already exists and items should be deleted
 
457
      Dispose(CodePos);
 
458
    end;
 
459
  end;
 
460
  if ClearList then
 
461
    SrcList.Clear;
 
462
end;
 
463
 
 
464
function ListOfPCodeXYPositionToStr(const ListOfPCodeXYPosition: TFPList
 
465
  ): string;
 
466
var
 
467
  p: TCodeXYPosition;
 
468
  i: Integer;
 
469
begin
 
470
  if ListOfPCodeXYPosition=nil then
 
471
    Result:='nil'
 
472
  else begin
 
473
    Result:='';
 
474
    for i:=0 to ListOfPCodeXYPosition.Count-1 do begin
 
475
      p:=PCodeXYPosition(ListOfPCodeXYPosition[i])^;
 
476
      Result:=Result+'  '+Dbgs(p)+LineEnding;
 
477
    end;
 
478
  end;
 
479
end;
 
480
 
 
481
function Dbgs(const p: TCodeXYPosition): string;
 
482
begin
 
483
  if p.Code=nil then
 
484
    Result:='(none)'
 
485
  else
 
486
    Result:=p.Code.Filename+'(y='+dbgs(p.y)+',x='+dbgs(p.x)+')';
 
487
end;
 
488
 
 
489
function Dbgs(const p: TCodePosition): string;
 
490
var
 
491
  CodeXYPosition: TCodeXYPosition;
 
492
begin
 
493
  FillChar(CodeXYPosition,SizeOf(TCodeXYPosition),0);
 
494
  CodeXYPosition.Code:=p.Code;
 
495
  if CodeXYPosition.Code<>nil then begin
 
496
    CodeXYPosition.Code.AbsoluteToLineCol(p.P,CodeXYPosition.Y,CodeXYPosition.X);
 
497
  end;
 
498
  Result:=Dbgs(CodeXYPosition);
 
499
end;
 
500
 
244
501
{ TCodeCache }
245
502
 
246
503
procedure TCodeCache.Clear;
315
572
end;
316
573
 
317
574
function TCodeCache.LoadFile(const AFilename: string): TCodeBuffer;
318
 
// search file in cache
 
575
var
 
576
  DiskFilename: String;
 
577
 
 
578
  procedure FindDiskFilenameInconsistent;
 
579
  var
 
580
    s: String;
 
581
  begin
 
582
    s:='[TCodeCache.LoadFile] Inconsistency found: AFilename="'+AFilename+'" FindDiskFilename="'+DiskFilename+'"';
 
583
    s:=s+' CompareFilenames='+dbgs(CompareFilenames(AFilename,DiskFilename));
 
584
    raise Exception.Create(s);
 
585
  end;
 
586
 
319
587
begin
320
588
  Result:=FindFile(AFilename);
321
589
  if FilenameIsAbsolute(AFilename) then begin
322
590
    if Result=nil then begin
323
591
      // load new buffer
 
592
      if (not FileExistsCached(AFilename)) then
 
593
        exit;
 
594
      if DirectoryCachePool<>nil then
 
595
        DiskFilename:=DirectoryCachePool.FindDiskFilename(AFilename)
 
596
      else
 
597
        DiskFilename:=FindDiskFilename(AFilename);
 
598
      if FindFile(DiskFilename)<>nil then
 
599
        FindDiskFilenameInconsistent;
324
600
      Result:=TCodeBuffer.Create;
325
 
      if (not FileExistsCached(AFilename)) then begin
326
 
        Result.Free;
327
 
        Result:=nil;
328
 
        exit;
329
 
      end;
330
 
      Result.Filename:=GetFilenameOnDisk(AFilename);
 
601
      Result.Filename:=DiskFilename;
331
602
      Result.FCodeCache:=Self;
332
 
      if (not Result.LoadFromFile(Result.Filename)) then
333
 
      begin
 
603
      if (not Result.LoadFromFile(Result.Filename)) then begin
334
604
        Result.FCodeCache:=nil;
335
605
        Result.Free;
336
606
        Result:=nil;
648
918
function TCodeCache.OnScannerCheckFileOnDisk(Code: pointer): boolean;
649
919
var Buf: TCodeBuffer;
650
920
begin
 
921
  Result:=false;
651
922
  Buf:=TCodeBuffer(Code);
652
923
  //DebugLn(['OnScannerCheckFileOnDisk A ',Buf.Filename,' AutoRev=',Buf.AutoRevertFromDisk,' WriteLock=',GlobalWriteLockIsSet,' DiskChg=',Buf.FileOnDiskHasChanged,' IsDeleted=',Buf.IsDeleted]);
653
924
  if Buf.AutoRevertFromDisk or Buf.IsDeleted then begin
655
926
      if GlobalWriteLockStep<>Buf.GlobalWriteLockStepOnLastLoad then begin
656
927
        Buf.GlobalWriteLockStepOnLastLoad:=GlobalWriteLockStep;
657
928
        if Buf.FileNeedsUpdate then
658
 
          Buf.Revert;
 
929
          Result:=true;
659
930
      end;
660
931
    end else begin
661
932
      if Buf.FileNeedsUpdate then
662
 
        Buf.Revert;
 
933
        Result:=true;
663
934
    end;
664
935
  end else begin
665
936
    //DebugLn(['TCodeCache.OnScannerCheckFileOnDisk AutoRevertFromDisk=',Buf.AutoRevertFromDisk,' ',Buf.Filename]);
666
937
  end;
 
938
  if Result then
 
939
    Buf.Revert;
667
940
  //if buf.IsDeleted then debugln(['TCodeCache.OnScannerCheckFileOnDisk ',Buf.Filename,' still deleted']);
668
 
  Result:=true;
669
941
end;
670
942
 
671
943
procedure TCodeCache.OnScannerIncludeCode(ParentCode, IncludeCode: pointer);
715
987
function TCodeCache.FindIncludeLinkAVLNode(const IncludeFilename: string
716
988
  ): TAVLTreeNode;
717
989
begin
718
 
  Result:=FIncludeLinks.FindKey(@IncludeFilename,
719
 
                                @ComparePAnsiStringWithIncludedByLink);
 
990
  Result:=FIncludeLinks.FindKey(Pointer(IncludeFilename),
 
991
                                @CompareAnsiStringWithIncludedByLink);
720
992
end;
721
993
 
722
994
function TCodeCache.FindIncludeLink(const IncludeFilename: string): string;
969
1241
 
970
1242
procedure TCodeCache.IncreaseChangeStamp;
971
1243
begin
972
 
  if FChangeStamp<high(FChangeStamp) then
973
 
    inc(FChangeStamp)
974
 
  else
975
 
    FChangeStamp:=low(FChangeStamp);
 
1244
  //debugln(['TCodeCache.IncreaseChangeStamp ']);
 
1245
  CTIncreaseChangeStamp64(FChangeStamp);
976
1246
end;
977
1247
 
978
1248
procedure TCodeCache.WriteAllFileNames;
1023
1293
    Result:=false;
1024
1294
    exit;
1025
1295
  end;
1026
 
  if not IsVirtual then begin
 
1296
  if (not IsVirtual) or (Filename='') then begin
1027
1297
    if CompareFilenames(AFilename,Filename)=0 then begin
1028
 
      //DebugLn('****** [TCodeBuffer.LoadFromFile] ',Filename,' FileDateValid=',FileDateValid,' ',FFileDate,',',FileAgeUTF8(Filename),',',FFileChangeStep,',',ChangeStep,', NeedsUpdate=',FileNeedsUpdate);
 
1298
      //DebugLn('[TCodeBuffer.LoadFromFile] ',Filename,' FileDateValid=',FileDateValid,' ',FFileDate,',',FileAgeUTF8(Filename),',',FFileChangeStep,',',ChangeStep,', NeedsUpdate=',FileNeedsUpdate);
1029
1299
      if FileNeedsUpdate then begin
1030
1300
        Result:=inherited LoadFromFile(AFilename);
1031
1301
        if Result then MakeFileDateValid;
1051
1321
      Modified:=false;
1052
1322
    end;
1053
1323
  end;
 
1324
  //debugln(['TCodeBuffer.SaveToFile FileOnDiskHasChanged=',FileOnDiskHasChanged,' LoadDate=',LoadDate,' FileAgeCached=',FileAgeCached(Filename)]);
1054
1325
end;
1055
1326
 
1056
1327
function TCodeBuffer.Reload: boolean;
1121
1392
  end;
1122
1393
end;
1123
1394
 
1124
 
procedure TCodeBuffer.IncreaseChangeStep;
 
1395
procedure TCodeBuffer.DoSourceChanged;
1125
1396
begin
1126
 
  inherited IncreaseChangeStep;
 
1397
  //debugln(['TCodeBuffer.DoSourceChanged ',Filename]);
 
1398
  inherited DoSourceChanged;
1127
1399
  if FCodeCache<>nil then
1128
1400
    FCodeCache.IncreaseChangeStamp;
1129
1401
end;
1136
1408
    CodeCache.DecodeLoaded(Self,AFilename,ASource,ADiskEncoding,AMemEncoding);
1137
1409
end;
1138
1410
 
1139
 
procedure TCodeBuffer.EncodeSaving(const AFilename: string; var ASource: string
1140
 
  );
 
1411
procedure TCodeBuffer.EncodeSaving(const AFilename: string; var ASource: string);
1141
1412
begin
1142
1413
  inherited EncodeSaving(AFilename,ASource);
1143
1414
  if CodeCache<>nil then
1173
1444
function TCodeBuffer.FileNeedsUpdate: boolean;
1174
1445
// file needs update (to be loaded), if file is not modified and file on disk has changed
1175
1446
begin
1176
 
  if Modified then exit(false);
 
1447
  if Modified or IsVirtual then exit(false);
1177
1448
  if LoadDateValid then
1178
1449
    Result:=(FFileChangeStep=ChangeStep) and (FileDateOnDisk<>LoadDate)
1179
1450
  else
1181
1452
end;
1182
1453
 
1183
1454
function TCodeBuffer.FileOnDiskNeedsUpdate: boolean;
1184
 
// file on disk needs update (to be saved), if memory is modified or file does not exist
 
1455
// file on disk needs update (= file needs to be saved), if memory is modified or file does not exist
1185
1456
begin
1186
 
  if LoadDateValid then
1187
 
    Result:=Modified or (FFileChangeStep<>ChangeStep)
1188
 
            or (not FileExistsCached(Filename))
1189
 
  else
1190
 
    Result:=false;
 
1457
  if IsVirtual or IsDeleted then exit(false);
 
1458
  Result:=Modified
 
1459
          or (not LoadDateValid) // file was created in memory, but not yet saved to disk
 
1460
          or (FFileChangeStep<>ChangeStep) // file was modified since last load/save
 
1461
          or (not FileExistsCached(Filename));
1191
1462
end;
1192
1463
 
1193
1464
function TCodeBuffer.FileOnDiskHasChanged: boolean;
 
1465
// file on disk has changed since last load/save
1194
1466
begin
1195
1467
  if LoadDateValid and FileExistsCached(Filename) then
1196
1468
    Result:=(FileDateOnDisk<>LoadDate)
1200
1472
 
1201
1473
function TCodeBuffer.FileOnDiskIsEqual: boolean;
1202
1474
begin
1203
 
  Result:=(not FileOnDiskNeedsUpdate) and (not FileOnDiskHasChanged);
 
1475
  if IsVirtual then
 
1476
    exit(true);
 
1477
  if IsDeleted then
 
1478
    exit(not FileExistsCached(Filename));
 
1479
  if (not LoadDateValid)
 
1480
  or Modified or (FFileChangeStep<>ChangeStep)
 
1481
  or (not FileExistsCached(Filename))
 
1482
  or (FileDateOnDisk<>LoadDate)
 
1483
  then
 
1484
    exit(false);
 
1485
  Result:=true;
1204
1486
end;
1205
1487
 
1206
1488
function TCodeBuffer.AutoRevertFromDisk: boolean;
1267
1549
    +MemSizeString(IncludeFilename);
1268
1550
end;
1269
1551
 
 
1552
{ TCodeXYPositions }
 
1553
 
 
1554
function TCodeXYPositions.GetItems(Index: integer): PCodeXYPosition;
 
1555
begin
 
1556
  Result:=PCodeXYPosition(FItems[Index]);
 
1557
end;
 
1558
 
 
1559
function TCodeXYPositions.GetCaretsXY(Index: integer): TPoint;
 
1560
var
 
1561
  Item: PCodeXYPosition;
 
1562
begin
 
1563
  Item:=Items[Index];
 
1564
  Result:=Point(Item^.X,Item^.Y);
 
1565
end;
 
1566
 
 
1567
function TCodeXYPositions.GetCodes(Index: integer): TCodeBuffer;
 
1568
var
 
1569
  Item: PCodeXYPosition;
 
1570
begin
 
1571
  Item:=Items[Index];
 
1572
  Result:=Item^.Code;
 
1573
end;
 
1574
 
 
1575
procedure TCodeXYPositions.SetCaretsXY(Index: integer; const AValue: TPoint);
 
1576
var
 
1577
  Item: PCodeXYPosition;
 
1578
begin
 
1579
  Item:=Items[Index];
 
1580
  Item^.X:=AValue.X;
 
1581
  Item^.Y:=AValue.Y;
 
1582
end;
 
1583
 
 
1584
procedure TCodeXYPositions.SetCodes(Index: integer; const AValue: TCodeBuffer);
 
1585
var
 
1586
  Item: PCodeXYPosition;
 
1587
begin
 
1588
  Item:=Items[Index];
 
1589
  Item^.Code:=AValue;
 
1590
end;
 
1591
 
 
1592
procedure TCodeXYPositions.SetItems(Index: integer;
 
1593
  const AValue: PCodeXYPosition);
 
1594
begin
 
1595
  FItems[Index]:=AValue;
 
1596
end;
 
1597
 
 
1598
constructor TCodeXYPositions.Create;
 
1599
begin
 
1600
 
 
1601
end;
 
1602
 
 
1603
destructor TCodeXYPositions.Destroy;
 
1604
begin
 
1605
  Clear;
 
1606
  FItems.Free;
 
1607
  FItems:=nil;
 
1608
  inherited Destroy;
 
1609
end;
 
1610
 
 
1611
procedure TCodeXYPositions.Clear;
 
1612
var
 
1613
  i: Integer;
 
1614
  Item: PCodeXYPosition;
 
1615
begin
 
1616
  if FItems<>nil then begin
 
1617
    for i:=0 to FItems.Count-1 do begin
 
1618
      Item:=Items[i];
 
1619
      Dispose(Item);
 
1620
    end;
 
1621
    FItems.Clear;
 
1622
  end;
 
1623
end;
 
1624
 
 
1625
function TCodeXYPositions.Add(const Position: TCodeXYPosition): integer;
 
1626
var
 
1627
  NewItem: PCodeXYPosition;
 
1628
begin
 
1629
  New(NewItem);
 
1630
  NewItem^:=Position;
 
1631
  if FItems=nil then FItems:=TFPList.Create;
 
1632
  Result:=FItems.Add(NewItem);
 
1633
end;
 
1634
 
 
1635
function TCodeXYPositions.Add(X, Y: integer; Code: TCodeBuffer): integer;
 
1636
var
 
1637
  NewItem: TCodeXYPosition;
 
1638
begin
 
1639
  NewItem.X:=X;
 
1640
  NewItem.Y:=Y;
 
1641
  NewItem.Code:=Code;
 
1642
  Result:=Add(NewItem);
 
1643
end;
 
1644
 
 
1645
procedure TCodeXYPositions.Assign(Source: TCodeXYPositions);
 
1646
var
 
1647
  i: Integer;
 
1648
begin
 
1649
  if IsEqual(Source) then exit;
 
1650
  Clear;
 
1651
  for i:=0 to Source.Count-1 do
 
1652
    Add(Source[i]^);
 
1653
end;
 
1654
 
 
1655
function TCodeXYPositions.IsEqual(Source: TCodeXYPositions): boolean;
 
1656
var
 
1657
  SrcItem: TCodeXYPosition;
 
1658
  CurItem: TCodeXYPosition;
 
1659
  i: Integer;
 
1660
begin
 
1661
  if Source=Self then
 
1662
    Result:=true
 
1663
  else if (Source=nil) or (Source.Count<>Count) then
 
1664
    Result:=false
 
1665
  else begin
 
1666
    for i:=0 to Count-1 do begin
 
1667
      SrcItem:=Source[i]^;
 
1668
      CurItem:=Items[i]^;
 
1669
      if (SrcItem.X<>CurItem.X)
 
1670
      or (SrcItem.Y<>CurItem.Y)
 
1671
      or (SrcItem.Code<>CurItem.Code)
 
1672
      then begin
 
1673
        Result:=false;
 
1674
        exit;
 
1675
      end;
 
1676
    end;
 
1677
    Result:=true;
 
1678
  end;
 
1679
end;
 
1680
 
 
1681
function TCodeXYPositions.Count: integer;
 
1682
begin
 
1683
  if FItems<>nil then
 
1684
    Result:=FItems.Count
 
1685
  else
 
1686
    Result:=0;
 
1687
end;
 
1688
 
 
1689
procedure TCodeXYPositions.Delete(Index: integer);
 
1690
var
 
1691
  Item: PCodeXYPosition;
 
1692
begin
 
1693
  Item:=Items[Index];
 
1694
  Dispose(Item);
 
1695
  FItems.Delete(Index);
 
1696
end;
 
1697
 
 
1698
function TCodeXYPositions.CreateCopy: TCodeXYPositions;
 
1699
begin
 
1700
  Result:=TCodeXYPositions.Create;
 
1701
  Result.Assign(Self);
 
1702
end;
 
1703
 
 
1704
function TCodeXYPositions.CalcMemSize: PtrUint;
 
1705
begin
 
1706
  Result:=PtrUInt(InstanceSize);
 
1707
  if FItems<>nil then
 
1708
    inc(Result,PtrUInt(FItems.InstanceSize)
 
1709
      +PtrUInt(FItems.Capacity)*SizeOf(TCodeXYPosition));
 
1710
end;
1270
1711
 
1271
1712
end.
1272
1713