source: cprs/trunk/CPRS-Chart/uComServ.pas@ 770

Last change on this file since 770 was 456, checked in by Kevin Toppenberg, 16 years ago

Initial Upload of Official WV CPRS 1.0.26.76

File size: 11.5 KB
Line 
1{ *********************************************************************** }
2{ }
3{ Delphi Runtime Library }
4{ }
5{ Copyright (c) 1997-2001 Borland Software Corporation }
6{ }
7{ *********************************************************************** }
8
9{*******************************************************}
10{ COM server support }
11{*******************************************************}
12
13unit uComServ;
14
15{$DENYPACKAGEUNIT}
16
17interface
18
19uses Windows, Messages, ActiveX, SysUtils, ComObj;
20
21type
22
23{ Application start mode }
24
25 TStartMode = (smStandalone, smAutomation, smRegServer, smUnregServer);
26
27{ Class manager event types }
28
29 TLastReleaseEvent = procedure(var Shutdown: Boolean) of object;
30
31{ TComServer }
32
33 TComServer = class(TComServerObject)
34 private
35 FObjectCount: Integer;
36 FFactoryCount: Integer;
37 FTypeLib: ITypeLib;
38 FServerName: string;
39 FHelpFileName: string;
40 FIsInprocServer: Boolean;
41 FStartMode: TStartMode;
42 FStartSuspended: Boolean;
43 FRegister: Boolean;
44 FUIInteractive: Boolean;
45 FOnLastRelease: TLastReleaseEvent;
46 procedure FactoryFree(Factory: TComObjectFactory);
47 procedure FactoryRegisterClassObject(Factory: TComObjectFactory);
48 procedure FactoryUpdateRegistry(Factory: TComObjectFactory);
49 procedure LastReleased;
50 protected
51 function CountObject(Created: Boolean): Integer; override;
52 function CountFactory(Created: Boolean): Integer; override;
53 function GetHelpFileName: string; override;
54 function GetServerFileName: string; override;
55 function GetServerKey: string; override;
56 function GetServerName: string; override;
57 function GetStartSuspended: Boolean; override;
58 function GetTypeLib: ITypeLib; override;
59 procedure SetHelpFileName(const Value: string); override;
60 public
61 constructor Create;
62 destructor Destroy; override;
63 procedure Initialize;
64 procedure LoadTypeLib;
65 procedure SetServerName(const Name: string);
66 procedure UpdateRegistry(Register: Boolean);
67 property IsInprocServer: Boolean read FIsInprocServer write FIsInprocServer;
68 property ObjectCount: Integer read FObjectCount;
69 property StartMode: TStartMode read FStartMode;
70 property UIInteractive: Boolean read FUIInteractive write FUIInteractive;
71 property OnLastRelease: TLastReleaseEvent read FOnLastRelease write FOnLastRelease;
72 end;
73
74var
75 ComServer: TComServer;
76
77function DllGetClassObject(const CLSID, IID: TGUID; var Obj): HResult; stdcall;
78function DllCanUnloadNow: HResult; stdcall;
79function DllRegisterServer: HResult; stdcall;
80function DllUnregisterServer: HResult; stdcall;
81
82implementation
83
84uses ComConst;
85
86function GetModuleFileName: string;
87var
88 Buffer: array[0..261] of Char;
89begin
90 SetString(Result, Buffer, Windows.GetModuleFileName(HInstance,
91 Buffer, SizeOf(Buffer)));
92end;
93
94function GetModuleName: string;
95begin
96 Result := ChangeFileExt(ExtractFileName(GetModuleFileName), '');
97end;
98
99function LoadTypeLibrary(const ModuleName: string): ITypeLib;
100begin
101 OleCheck(LoadTypeLib(PWideChar(WideString(ModuleName)), Result));
102end;
103
104procedure RegisterTypeLibrary(TypeLib: ITypeLib; const ModuleName: string);
105var
106 Name: WideString;
107 HelpPath: WideString;
108begin
109 Name := ModuleName;
110 HelpPath := ExtractFilePath(ModuleName);
111 OleCheck(RegisterTypeLib(TypeLib, PWideChar(Name), PWideChar(HelpPath)));
112end;
113
114procedure UnregisterTypeLibrary(TypeLib: ITypeLib);
115type
116 TUnregisterProc = function(const GUID: TGUID; VerMajor, VerMinor: Word;
117 LCID: TLCID; SysKind: TSysKind): HResult stdcall;
118var
119 Handle: THandle;
120 UnregisterProc: TUnregisterProc;
121 LibAttr: PTLibAttr;
122begin
123 Handle := GetModuleHandle('OLEAUT32.DLL');
124 if Handle <> 0 then
125 begin
126 @UnregisterProc := GetProcAddress(Handle, 'UnRegisterTypeLib');
127 if @UnregisterProc <> nil then
128 begin
129 OleCheck(ComServer.TypeLib.GetLibAttr(LibAttr));
130 with LibAttr^ do
131 UnregisterProc(guid, wMajorVerNum, wMinorVerNum, lcid, syskind);
132 ComServer.TypeLib.ReleaseTLibAttr(LibAttr);
133 end;
134 end;
135end;
136
137function GetTypeLibName(TypeLib: ITypeLib): string;
138var
139 Name: WideString;
140begin
141 OleCheck(TypeLib.GetDocumentation(-1, @Name, nil, nil, nil));
142 Result := Name;
143end;
144
145function DllGetClassObject(const CLSID, IID: TGUID; var Obj): HResult;
146var
147 Factory: TComObjectFactory;
148begin
149 Factory := ComClassManager.GetFactoryFromClassID(CLSID);
150 if Factory <> nil then
151 if Factory.GetInterface(IID, Obj) then
152 Result := S_OK
153 else
154 Result := E_NOINTERFACE
155 else
156 begin
157 Pointer(Obj) := nil;
158 Result := CLASS_E_CLASSNOTAVAILABLE;
159 end;
160end;
161
162function DllCanUnloadNow: HResult;
163begin
164 if (ComServer = nil) or
165 ((ComServer.FObjectCount = 0) and (ComServer.FFactoryCount = 0)) then
166 Result := S_OK
167 else
168 Result := S_FALSE;
169end;
170
171function DllRegisterServer: HResult;
172begin
173 Result := S_OK;
174 try
175 ComServer.UpdateRegistry(True);
176 except
177 Result := E_FAIL;
178 end;
179end;
180
181function DllUnregisterServer: HResult;
182begin
183 Result := S_OK;
184 try
185 ComServer.UpdateRegistry(False);
186 except
187 Result := E_FAIL;
188 end;
189end;
190
191{ Automation TerminateProc }
192
193function AutomationTerminateProc: Boolean;
194begin
195 Result := True;
196 if (ComServer <> nil) and (ComServer.ObjectCount > 0) and ComServer.UIInteractive then
197 begin
198 Result := MessageBox(0, PChar(SNoCloseActiveServer1 + SNoCloseActiveServer2),
199 PChar(SAutomationWarning), MB_YESNO or MB_TASKMODAL or
200 MB_ICONWARNING or MB_DEFBUTTON2) = IDYES;
201 end;
202end;
203
204{ TComServer }
205
206constructor TComServer.Create;
207
208 function FindSwitch(const Switch: string): Boolean;
209 begin
210 Result := FindCmdLineSwitch(Switch, ['-', '/'], True);
211 end;
212
213begin
214 FTypeLib := nil;
215 FIsInprocServer := ModuleIsLib;
216 if FindSwitch('AUTOMATION') or FindSwitch('EMBEDDING') then
217 FStartMode := smAutomation
218 else if FindSwitch('REGSERVER') then
219 FStartMode := smRegServer
220 else if FindSwitch('UNREGSERVER') then
221 FStartMode := smUnregServer;
222 FUIInteractive := True;
223end;
224
225destructor TComServer.Destroy;
226begin
227 ComClassManager.ForEachFactory(Self, FactoryFree);
228end;
229
230function TComServer.CountObject(Created: Boolean): Integer;
231begin
232 if Created then
233 begin
234 Result := InterlockedIncrement(FObjectCount);
235 if (not IsInProcServer) and (StartMode = smAutomation)
236 and Assigned(ComObj.CoAddRefServerProcess) then
237 ComObj.CoAddRefServerProcess;
238 end
239 else
240 begin
241 Result := InterlockedDecrement(FObjectCount);
242 if (not IsInProcServer) and (StartMode = smAutomation)
243 and Assigned(ComObj.CoReleaseServerProcess) then
244 begin
245 if ComObj.CoReleaseServerProcess = 0 then
246 LastReleased;
247 end
248 else if Result = 0 then
249 LastReleased;
250 end;
251end;
252
253function TComServer.CountFactory(Created: Boolean): Integer;
254begin
255 if Created then
256 Result := InterlockedIncrement(FFactoryCount)
257 else
258 Result := InterlockedDecrement(FFactoryCount);
259end;
260
261procedure TComServer.FactoryFree(Factory: TComObjectFactory);
262begin
263 Factory.Free;
264end;
265
266procedure TComServer.FactoryRegisterClassObject(Factory: TComObjectFactory);
267begin
268 Factory.RegisterClassObject;
269end;
270
271procedure TComServer.FactoryUpdateRegistry(Factory: TComObjectFactory);
272begin
273 if Factory.Instancing <> ciInternal then
274 Factory.UpdateRegistry(FRegister);
275end;
276
277function TComServer.GetHelpFileName: string;
278begin
279 Result := FHelpFileName;
280end;
281
282function TComServer.GetServerFileName: string;
283begin
284 Result := GetModuleFileName;
285end;
286
287function TComServer.GetServerKey: string;
288begin
289 if FIsInprocServer then
290 Result := 'InprocServer32' else
291 Result := 'LocalServer32';
292end;
293
294function TComServer.GetServerName: string;
295begin
296 if FServerName <> '' then
297 Result := FServerName
298 else
299 if FTypeLib <> nil then
300 Result := GetTypeLibName(FTypeLib)
301 else
302 Result := GetModuleName;
303end;
304
305procedure TComServer.SetServerName(const Name: string);
306begin
307 if FTypeLib = nil then
308 FServerName := Name;
309end;
310
311function TComServer.GetTypeLib: ITypeLib;
312begin
313 LoadTypeLib;
314 Result := FTypeLib;
315end;
316
317
318procedure TComServer.LastReleased;
319var
320 Shutdown: Boolean;
321begin
322 if not FIsInprocServer then
323 begin
324 Shutdown := FStartMode = smAutomation;
325 try
326 if Assigned(FOnLastRelease) then FOnLastRelease(Shutdown);
327 finally
328 if Shutdown then PostThreadMessage(MainThreadID, WM_QUIT, 0, 0);
329 end;
330 end;
331end;
332
333procedure TComServer.LoadTypeLib;
334var
335 Temp: ITypeLib;
336begin
337 if FTypeLib = nil then
338 begin
339 // this may load typelib more than once, but avoids need for critical section
340 // and releases the interface correctly
341 Temp := LoadTypeLibrary(GetModuleFileName);
342 Integer(Temp) := InterlockedExchange(Integer(FTypeLib), Integer(Temp));
343 end;
344end;
345
346procedure TComServer.UpdateRegistry(Register: Boolean);
347begin
348 if FTypeLib <> nil then
349 if Register then
350 RegisterTypeLibrary(FTypeLib, GetModuleFileName) else
351 UnregisterTypeLibrary(FTypeLib);
352 FRegister := Register;
353 ComClassManager.ForEachFactory(Self, FactoryUpdateRegistry);
354end;
355
356var
357 SaveInitProc: Pointer = nil;
358 OleAutHandle: Integer;
359
360procedure InitComServer;
361begin
362 if SaveInitProc <> nil then TProcedure(SaveInitProc);
363 ComServer.FStartSuspended := (CoInitFlags <> -1) and
364 Assigned(ComObj.CoInitializeEx) and Assigned(ComObj.CoResumeClassObjects);
365 ComServer.Initialize;
366 if ComServer.FStartSuspended then
367 ComObj.CoResumeClassObjects;
368end;
369
370function TComServer.GetStartSuspended: Boolean;
371begin
372 Result := FStartSuspended;
373end;
374
375procedure TComServer.SetHelpFileName(const Value: string);
376begin
377 FHelpFileName := Value;
378end;
379{ older proc replaced by one below this
380procedure TComServer.Initialize;
381begin
382 try
383 UpdateRegistry(FStartMode <> smUnregServer);
384 except
385 on E: EOleRegistrationError do
386 // User may not have write access to the registry.
387 // Squelch the exception unless we were explicitly told to register.
388 if FStartMode = smRegServer then raise;
389 end;
390 if FStartMode in [smRegServer, smUnregServer] then Halt;
391 ComClassManager.ForEachFactory(Self, FactoryRegisterClassObject);
392end;
393 }
394procedure TComServer.Initialize;
395begin
396 try
397 UpdateRegistry(FStartMode <> smUnregServer);
398 except
399 on E: EOleRegistrationError do
400 // User may not have write access to the registry.
401 // Squelch the exception unless we were explicitly told to register.
402 if FStartMode = smRegServer then raise;
403 on E: EOleSysError do
404 if FStartMode = smRegServer then raise;
405 end;
406 if FStartMode in [smRegServer, smUnregServer] then Halt;
407 ComClassManager.ForEachFactory(Self, FactoryRegisterClassObject);
408end;
409initialization
410begin
411 OleAutHandle := SafeLoadLibrary('OLEAUT32.DLL');
412 ComServer := TComServer.Create;
413 if not ModuleIsLib then
414 begin
415 SaveInitProc := InitProc;
416 InitProc := @InitComServer;
417 AddTerminateProc(@AutomationTerminateProc);
418 end;
419end;
420
421finalization
422begin
423 ComServer.Free;
424 ComServer := nil;
425 FreeLibrary(OleAutHandle);
426end;
427
428end.
Note: See TracBrowser for help on using the repository browser.