cregist.inc 6.0 KB

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