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