PageRenderTime 28ms CodeModel.GetById 17ms app.highlight 5ms RepoModel.GetById 1ms app.codeStats 0ms

/ide/compatibilityrestrictions.pas

http://github.com/graemeg/lazarus
Pascal | 387 lines | 283 code | 69 blank | 35 comment | 30 complexity | 15f2f0c734bcf42c72f959b16a874b87 MD5 | raw file
  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., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.        *
 23 *                                                                         *
 24 ***************************************************************************
 25
 26  Abstract:
 27    Compatiblity restrictions utilities
 28
 29}
 30unit CompatibilityRestrictions;
 31
 32{$mode objfpc}{$H+}
 33
 34interface
 35
 36uses
 37  Classes, SysUtils, Forms, LCLProc, InterfaceBase, StringHashList,
 38  Laz2_DOM, Laz2_XMLRead, Laz2_XMLWrite,
 39  ObjectInspector, OIFavoriteProperties, PackageIntf,
 40  PackageSystem, PackageDefs, ComponentReg, LazConf;
 41
 42type
 43  TReadRestrictedEvent = procedure (const RestrictedName, WidgetSetName: String) of object;
 44  TReadRestrictedContentEvent = procedure (const Short, Description: String) of object;
 45
 46  PRestriction = ^TRestriction;
 47  TRestriction = record
 48    Name: String;
 49    Short: String;
 50    Description: String;
 51    WidgetSet: TLCLPlatform;
 52  end;
 53  
 54  { TClassHashList }
 55
 56  TClassHashList = class
 57  private
 58    FHashList: TStringHashList;
 59  public
 60    constructor Create;
 61    destructor Destroy; override;
 62    
 63    procedure Add(const AClass: TPersistentClass);
 64    procedure AddComponent(const AClass: TComponentClass);
 65    function Find(const AClassName: String): TPersistentClass;
 66  end;
 67  
 68  TRestrictedList = array of TRestriction;
 69
 70  { TRestrictedManager }
 71
 72  TRestrictedManager = class
 73  private
 74    FRestrictedProperties: TOIRestrictedProperties;
 75    FRestrictedList: TRestrictedList;
 76    FRestrictedFiles: TStringList;
 77    FClassList: TClassHashList;
 78    procedure AddPackage(APackage: TLazPackageID);
 79    procedure AddRestricted(const RestrictedName, WidgetSetName: String);
 80    procedure AddRestrictedContent(const Short, Description: String);
 81    procedure AddRestrictedProperty(const RestrictedName, WidgetSetName: String);
 82    procedure GatherRestrictedFiles;
 83    procedure ReadRestrictions(const Filename: String;
 84      OnReadRestricted: TReadRestrictedEvent;
 85      OnReadRestrictedContent: TReadRestrictedContentEvent);
 86  public
 87    constructor Create;
 88    destructor Destroy; override;
 89    
 90    function GetRestrictedProperties: TOIRestrictedProperties;
 91    function GetRestrictedList: TRestrictedList;
 92  end;
 93
 94  
 95function GetRestrictedProperties: TOIRestrictedProperties;
 96function GetRestrictedList: TRestrictedList;
 97  
 98implementation
 99
