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