1 { /***************************************************************************
2 CompatibilityRestrictions.pas - Lazarus IDE unit
3 --------------------------------------------------
4
5 ***************************************************************************/
6
7 ***************************************************************************
8 * *
9 * This source is free software; you can redistribute it and/or modify *
10 * it under the terms of the GNU General Public License as published by *
11 * the Free Software Foundation; either version 2 of the License, or *
12 * (at your option) any later version. *
13 * *
14 * This code is distributed in the hope that it will be useful, but *
15 * WITHOUT ANY WARRANTY; without even the implied warranty of *
16 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU *
17 * General Public License for more details. *
18 * *
19 * A copy of the GNU General Public License is available on the World *
20 * Wide Web at <http://www.gnu.org/copyleft/gpl.html>. You can also *
21 * obtain it by writing to the Free Software Foundation, *
22 * Inc., 51 Franklin Street - Fifth Floor, Boston, MA 02110-1335, USA. *
23 * *
24 ***************************************************************************
25
26 Abstract:
27 Compatiblity restrictions utilities
28
29 }
30 unit CompatibilityRestrictions;
31
32 {$mode objfpc}{$H+}
33
34 interface
35
36 uses
37 Classes, SysUtils,
38 // LCL
39 Forms, LCLProc, LCLPlatformDef,
40 // LazUtils
41 Laz2_DOM, Laz2_XMLRead, Laz2_XMLWrite, StringHashList,
42 // IdeIntf
43 OIFavoriteProperties, PackageIntf, ComponentReg,
44 // IDE
45 PackageSystem, PackageDefs;
46
47 type
48 TReadRestrictedEvent = procedure (const RestrictedName, WidgetSetName: String) of object;
49 TReadRestrictedContentEvent = procedure (const Short, Description: String) of object;
50
51 PRestriction = ^TRestriction;
52 TRestriction = record
53 Name: String;
54 Short: String;
55 Description: String;
56 WidgetSet: TLCLPlatform;
57 end;
58
59 { TClassHashList }
60
61 TClassHashList = class
62 private
63 FHashList: TStringHashList;
64 public
65 constructor Create;
66 destructor Destroy; override;
67
68 procedure Add(const AClass: TPersistentClass);
69 procedure AddComponent(const AClass: TComponentClass);
Findnull70 function Find(const AClassName: String): TPersistentClass;
71 end;
72
73 TRestrictedList = array of TRestriction;
74
75 { TRestrictedManager }
76
77 TRestrictedManager = class
78 private
79 FRestrictedProperties: TOIRestrictedProperties;
80 FRestrictedList: TRestrictedList;
81 FRestrictedFiles: TStringList;
82 FClassList: TClassHashList;
83 procedure AddPackage(APackage: TLazPackageID);
84 procedure AddRestricted(const RestrictedName, WidgetSetName: String);
85 procedure AddRestrictedContent(const Short, Description: String);
86 procedure AddRestrictedProperty(const RestrictedName, WidgetSetName: String);
87 procedure GatherRestrictedFiles;
88 procedure ReadRestrictions(const Filename: String;
89 OnReadRestricted: TReadRestrictedEvent;
90 OnReadRestrictedContent: TReadRestrictedContentEvent);
91 public
92 constructor Create;
93 destructor Destroy; override;
94
GetRestrictedPropertiesnull95 function GetRestrictedProperties: TOIRestrictedProperties;
GetRestrictedListnull96 function GetRestrictedList: TRestrictedList;
97 end;
98
99
GetRestrictedPropertiesnull100 function GetRestrictedProperties: TOIRestrictedProperties;
GetRestrictedListnull101 function GetRestrictedList: TRestrictedList;
102
103 implementation
104
105 var
106 RestrictedManager: TRestrictedManager = nil;
107
108 { TClassHashList }
109
110 constructor TClassHashList.Create;
111 begin
112 inherited;
113
114 FHashList := TStringHashList.Create(False);
115 end;
116
117 destructor TClassHashList.Destroy;
118 begin
119 FHashList.Free;
120
121 inherited;
122 end;
123
124 procedure TClassHashList.Add(const AClass: TPersistentClass);
125 var
126 C: TClass;
127 begin
128 C := AClass;
129 while (C <> nil) and (FHashList.Find(C.ClassName) < 0) do
130 begin
131 FHashList.Add(C.ClassName, Pointer(C));
132 if (C = TPersistent) then Break;
133 C := C.ClassParent;
134 end;
135 end;
136
137 procedure TClassHashList.AddComponent(const AClass: TComponentClass);
138 begin
139 Add(AClass);
140 end;
141
TClassHashList.Findnull142 function TClassHashList.Find(const AClassName: String): TPersistentClass;
143 begin
144 Result := TPersistentClass(FHashList.Data[AClassName]);
145 end;
146
147
GetRestrictedPropertiesnull148 function GetRestrictedProperties: TOIRestrictedProperties;
149 begin
150 if RestrictedManager = nil then
151 RestrictedManager := TRestrictedManager.Create;
152 Result := RestrictedManager.GetRestrictedProperties;
153 end;
154
GetRestrictedListnull155 function GetRestrictedList: TRestrictedList;
156 begin
157 if RestrictedManager = nil then
158 RestrictedManager := TRestrictedManager.Create;
159 Result := RestrictedManager.GetRestrictedList;
160 end;
161
162 { TRestrictedManager }
163
GetRestrictedPropertiesnull164 function TRestrictedManager.GetRestrictedProperties: TOIRestrictedProperties;
165 var
166 I: Integer;
167 begin
168 Result := nil;
169 FreeAndNil(FRestrictedProperties);
170 FRestrictedProperties := TOIRestrictedProperties.Create;
171
172
173 FClassList := TClassHashList.Create;
174 try
175 IDEComponentPalette.IterateRegisteredClasses(@(FClassList.AddComponent));
176 FClassList.Add(TForm);
177 FClassList.Add(TDataModule);
178
179 for I := 0 to FRestrictedFiles.Count - 1 do
180 ReadRestrictions(FRestrictedFiles[I], @AddRestrictedProperty, nil);
181
182 Result := FRestrictedProperties;
183 finally
184 FreeAndNil(FClassList);
185 end;
186 end;
187
GetRestrictedListnull188 function TRestrictedManager.GetRestrictedList: TRestrictedList;
189 var
190 I: Integer;
191 begin
192 SetLength(FRestrictedList, 0);
193
194 for I := 0 to FRestrictedFiles.Count - 1 do
195 ReadRestrictions(FRestrictedFiles[I], @AddRestricted, @AddRestrictedContent);
196
197 Result := FRestrictedList;
198 end;
199
200 procedure TRestrictedManager.AddPackage(APackage: TLazPackageID);
201 var
202 ALazPackage: TLazPackage;
203 I: Integer;
204 begin
205 if APackage = nil then Exit;
206 ALazPackage := PackageGraph.FindPackageWithID(APackage);
207 if ALazPackage = nil then Exit;
208
209 for I := 0 to ALazPackage.FileCount - 1 do
210 if ALazPackage.Files[I].FileType = pftIssues then
211 FRestrictedFiles.Add(ALazPackage.Files[I].GetFullFilename);
212 end;
213
214 procedure TRestrictedManager.AddRestricted(const RestrictedName, WidgetSetName: String);
215 begin
216 SetLength(FRestrictedList, Succ(Length(FRestrictedList)));
217 FRestrictedList[High(FRestrictedList)].Name := RestrictedName;
218 FRestrictedList[High(FRestrictedList)].WidgetSet := DirNameToLCLPlatform(WidgetSetName);
219 FRestrictedList[High(FRestrictedList)].Short := '';
220 FRestrictedList[High(FRestrictedList)].Description := '';
221 end;
222
223 procedure TRestrictedManager.AddRestrictedContent(const Short, Description: String);
224 begin
225 if Length(FRestrictedList) = 0 then Exit;
226 FRestrictedList[High(FRestrictedList)].Short := Short;
227 FRestrictedList[High(FRestrictedList)].Description := Description;
228 end;
229
230 procedure TRestrictedManager.AddRestrictedProperty(const RestrictedName, WidgetSetName: String);
231 var
232 Issue: TOIRestrictedProperty;
233 AClass: TPersistentClass;
234 AProperty: String;
235 P: Integer;
236 Platform: TLCLPlatform;
237 begin
238 if RestrictedName = '' then Exit;
239
240 P := Pos('.', RestrictedName);
241 if P = 0 then
242 begin
243 AClass := FClassList.Find(RestrictedName);
244 AProperty := '';
245 end
246 else
247 begin
248 AClass := FClassList.Find(Copy(RestrictedName, 0, P - 1));
249 AProperty := Copy(RestrictedName, P + 1, MaxInt);
250 end;
251
252 Platform:=DirNameToLCLPlatform(WidgetSetName);
253 if AClass = nil then
254 begin
255 // add as generic widgetset issue
256 //debugln('TRestrictedManager.AddRestrictedProperty ',RestrictedName,' ',WidgetSetName);
257 inc(FRestrictedProperties.WidgetSetRestrictions[Platform]);
258 Exit;
259 end;
260
261 Issue := TOIRestrictedProperty.Create(AClass, AProperty, True);
262 Issue.WidgetSets := [Platform];
263 FRestrictedProperties.Add(Issue);
264 end;
265
266 procedure TRestrictedManager.GatherRestrictedFiles;
267 begin
268 FRestrictedFiles.Clear;
269 PackageGraph.IteratePackages([fpfSearchInInstalledPckgs], @AddPackage);
270 end;
271
272 procedure TRestrictedManager.ReadRestrictions(const Filename: String;
273 OnReadRestricted: TReadRestrictedEvent;
274 OnReadRestrictedContent: TReadRestrictedContentEvent);
275 var
276 IssueFile: TXMLDocument;
277 R, N: TDOMNode;
278
ReadContentnull279 function ReadContent(ANode: TDOMNode): String;
280 var
281 S: TStringStream;
282 N: TDOMNode;
283 begin
284 Result := '';
285 S := TStringStream.Create('');
286 try
287 N := ANode.FirstChild;
288 while N <> nil do
289 begin
290 WriteXML(N, S);
291 N := N.NextSibling;
292 end;
293
294 Result := S.DataString;
295 finally
296 S.Free;
297 end;
298 end;
299
300 procedure ParseWidgetSet(ANode: TDOMNode);
301 var
302 WidgetSetName, IssueName, Short, Description: String;
303 IssueNode, AttrNode, IssueContentNode: TDOMNode;
304 begin
305 AttrNode := ANode.Attributes.GetNamedItem('name');
306 if AttrNode <> nil then WidgetSetName := AttrNode.NodeValue
307 else WidgetSetName := 'win32';
308
309 IssueNode := ANode.FirstChild;
310 while IssueNode <> nil do
311 begin
312 if IssueNode.NodeName = 'issue' then
313 begin
314 AttrNode := IssueNode.Attributes.GetNamedItem('name');
315 if AttrNode <> nil then IssueName := AttrNode.NodeValue
316 else IssueName := 'win32';
317
318 if Assigned(OnReadRestricted) then
319 OnReadRestricted(IssueName, WidgetSetName);
320 if Assigned(OnReadRestrictedContent) then
321 begin
322 Short := '';
323 Description := '';
324
325 IssueContentNode := IssueNode.FirstChild;
326 while IssueContentNode <> nil do
327 begin
328 if IssueContentNode.NodeName = 'short' then
329 Short := ReadContent(IssueContentNode)
330 else
331 if IssueContentNode.NodeName = 'descr' then
332 Description := ReadContent(IssueContentNode);
333
334 IssueContentNode := IssueContentNode.NextSibling;
335 end;
336
337 OnReadRestrictedContent(Short, Description);
338 end;
339 end;
340 IssueNode := IssueNode.NextSibling;
341 end;
342 end;
343
344 begin
345 try
346 ReadXMLFile(IssueFile, Filename);
347 except
348 on E: Exception do
349 DebugLn('TIssueManager.ReadFileIssues failed: ' + E.Message);
350 end;
351
352 try
353 if IssueFile = nil then Exit;
354
355 R := IssueFile.FindNode('package');
356 if R = nil then Exit;
357
358 N := R.FirstChild;
359 while N <> nil do
360 begin
361 if N.NodeName = 'widgetset' then
362 ParseWidgetSet(N);
363
364 N := N.NextSibling;
365 end;
366 finally
367 IssueFile.Free;
368 end;
369 end;
370
371 constructor TRestrictedManager.Create;
372 begin
373 inherited;
374
375 FRestrictedFiles := TStringList.Create;
376 FRestrictedProperties := nil;
377
378 GatherRestrictedFiles;
379 end;
380
381 destructor TRestrictedManager.Destroy;
382 begin
383 FreeAndNil(FRestrictedFiles);
384 FreeAndNil(FRestrictedProperties);
385
386 inherited Destroy;
387 end;
388
389
390 finalization
391
392 FreeAndNil(RestrictedManager);
393
394
395 end.
396