PageRenderTime 49ms CodeModel.GetById 35ms app.highlight 8ms RepoModel.GetById 0ms app.codeStats 1ms

/designer/changeclassdialog.pas

http://github.com/graemeg/lazarus
Pascal | 498 lines | 398 code | 41 blank | 59 comment | 53 complexity | 9ac8dee56367bb0e2ae44daf476434e6 MD5 | raw file
  1{ /***************************************************************************
  2                 ChangeClassDialog.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  Author: Mattias Gaertner
 27
 28  Abstract:
 29    Functions and Dialog to change the class of a designer component.
 30}
 31unit ChangeClassDialog;
 32
 33{$mode objfpc}{$H+}
 34
 35interface
 36
 37uses
 38  Classes, SysUtils, LCLProc, LResources, Forms, Controls, Graphics, Dialogs,
 39  StdCtrls, Buttons, AVGLvlTree, LFMTrees, CodeCache, CodeToolManager, LCLType,
 40  // IDE
 41  SrcEditorIntf, PropEdits, LazarusIDEStrConsts, ComponentReg, ComponentEditors,
 42  FormEditingIntf, IDEDialogs, CheckLFMDlg, Project, MainIntf, ExtCtrls,
 43  ButtonPanel;
 44
 45type
 46
 47  { TChangeClassDlg }
 48
 49  TChangeClassDlg = class(TForm)
 50    BtnPanel: TButtonPanel;
 51    NewClassComboBox: TComboBox;
 52    NewAncestorsListBox: TListBox;
 53    OldAncestorsListBox: TListBox;
 54    OldClassLabel: TLabel;
 55    NewGroupBox: TGroupBox;
 56    OldGroupBox: TGroupBox;
 57    procedure ChangeClassDlgCreate(Sender: TObject);
 58    procedure NewClassComboBoxEditingDone(Sender: TObject);
 59    procedure NewClassComboBoxKeyUp(Sender: TObject; var Key: Word;
 60      {%H-}Shift: TShiftState);
 61  private
 62    FClasses: TAvgLvlTree;
 63    FNewClass: TClass;
 64    FThePersistent: TPersistent;
 65    procedure SetNewClass(const AValue: TClass);
 66    procedure SetThePersistent(const AValue: TPersistent);
 67    procedure UpdateInfo;
 68    procedure UpdateOldInfo;
 69    procedure UpdateNewInfo;
 70    procedure FillAncestorListBox(AClass: TClass; AListBox: TListBox);
 71    procedure AddClass(const AClass: TPersistentClass);
 72    procedure AddComponentClass(const AClass: TComponentClass);
 73    function CompareClasses({%H-}Tree: TAvgLvlTree; Class1, Class2: TClass): integer;
 74  public
 75    destructor Destroy; override;
 76    procedure FillNewClassComboBox;
 77    property ThePersistent: TPersistent read FThePersistent write SetThePersistent;
 78    property NewClass: TClass read FNewClass write SetNewClass;
 79  end;
 80
 81function ShowChangeClassDialog(ADesigner: TIDesigner;
 82  APersistent: TPersistent): TModalResult;
 83function ChangePersistentClass(ADesigner: TIDesigner;
 84  APersistent: TPersistent; NewClass: TClass): TModalResult;
 85
 86implementation
 87
 88{$R *.lfm}
 89
 90function ShowChangeClassDialog(ADesigner: TIDesigner;
 91  APersistent: TPersistent): TModalResult;
 92var
 93  ChangeClassDlg: TChangeClassDlg;
 94begin
 95  Result:=mrCancel;
 96  ChangeClassDlg:=TChangeClassDlg.Create(nil);
 97  try
 98    ChangeClassDlg.ThePersistent:=APersistent;
 99    ChangeClassDlg.FillNewClassComboBox;
100    if ChangeClassDlg.ShowModal=mrOk then begin
101      Result:=ChangePersistentClass(ADesigner,APersistent,ChangeClassDlg.NewClass);
102    end;
103  finally
104    ChangeClassDlg.Free;
105  end;
106end;
107
108function ChangePersistentClass(ADesigner: TIDesigner;
109  APersistent: TPersistent; NewClass: TClass): TModalResult;
110var
111  ComponentStream: TMemoryStream;
112  PersistentName: String;
113  UnitCode: TCodeBuffer;
114  LFMBuffer: TCodeBuffer;
115  LFMTree: TLFMTree;
116  UnitInfo: TUnitInfo;
117  OldParents: TStrings; // Name=OldParent pairs
118
119  procedure ShowAbortMessage(const Msg: string);
120  begin
121    IDEMessageDialog('Error',
122      Format(lisUnableToChangeClassOfTo, [Msg, LineEnding, PersistentName,
123        NewClass.ClassName]),
124      mtError,[mbCancel]);
125  end;
126
127  function StreamSelection: boolean;
128  begin
129    Result:=false;
130    // select only this persistent
131    GlobalDesignHook.SelectOnlyThis(APersistent);
132    if (APersistent is TControl)
133    and (TControl(APersistent).Parent<>nil) then begin
134      if OldParents=nil then
135        OldParents:=TStringList.Create;
136      OldParents.Values[TControl(APersistent).Name]:=TControl(APersistent).Parent.Name;
137    end;
138
139    // stream selection
140    ComponentStream:=TMemoryStream.Create;
141    if (not FormEditingHook.SaveSelectionToStream(ComponentStream))
142    or (ComponentStream.Size=0) then begin
143      ShowAbortMessage(lisUnableToStreamSelectedComponents2);
144      exit;
145    end;
146    Result:=true;
147  end;
148
149  function ParseLFMStream: boolean;
150  var
151    SrcEdit: TSourceEditorInterface;
152    Msg: String;
153  begin
154    Result:=false;
155    if not CodeToolBoss.GatherExternalChanges then begin
156      ShowAbortMessage(lisUnableToGatherEditorChanges);
157      exit;
158    end;
159    MainIDEInterface.GetUnitInfoForDesigner(ADesigner,SrcEdit,UnitInfo);
160    if UnitInfo=nil then begin
161      ShowAbortMessage(lisUnableToGetSourceForDesigner);
162      exit;
163    end;
164    UnitCode:=UnitInfo.Source;
165    LFMBuffer:=CodeToolBoss.CreateTempFile('changeclass.lfm');
166    if (LFMBuffer=nil) or (ComponentStream.Size=0) then begin
167      ShowAbortMessage(lisUnableToCreateTemporaryLfmBuffer);
168      exit;
169    end;
170    ComponentStream.Position:=0;
171    LFMBuffer.LoadFromStream(ComponentStream);
172    //debugln('ChangePersistentClass-Before-Checking--------------------------------------------');
173    //debugln(LFMBuffer.Source);
174    //debugln('ChangePersistentClass-Before-Checking-------------------------------------------');
175    if not CodeToolBoss.CheckLFM(UnitCode,LFMBuffer,LFMTree,false,false,false) then
176    begin
177      debugln('ChangePersistentClass-Before--------------------------------------------');
178      debugln(LFMBuffer.Source);
179      debugln('ChangePersistentClass-Before--------------------------------------------');
180      if CodeToolBoss.ErrorMessage<>'' then
181        MainIDEInterface.DoJumpToCodeToolBossError
182      else begin
183        Msg:=lisErrorParsingLfmComponentStream;
184        if LFMTree<>nil then
185          Msg:=Msg+LineEnding+LineEnding+LFMTree.FirstErrorAsString+LineEnding;
186        ShowAbortMessage(Msg);
187      end;
188      exit;
189    end;
190    Result:=true;
191  end;
192
193  function ChangeClassName: boolean;
194  var
195    CurNode: TLFMTreeNode;
196    ObjectNode: TLFMObjectNode;
197  begin
198    Result:=false;
199    // find classname position
200    CurNode:=LFMTree.Root;
201    while CurNode<>nil do begin
202      if (CurNode is TLFMObjectNode) then begin
203        ObjectNode:=TLFMObjectNode(CurNode);
204        if (CompareText(ObjectNode.Name,(APersistent as TComponent).Name)=0)
205        and (CompareText(ObjectNode.TypeName,APersistent.ClassName)=0) then begin
206          // replace classname
207          LFMBuffer.Replace(ObjectNode.TypeNamePosition,length(ObjectNode.TypeName),
208            NewClass.ClassName);
209          Result:=true;
210          exit;
211        end;
212      end;
213      CurNode:=CurNode.NextSibling;
214    end;
215    ShowAbortMessage(Format(lisUnableToFindInLFMStream, [PersistentName]));
216  end;
217
218  function CheckProperties: boolean;
219  begin
220    Result:=RepairLFMBuffer(UnitCode,LFMBuffer,false,false,false)=mrOk;
221    if not Result and (CodeToolBoss.ErrorMessage<>'') then
222      MainIDEInterface.DoJumpToCodeToolBossError;
223  end;
224
225  function InsertStreamedSelection: boolean;
226  var
227    MemStream: TMemoryStream;
228    LFMType, LFMComponentName, LFMClassName: string;
229    AComponent: TComponent;
230    NewParent: TWinControl;
231    NewParentName: string;
232  begin
233    Result:=false;
234    if LFMBuffer.SourceLength=0 then exit;
235    MemStream:=TMemoryStream.Create;
236    try
237      debugln('ChangePersistentClass-After--------------------------------------------');
238      debugln(LFMBuffer.Source);
239      debugln('ChangePersistentClass-After--------------------------------------------');
240      LFMBuffer.SaveToStream(MemStream);
241      MemStream.Position:=0;
242      NewParent:=nil;
243      if OldParents<>nil then begin
244        ReadLFMHeader(MemStream,LFMType,LFMComponentName,LFMClassName);
245        if (LFMType='') or (LFMClassName='') then ;
246        MemStream.Position:=0;
247        if LFMComponentName<>'' then begin
248          NewParentName:=OldParents.Values[LFMComponentName];
249          if NewParentName<>'' then begin
250            AComponent:=GlobalDesignHook.GetComponent(NewParentName);
251            if AComponent is TWinControl then
252              NewParent:=TWinControl(AComponent);
253          end;
254        end;
255      end;
256      Result:=FormEditingHook.InsertFromStream(MemStream,NewParent,
257                                               [cpsfReplace]);
258      if not Result then
259        ShowAbortMessage(lisReplacingSelectionFailed);
260    finally
261      MemStream.Free;
262    end;
263  end;
264
265begin
266  Result:=mrCancel;
267  if NewClass = nil then
268    exit;
269  if CompareText(APersistent.ClassName,NewClass.ClassName)=0 then begin
270    Result:=mrOk;
271    exit;
272  end;
273  PersistentName:=APersistent.ClassName;
274  if APersistent is TComponent then begin
275    PersistentName:=TComponent(APersistent).Name+': '+PersistentName;
276  end else begin
277    ShowAbortMessage(lisCanOnlyChangeTheClassOfTComponents);
278    exit;
279  end;
280  ComponentStream:=nil;
281  LFMTree:=nil;
282  OldParents:=nil;
283  try
284    if not StreamSelection then exit;
285    if not ParseLFMStream then exit;
286    if not ChangeClassName then exit;
287    if not CheckProperties then exit;
288    if not InsertStreamedSelection then exit;
289  finally
290    ComponentStream.Free;
291    OldParents.Free;
292    // Note: do not free LFMTree, it is cached by the codetools
293  end;
294  Result:=mrOk;
295end;
296
297{ TChangeClassDlg }
298
299procedure TChangeClassDlg.ChangeClassDlgCreate(Sender: TObject);
300begin
301  OldGroupBox.Caption:=lisOldClass;
302  NewGroupBox.Caption:=lisNewClass;
303end;
304
305procedure TChangeClassDlg.NewClassComboBoxEditingDone(Sender: TObject);
306begin
307  UpdateNewInfo;
308end;
309
310procedure TChangeClassDlg.NewClassComboBoxKeyUp(Sender: TObject; var Key: Word;
311  Shift: TShiftState);
312begin
313  if Key = VK_RETURN then
314    UpdateNewInfo;
315end;
316
317procedure TChangeClassDlg.SetThePersistent(const AValue: TPersistent);
318begin
319  if FThePersistent=AValue then exit;
320  FThePersistent:=AValue;
321  UpdateInfo;
322end;
323
324procedure TChangeClassDlg.SetNewClass(const AValue: TClass);
325begin
326  if FNewClass=AValue then exit;
327  FNewClass:=AValue;
328  UpdateNewInfo;
329end;
330
331procedure TChangeClassDlg.UpdateInfo;
332begin
333  UpdateNewInfo;
334  UpdateOldInfo;
335end;
336
337procedure TChangeClassDlg.UpdateOldInfo;
338begin
339  FillAncestorListBox(ThePersistent.ClassType,OldAncestorsListBox);
340  if ThePersistent<>nil then begin
341    if ThePersistent is TComponent then
342      OldClassLabel.Caption:=TComponent(ThePersistent).Name+': '+ThePersistent.ClassName
343    else
344      OldClassLabel.Caption:=ThePersistent.ClassName;
345    Caption:=Format(lisCCDChangeClassOf, [OldClassLabel.Caption]);
346  end else begin
347    OldClassLabel.Caption:=lisCCDNoClass;
348    Caption:=lisChangeClass;
349  end;
350end;
351
352procedure TChangeClassDlg.UpdateNewInfo;
353var
354  ANode: TAvgLvlTreeNode;
355begin
356  FNewClass:=nil;
357  if FClasses<>nil then begin
358    ANode:=FClasses.FindLowest;
359    while (ANode<>nil) do begin
360      FNewClass:=TClass(ANode.Data);
361      if (CompareText(NewClass.ClassName,NewClassComboBox.Text)=0) then
362        break
363      else
364        FNewClass:=nil;
365      ANode:=FClasses.FindSuccessor(ANode);
366    end;
367  end;
368  FillAncestorListBox(NewClass,NewAncestorsListBox);
369  if NewClass<>nil then begin
370    NewClassComboBox.Text:=NewClass.ClassName;
371    BtnPanel.OKButton.Enabled:=true;
372  end
373  else begin
374    NewClassComboBox.Text:='';
375    BtnPanel.OKButton.Enabled:=false;
376  end;
377end;
378
379procedure TChangeClassDlg.FillAncestorListBox(AClass: TClass; AListBox: TListBox);
380var
381  List: TStringList;
382  
383  procedure AddAncestor(CurClass: TClass);
384  begin
385    if CurClass=nil then exit;
386    List.Add(CurClass.ClassName);
387    AddAncestor(CurClass.ClassParent);
388  end;
389  
390begin
391  List:=TStringList.Create;
392  AddAncestor(AClass);
393  AListBox.Items.Assign(List);
394  List.Free;
395end;
396
397procedure TChangeClassDlg.AddClass(const AClass: TPersistentClass);
398begin
399  if FClasses.FindPointer(AClass)<>nil then exit;
400  FClasses.Add(AClass);
401end;
402
403procedure TChangeClassDlg.AddComponentClass(const AClass: TComponentClass);
404begin
405  AddClass(AClass);
406end;
407
408function TChangeClassDlg.CompareClasses(Tree: TAvgLvlTree; Class1,Class2: TClass): integer;
409// sort:
410//   transforming ThePersistent to descending classes is easy
411//   transforming ThePersistent to ascending classes is medium
412//
413//   count distance between, that means: find nearest shared ancestor, then
414//   give two points for every step from ThePersistent to ancestor and one point
415//   for every step from ancestor to class
416//
417//   otherwise sort for classnames
418
419  function AncestorDistance(ChildClass, AncestorClass: TClass): integer;
420  begin
421    Result:=0;
422    while (ChildClass<>nil) and (ChildClass<>AncestorClass) do begin
423      ChildClass:=ChildClass.ClassParent;
424      inc(Result);
425    end;
426  end;
427
428  function RelationDistance(SrcClass, DestClass: TClass): integer;
429  var
430    Ancestor: TClass;
431  begin
432    // find shared ancestor of
433    Ancestor:=SrcClass;
434    while (Ancestor<>nil) and (not DestClass.InheritsFrom(Ancestor)) do
435      Ancestor:=Ancestor.ClassParent;
436    // going to the ancestor is normally more difficult than going away
437    Result:=2*AncestorDistance(SrcClass,Ancestor)
438             +AncestorDistance(DestClass,Ancestor);
439  end;
440
441var
442  Dist1: LongInt;
443  Dist2: LongInt;
444begin
445  Result:=0;
446  if (ThePersistent<>nil) then begin
447    Dist1:=RelationDistance(ThePersistent.ClassType,Class1);
448    Dist2:=RelationDistance(ThePersistent.ClassType,Class2);
449    Result:=Dist1-Dist2;
450    if Result<>0 then exit;
451  end;
452  Result:=CompareText(Class1.ClassName,Class2.ClassName);
453end;
454
455destructor TChangeClassDlg.Destroy;
456begin
457  FClasses.Free;
458  FClasses:=nil;
459  inherited Destroy;
460end;
461
462procedure TChangeClassDlg.FillNewClassComboBox;
463var
464  ANode: TAvgLvlTreeNode;
465  List: TStringList;
466begin
467  // create/clear tree
468  if FClasses=nil then
469    FClasses:=TAvgLvlTree.CreateObjectCompare(TObjectSortCompare(@CompareClasses))
470  else
471    FClasses.Clear;
472  // add class of ThePersistent
473  if ThePersistent<>nil then
474    AddClass(TPersistentClass(ThePersistent.ClassType));
475  // add all registered component classes
476  if (IDEComponentPalette<>nil) then
477    IDEComponentPalette.IterateRegisteredClasses(@AddComponentClass);
478  // add list of classnames
479  List:=TStringList.Create;
480  try
481    ANode:=FClasses.FindLowest;
482    while ANode<>nil do begin
483      List.Add(TClass(ANode.Data).ClassName);
484      ANode:=FClasses.FindSuccessor(ANode);
485    end;
486    // assign to combobox
487    NewClassComboBox.Items.Assign(List);
488    if (NewClassComboBox.Items.IndexOf(NewClassComboBox.Text)<0)
489    and (NewClassComboBox.Items.Count>0) then
490      NewClassComboBox.Text:=NewClassComboBox.Items[0];
491    UpdateNewInfo;
492  finally
493    List.Free;
494  end;
495end;
496
497end.
498