1{ 2 This file is part of the Free Component Library (FCL) 3 Copyright (c) 1999-2000 by the Free Pascal development team 4 5 See the file COPYING.FPC, included in this distribution, 6 for details about the copyright. 7 8 This program is distributed in the hope that it will be useful, 9 but WITHOUT ANY WARRANTY; without even the implied warranty of 10 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 11 12 **********************************************************************} 13 14 15 16{ Class registration routines } 17 18procedure RegisterClass(AClass: TPersistentClass); 19var 20aClassname : String; 21begin 22 //Classlist is created during initialization. 23 with Classlist.Locklist do 24 try 25 while Indexof(AClass) = -1 do 26 begin 27 aClassname := AClass.ClassName; 28 if GetClass(aClassName) <> nil then //class alread registered! 29 Begin 30 //raise an error 31 exit; 32 end; 33 Add(AClass); 34 if AClass = TPersistent then break; 35 AClass := TPersistentClass(AClass.ClassParent); 36 end; 37 finally 38 ClassList.UnlockList; 39 end; 40end; 41 42 43procedure RegisterClassAlias(AClass: TPersistentClass; const Alias: string); 44 var 45 I : integer; 46 begin 47 I:=-1; 48 ClassList.LockList; 49 try 50 if ClassAliasList=nil then 51 ClassAliasList := TStringList.Create 52 else 53 i := ClassAliasList.IndexOf(Alias); 54 if I = -1 then 55 ClassAliasList.AddObject( Alias, TObject(AClass) ); 56 finally 57 ClassList.UnlockList; 58 end; 59 end; 60 61 62procedure RegisterClasses(AClasses: array of TPersistentClass); 63var 64I : Integer; 65begin 66for I := low(aClasses) to high(aClasses) do 67 RegisterClass(aClasses[I]); 68end; 69 70 71procedure UnRegisterClass(AClass: TPersistentClass); 72 73begin 74end; 75 76 77procedure UnRegisterClasses(AClasses: array of TPersistentClass); 78 79begin 80end; 81 82 83procedure UnRegisterModuleClasses(Module: HMODULE); 84begin 85end; 86 87 88function FindClass(const AClassName: string): TPersistentClass; 89 90begin 91 Result := GetClass(AClassName); 92 if not Assigned(Result) then 93 raise EClassNotFound.CreateFmt(SClassNotFound, [AClassName]); 94end; 95 96 97function GetClass(const AClassName: string): TPersistentClass; 98var 99I : Integer; 100begin 101 with ClassList.LockList do 102 try 103 for I := 0 to Count-1 do 104 begin 105 Result := TPersistentClass(Items[I]); 106 if Result.ClassNameIs(AClassName) then Exit; 107 end; 108 if Assigned(ClassAliasList) then 109 begin 110 I := ClassAliasList.Indexof(AClassName); 111 if I >= 0 then //found 112 Begin 113 Result := TPersistentClass(ClassAliasList.Objects[i]); 114 exit; 115 end; 116 end; 117 Result := nil; 118 finally 119 ClassList.Unlocklist; 120 end; 121end; 122 123 124procedure StartClassGroup(AClass: TPersistentClass); 125begin 126end; 127 128 129procedure GroupDescendentsWith(AClass, AClassGroup: TPersistentClass); 130begin 131end; 132 133 134function ActivateClassGroup(AClass: TPersistentClass): TPersistentClass; 135begin 136 Result:=nil; 137end; 138 139 140function ClassGroupOf(AClass: TPersistentClass): TPersistentClass; 141begin 142 Result:=nil; 143end; 144 145 146function ClassGroupOf(Instance: TPersistent): TPersistentClass; 147begin 148 Result:=nil; 149end; 150 151 152{ Component registration routines } 153 154type 155 TComponentPage = class(TCollectionItem) 156 public 157 Name: String; 158 Classes: TList; 159 destructor Destroy; override; 160 end; 161 162{ TComponentPage } 163 164destructor TComponentPage.Destroy; 165begin 166 Classes.Free; 167 inherited Destroy; 168end; 169 170var 171 ComponentPages: TCollection; 172 173procedure InitComponentPages; 174begin 175 ComponentPages := TCollection.Create(TComponentPage); 176 { Add a empty page which will be used for storing the NoIcon components } 177 ComponentPages.Add; 178end; 179 180procedure RegisterComponents(const Page: string; 181 ComponentClasses: array of TComponentClass); 182var 183 i: Integer; 184 pg: TComponentPage; 185begin 186 if Page = '' then exit; { prevent caller from doing nonsense } 187 188 pg := nil; 189 if not Assigned(ComponentPages) then 190 InitComponentPages 191 else 192 for i := 0 to ComponentPages.Count - 1 do 193 if TComponentPage(ComponentPages.Items[i]).Name = Page then begin 194 pg := TComponentPage(ComponentPages.Items[i]); 195 break; 196 end; 197 198 if pg = nil then begin 199 pg := TComponentPage(ComponentPages.Add); 200 pg.Name := Page; 201 end; 202 203 if pg.Classes = nil then 204 pg.Classes := TList.Create; 205 206 for i := Low(ComponentClasses) to High(ComponentClasses) do 207 pg.Classes.Add(ComponentClasses[i]); 208 209 if Assigned(RegisterComponentsProc) then 210 RegisterComponentsProc(Page, ComponentClasses); 211end; 212 213 214procedure RegisterNoIcon(ComponentClasses: array of TComponentClass); 215var 216 pg: TComponentPage; 217 i: Integer; 218begin 219 if not Assigned(ComponentPages) then 220 InitComponentPages; 221 222 pg := TComponentPage(ComponentPages.Items[0]); 223 if pg.Classes = nil then 224 pg.Classes := TList.Create; 225 226 for i := Low(ComponentClasses) to High(ComponentClasses) do 227 pg.Classes.Add(ComponentClasses[i]); 228 229 if Assigned(RegisterNoIconProc) then 230 RegisterNoIconProc(ComponentClasses); 231end; 232 233 234procedure RegisterNonActiveX(ComponentClasses: array of TComponentClass; 235 AxRegType: TActiveXRegType); 236 237begin 238end; 239 240 241