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 Scanning FPC sources in background.
25
26 }
27 unit FPCSrcScan;
28
29 {$mode objfpc}{$H+}
30
31 interface
32
33 uses
34 Classes, SysUtils, FileProcs, LazFileUtils, DefineTemplates, CodeToolManager,
35 LazarusIDEStrConsts, ProgressWnd, BaseBuildManager;
36
37 type
38 TFPCSrcScans = class;
39
40 { TFPCSrcScan }
41
42 TFPCSrcScan = class(TThread)
43 protected
44 fLogMsg: string;
45 fFiles: TStringList;
46 procedure Execute; override;
47 procedure OnFilesGathered; // main thread, called after thread has collected Files
48 procedure MainThreadLog;
49 procedure Log(Msg: string);
50 public
51 Directory: string;
52 Scans: TFPCSrcScans;
53 ProgressItem: TIDEProgressItem;
54 end;
55
56 { TFPCSrcScans }
57
58 TFPCSrcScans = class(TComponent)
59 private
60 fItems: TFPList;
61 FCritSec: TRTLCriticalSection;
GetItemsnull62 function GetItems(Index: integer): TFPCSrcScan;
63 procedure Remove(Item: TFPCSrcScan);
64 public
65 constructor Create(AOwner: TComponent); override;
66 destructor Destroy; override;
Countnull67 function Count: integer; // requires Enter/Leave
68 property Items[Index: integer]: TFPCSrcScan read GetItems; default; // requires Enter/Leave
69 procedure Clear; // waits until all
70 procedure EnterCriticalsection;
71 procedure LeaveCriticalsection;
72 procedure Scan(Directory: string);
73 end;
74
75 procedure ApplyFPCSrcFiles(FPCSrcDir: string; var Files: TStringList);
76
77 implementation
78
79 procedure ApplyFPCSrcFiles(FPCSrcDir: string; var Files: TStringList);
80 var
81 SrcCache: TFPCSourceCache;
82 begin
83 debugln(['ApplyFPCSrcFiles ',FPCSrcDir,' FileCount=',Files.Count]);
84 // copy Files to codetools cache
85 if CodeToolBoss<>nil then
86 begin
87 SrcCache:=CodeToolBoss.CompilerDefinesCache.SourceCaches.Find(FPCSrcDir,true);
88 debugln(['ApplyFPCSrcFiles SrcCache.Update ...']);
89 SrcCache.Update(Files);
90
91 debugln(['ApplyFPCSrcFiles BuildBoss.RescanCompilerDefines ...']);
92 if BuildBoss<>nil then
93 BuildBoss.RescanCompilerDefines(false,false,false,true);
94 end;
95 FreeAndNil(Files);
96 end;
97
98 { TFPCSrcScan }
99
100 procedure TFPCSrcScan.Execute;
101 begin
102 try
103 Log('TFPCSrcScan.Execute START '+Directory);
104 // scan fpc source directory, check for terminated
105 fFiles:=GatherFilesInFPCSources(Directory,nil);
106 Log('TFPCSrcScan.Execute found some files: '+dbgs((fFiles<>nil) and (fFiles.Count>0)));
107 except
108 on E: Exception do begin
109 Log('TFPCSrcScan.Execute error: '+E.Message);
110 end;
111 end;
112 if fFiles=nil then
113 fFiles:=TStringList.Create;
114 // let main thread update the codetools fpc source cache
115 Synchronize(@OnFilesGathered);
116 end;
117
118 procedure TFPCSrcScan.OnFilesGathered;
119 begin
120 try
121 ApplyFPCSrcFiles(Directory,fFiles);
122 // delete item in progress window
123 debugln(['TFPCSrcScan.OnFilesGathered closing progress item ...']);
124 ProgressItem.Window.Close;
125 FreeAndNil(ProgressItem);
126 Scans.Remove(Self);
127 debugln(['TFPCSrcScan.OnFilesGathered END']);
128 except
129 on E: Exception do
130 debugln(['TFPCSrcScan.OnFilesGathered ERROR: ',E.Message]);
131 end;
132 end;
133
134 procedure TFPCSrcScan.MainThreadLog;
135 begin
136 debugln(fLogMsg);
137 end;
138
139 procedure TFPCSrcScan.Log(Msg: string);
140 begin
141 fLogMsg:=Msg;
142 Synchronize(@MainThreadLog);
143 end;
144
145 { TFPCSrcScans }
146
TFPCSrcScans.GetItemsnull147 function TFPCSrcScans.GetItems(Index: integer): TFPCSrcScan;
148 begin
149 Result:=TFPCSrcScan(fItems[Index]);
150 end;
151
152 procedure TFPCSrcScans.Remove(Item: TFPCSrcScan);
153 begin
154 EnterCriticalsection;
155 try
156 fItems.Remove(Item);
157 finally
158 LeaveCriticalsection;
159 end;
160 end;
161
162 constructor TFPCSrcScans.Create(AOwner: TComponent);
163 begin
164 inherited Create(AOwner);
165 fItems:=TFPList.Create;
166 InitCriticalSection(FCritSec);
167 end;
168
169 destructor TFPCSrcScans.Destroy;
170 begin
171 Clear;
172 FreeAndNil(fItems);
173 DoneCriticalsection(FCritSec);
174 inherited Destroy;
175 end;
176
Countnull177 function TFPCSrcScans.Count: integer;
178 begin
179 Result:=fItems.Count;
180 end;
181
182 procedure TFPCSrcScans.Clear;
183 var
184 i: Integer;
185 begin
186 // terminate all threads
187 EnterCriticalsection;
188 try
189 for i:=0 to Count-1 do
190 Items[i].Terminate;
191 finally
192 LeaveCriticalsection;
193 end;
194 repeat
195 EnterCriticalsection;
196 try
197 if Count=0 then break;
198 finally
199 LeaveCriticalsection;
200 end;
201 Sleep(10);
202 until false;
203 end;
204
205 procedure TFPCSrcScans.EnterCriticalsection;
206 begin
207 System.EnterCriticalsection(FCritSec);
208 end;
209
210 procedure TFPCSrcScans.LeaveCriticalsection;
211 begin
212 System.LeaveCriticalsection(FCritSec);
213 end;
214
215 procedure TFPCSrcScans.Scan(Directory: string);
216 var
217 {$IFDEF DisableMultiThreading}
218 Files: TStringList;
219 {$ELSE}
220 i: Integer;
221 Item: TFPCSrcScan;
222 {$ENDIF}
223 begin
224 {$IFDEF DisableMultiThreading}
225 // scan fpc source directory, check for terminated
226 Files:=GatherFilesInFPCSources(Directory,nil);
227 if Files=nil then
228 Files:=TStringList.Create;
229 ApplyFPCSrcFiles(Directory,Files);
230 {$ELSE}
231 EnterCriticalsection;
232 try
233 // check if already scanning that directory
234 for i:=0 to Count-1 do
235 if CompareFilenames(Directory,Items[i].Directory)=0 then exit;
236 // create thread and create progress window
237 Item:=TFPCSrcScan.Create(true);
238 Item.FreeOnTerminate:=true;
239 Item.Scans:=Self;
240 Item.Directory:=Directory;
241 fItems.Add(Item);
242 finally
243 LeaveCriticalsection;
244 end;
245 Item.ProgressItem:=CreateProgressItem('FPCSrcScan',
246 Format(lisCreatingFileIndexOfFPCSources, [Directory]),
247 lisTheFileIndexIsNeededForFunctionsLikeFindDeclaratio);
248 Item.Start;
249 {$ENDIF}
250 end;
251
252 end.
253
254