/designer/changeclassdialog.pas
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