source: cprs/branches/tmg-cprs/CPRS-Chart/uComServ.pas@ 1593

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

Initial upload of TMG-CPRS 1.0.26.69

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