100var
101  RestrictedManager: TRestrictedManager = nil;
102  
103{ TClassHashList }
104
105constructor TClassHashList.Create;
106begin
107  inherited;
108  
109  FHashList := TStringHashList.Create(False);
110end;
111
112destructor TClassHashList.Destroy;
113begin
114  FHashList.Free;
115  
116  inherited;
117end;
118
119procedure TClassHashList.Add(const AClass: TPersistentClass);
120var
121  C: TClass;
122begin
123  C := AClass;
124  while (C <> nil) and (FHashList.Find(C.ClassName) < 0) do
125  begin
126    FHashList.Add(C.ClassName, Pointer(C));
127    if (C = TPersistent) then Break;
128    C := C.ClassParent;
129  end;
130end;
131
132procedure TClassHashList.AddComponent(const AClass: TComponentClass);
133begin
134  Add(AClass);
135end;
136
137function TClassHashList.Find(const AClassName: String): TPersistentClass;
138begin
139  Result := TPersistentClass(FHashList.Data[AClassName]);
140end;
141
142
143function GetRestrictedProperties: TOIRestrictedProperties;
144begin
145  if RestrictedManager = nil then
146    RestrictedManager := TRestrictedManager.Create;
147  Result := RestrictedManager.GetRestrictedProperties;
148end;
149
150function GetRestrictedList: TRestrictedList;
151begin
152  if RestrictedManager = nil then
153    RestrictedManager := TRestrictedManager.Create;
154  Result := RestrictedManager.GetRestrictedList;
155end;
156
157{ TRestrictedManager }
158
159function TRestrictedManager.GetRestrictedProperties: TOIRestrictedProperties;
160var
161  I: Integer;
162begin
163  Result := nil;
164  FreeAndNil(FRestrictedProperties);
165  FRestrictedProperties := TOIRestrictedProperties.Create;
166
167
168  FClassList := TClassHashList.Create;
169  try
170    IDEComponentPalette.IterateRegisteredClasses(@(FClassList.AddComponent));
171    FClassList.Add(TForm);
172    FClassList.Add(TDataModule);
173  
174    for I := 0 to FRestrictedFiles.Count - 1 do
175      ReadRestrictions(FRestrictedFiles[I], @AddRestrictedProperty, nil);
176    
177    Result := FRestrictedProperties;
178  finally
179    FreeAndNil(FClassList);
180  end;
181end;
182
183function TRestrictedManager.GetRestrictedList: TRestrictedList;
184var
185  I: Integer;
186begin
187  SetLength(FRestrictedList, 0);
188
189  for I := 0 to FRestrictedFiles.Count - 1 do
190    ReadRestrictions(FRestrictedFiles[I], @AddRestricted, @AddRestrictedContent);
191    
192  Result := FRestrictedList;
193end;
194
195procedure TRestrictedManager.AddPackage(APackage: TLazPackageID);
196var
197  ALazPackage: TLazPackage;
198  I: Integer;
199begin
200  if APackage = nil then Exit;
201  ALazPackage := PackageGraph.FindPackageWithID(APackage);
202  if ALazPackage = nil then Exit;
203  
204  for I := 0 to ALazPackage.FileCount - 1 do
205    if ALazPackage.Files[I].FileType = pftIssues then
206      FRestrictedFiles.Add(ALazPackage.Files[I].GetFullFilename);
207end;
208
209procedure TRestrictedManager.AddRestricted(const RestrictedName, WidgetSetName: String);
210begin
211  SetLength(FRestrictedList, Succ(Length(FRestrictedList)));
212  FRestrictedList[High(FRestrictedList)].Name := RestrictedName;
213  FRestrictedList[High(FRestrictedList)].WidgetSet := DirNameToLCLPlatform(WidgetSetName);
214  FRestrictedList[High(FRestrictedList)].Short := '';
215  FRestrictedList[High(FRestrictedList)].Description := '';
216end;
217
218procedure TRestrictedManager.AddRestrictedContent(const Short, Description: String);
219begin
220  if Length(FRestrictedList) = 0 then Exit;
221  FRestrictedList[High(FRestrictedList)].Short := Short;
222  FRestrictedList[High(FRestrictedList)].Description := Description;
223end;
224
225procedure TRestrictedManager.AddRestrictedProperty(const RestrictedName, WidgetSetName: String);
226var
227  Issue: TOIRestrictedProperty;
228  AClass: TPersistentClass;
229  AProperty: String;
230  P: Integer;
231begin
232  if RestrictedName = '' then Exit;
233
234  P := Pos('.', RestrictedName);
235  if P = 0 then
236  begin
237    AClass := FClassList.Find(RestrictedName);
238    AProperty := '';
239  end
240  else
241  begin
242    AClass := FClassList.Find(Copy(RestrictedName, 0, P - 1));
243    AProperty := Copy(RestrictedName, P + 1, MaxInt);
244  end;
245  
246  if AClass = nil then
247  begin
248    // add as generic widgetset issue
249    FRestrictedProperties.WidgetSetRestrictions[DirNameToLCLPlatform(WidgetSetName)] := FRestrictedProperties.WidgetSetRestrictions[DirNameToLCLPlatform(WidgetSetName)] + 1;
250    Exit;
251  end;
252  
253  Issue := TOIRestrictedProperty.Create(AClass, AProperty, True);
254  Issue.WidgetSets := [DirNameToLCLPlatform(WidgetSetName)];
255  FRestrictedProperties.Add(Issue);
256end;
257
258procedure TRestrictedManager.GatherRestrictedFiles;
259begin
260  FRestrictedFiles.Clear;
261  PackageGraph.IteratePackages([fpfSearchInInstalledPckgs], @AddPackage);
262end;
263
264procedure TRestrictedManager.ReadRestrictions(const Filename: String;
265  OnReadRestricted: TReadRestrictedEvent;
266  OnReadRestrictedContent: TReadRestrictedContentEvent);
267var
268  IssueFile: TXMLDocument;
269  R, N: TDOMNode;
270  
271  function ReadContent(ANode: TDOMNode): String;
272  var
273    S: TStringStream;
274    N: TDOMNode;
275  begin
276    Result := '';
277    S := TStringStream.Create('');
278    try
279      N := ANode.FirstChild;
280      while N <> nil do
281      begin
282        WriteXML(N, S);
283        N := N.NextSibling;
284      end;
285      
286      Result := S.DataString;
287    finally
288      S.Free;
289    end;
290  end;
291  
292  procedure ParseWidgetSet(ANode: TDOMNode);
293  var
294    WidgetSetName, IssueName, Short, Description: String;
295    IssueNode, AttrNode, IssueContentNode: TDOMNode;
296  begin
297    AttrNode := ANode.Attributes.GetNamedItem('name');
298    if AttrNode <> nil then WidgetSetName := AttrNode.NodeValue
299    else WidgetSetName := 'win32';
300    
301    IssueNode := ANode.FirstChild;
302    while IssueNode <> nil do
303    begin
304      if IssueNode.NodeName = 'issue' then
305      begin
306        AttrNode := IssueNode.Attributes.GetNamedItem('name');
307        if AttrNode <> nil then IssueName := AttrNode.NodeValue
308        else IssueName := 'win32';
309        
310        if Assigned(OnReadRestricted) then
311          OnReadRestricted(IssueName, WidgetSetName);
312        if Assigned(OnReadRestrictedContent) then
313        begin
314          Short := '';
315          Description := '';
316          
317          IssueContentNode := IssueNode.FirstChild;
318          while IssueContentNode <> nil do
319          begin
320            if IssueContentNode.NodeName = 'short' then
321              Short := ReadContent(IssueContentNode)
322            else
323              if IssueContentNode.NodeName = 'descr' then
324                Description := ReadContent(IssueContentNode);
325
326            IssueContentNode := IssueContentNode.NextSibling;
327          end;
328          
329          OnReadRestrictedContent(Short, Description);
330        end;
331      end;
332      IssueNode := IssueNode.NextSibling;
333    end;
334  end;
335  
336begin
337  try
338    ReadXMLFile(IssueFile, Filename);
339  except
340     on E: Exception do
341       DebugLn('TIssueManager.ReadFileIssues failed: ' + E.Message);
342  end;
343  
344  try
345    if IssueFile = nil then Exit;
346
347    R := IssueFile.FindNode('package');
348    if R = nil then Exit;
349
350    N := R.FirstChild;
351    while N <> nil do
352    begin
353      if N.NodeName = 'widgetset' then
354        ParseWidgetSet(N);
355
356      N := N.NextSibling;
357    end;
358  finally
359    IssueFile.Free;
360  end;
361end;
362
363constructor TRestrictedManager.Create;
364begin
365  inherited;
366  
367  FRestrictedFiles := TStringList.Create;
368  FRestrictedProperties := nil;
369  
370  GatherRestrictedFiles;
371end;
372
373destructor TRestrictedManager.Destroy;
374begin
375  FreeAndNil(FRestrictedFiles);
376  FreeAndNil(FRestrictedProperties);
377  
378  inherited Destroy;
379end;
380
381
382finalization
383
384  FreeAndNil(RestrictedManager);
385
386
387end.