1 | { **************************************************************
|
---|
2 | Package: XWB - Kernel RPCBroker
|
---|
3 | Date Created: Sept 18, 1997 (Version 1.1)
|
---|
4 | Site Name: Oakland, OI Field Office, Dept of Veteran Affairs
|
---|
5 | Developers: Kevin Meldrum, Travis Hilton, Joel Ivey
|
---|
6 | Description: Describes TSharedRPCBroker class.
|
---|
7 | Current Release: Version 1.1 Patch 47 (Jun. 17, 2008))
|
---|
8 | *************************************************************** }
|
---|
9 |
|
---|
10 | unit SharedRPCBroker;
|
---|
11 |
|
---|
12 | interface
|
---|
13 |
|
---|
14 | uses
|
---|
15 | Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
|
---|
16 | RPCSharedBrokerSessionMgr1_TLB_SRB, Trpcb, ActiveX, Extctrls;
|
---|
17 | // TRPCB is only used for data classes like TParams. There is no TRPCBroker dependency.
|
---|
18 |
|
---|
19 |
|
---|
20 | type
|
---|
21 | TLogout = procedure () of object;
|
---|
22 |
|
---|
23 | TOnConnectionDropped = procedure (ConnectionIndex: Integer; ErrorText: WideString) of object;
|
---|
24 | {
|
---|
25 | TOnClientConnected = procedure (uniqueClientId: Integer) of object;
|
---|
26 | TOnClientDisconnected = procedure (uniqueClientId: Integer) of object;
|
---|
27 | }
|
---|
28 |
|
---|
29 | // TSharedBrokerDataCollector is a data container class that collects all RPC call parameters BEFORE
|
---|
30 | // an RPC call is made. When the actual RPC call is made all of the parameters are turned into a WideString
|
---|
31 | // and passed through the Out-of-process COM interface to the TSharedBroker class found in VistASessionMgr.exe.
|
---|
32 | // After the call the results are put back into Results which is a TStrings class like in TRPCBroker.
|
---|
33 | // The parameters are stored in a local TParams member just like in TRPCBroker.
|
---|
34 | // All Connections to the backend Mumps server are done through TSharedBroker which actually instantiates a real
|
---|
35 | // TRPCBroker and uses it for the connection.
|
---|
36 |
|
---|
37 | // Thus this class becomes a Delphi Component that wraps all of the data and keeps performance as high as possible.
|
---|
38 | // If these calls were to be moved into the VistASessionMgr.exe then there would be two major problems
|
---|
39 | // 1. Performance suffers when marshaling data across an out-of-process COM connection
|
---|
40 | // 2. It is impossible to keeps the same Params and Results access interface that exists in TRPCBroker
|
---|
41 | // since the COM interface will not support structured data.
|
---|
42 |
|
---|
43 | {
|
---|
44 | Modified 11/27/2001 jli to TSharedRPCBroker from TSharedBrokerDataCollector,
|
---|
45 | and changed as derived from TRPCBroker instead of TComponent, since other
|
---|
46 | components have properties which are of Type TRPCBroker and the
|
---|
47 | TSharedBrokerDataCollector derived from TComponent can't be used as a value
|
---|
48 | for those properties.
|
---|
49 | }
|
---|
50 |
|
---|
51 |
|
---|
52 | // TSharedBrokerDataCollector = class(TComponent)
|
---|
53 | TSharedRPCBroker = class(TRPCBroker)
|
---|
54 | private
|
---|
55 | { FAccessVerifyCodes: TAccessVerifyCodes;
|
---|
56 | FClearParameters: Boolean;
|
---|
57 | FClearResults: Boolean;
|
---|
58 | FConnected: Boolean;
|
---|
59 | FConnecting: Boolean;
|
---|
60 | FCurrentContext: String;
|
---|
61 | FDebugMode: Boolean;
|
---|
62 | FListenerPort: integer;
|
---|
63 | FParams: TParams;
|
---|
64 | FResults: TStrings;
|
---|
65 | FRemoteProcedure: TRemoteProc;
|
---|
66 | FRpcVersion: TRpcVersion;
|
---|
67 | FServer: TServer;
|
---|
68 | FSocket: integer;
|
---|
69 | FRPCTimeLimit : integer; //for adjusting client RPC duration timeouts
|
---|
70 | FPulse : TTimer; //P6
|
---|
71 | FKernelLogIn : Boolean; //p13
|
---|
72 | FLogIn: TVistaLogIn; //p13
|
---|
73 | FUser: TVistaUser; //p13
|
---|
74 | FOnRPCBFailure: TOnRPCBFailure;
|
---|
75 | FShowErrorMsgs: TShowErrorMsgs;
|
---|
76 | FRPCBError: String;
|
---|
77 | }
|
---|
78 | FAllowShared: Boolean;
|
---|
79 | FVistaSession: ISharedBroker; // TSharedBroker;
|
---|
80 | FCurrRPCVersion: TRpcVersion;
|
---|
81 | // FOnLogout: TNotifyEvent;
|
---|
82 | FOnLogout: TLogout;
|
---|
83 | FOnConnectionDropped: TOnConnectionDropped;
|
---|
84 | {
|
---|
85 | FOnClientConnected: TOnClientConnected;
|
---|
86 | FOnClientDisconnected: TOnClientDisconnected;
|
---|
87 | }
|
---|
88 | FSinkCookie: LongInt;
|
---|
89 | FKernelLogin: Boolean;
|
---|
90 | FRPCTimeLimit: integer;
|
---|
91 | FSocket: Integer;
|
---|
92 | FRPCBError: String;
|
---|
93 | FOnRPCBFailure: TOnRPCBFailure;
|
---|
94 | FLogin: TVistaLogin;
|
---|
95 | FUser: TVistaUser;
|
---|
96 | protected
|
---|
97 | procedure SetLoginStr(Str: string); virtual;
|
---|
98 | procedure SetUserStr(Str: String);
|
---|
99 | procedure SetConnected(Value: Boolean); override;
|
---|
100 | function GetConnected: Boolean;
|
---|
101 | procedure SetResults(Value: TStrings); override;
|
---|
102 | procedure SetClearParameters(Value: Boolean); override;
|
---|
103 | procedure SetClearResults(Value: Boolean); override;
|
---|
104 | procedure SetRPCTimeLimit(Value: integer); override; //Screen changes to timeout.
|
---|
105 | // procedure SetOnLogout(EventHandler: TNotifyEvent);
|
---|
106 | procedure SetOnLogout(EventHandler: TLogout);
|
---|
107 | function GetRpcVersion:TRpcVersion;
|
---|
108 | procedure SetRpcVersion(version: TRpcVersion);
|
---|
109 | function LoginStr: String;
|
---|
110 | {
|
---|
111 | procedure SetRPC(Value: TRemoteProc);
|
---|
112 | function GetRPC: TRemoteProc;
|
---|
113 | }
|
---|
114 | public
|
---|
115 | constructor Create(AOwner: TComponent); override;
|
---|
116 | destructor Destroy; override;
|
---|
117 | // procedure OnLogoutEventHandlerDefault(Sender: TObject); virtual;
|
---|
118 | procedure OnLogoutEventHandlerDefault; virtual;
|
---|
119 | procedure OnConnectionDroppedHandler(ConnectionIndex: Integer; ErrorText: WideString); virtual;
|
---|
120 | function GetBrokerConnectionIndexFromUniqueClientId(UniqueClientId: Integer): Integer;
|
---|
121 |
|
---|
122 | property RPCBError: String read FRPCBError write FRPCBError;
|
---|
123 | property OnRPCBFailure: TOnRPCBFailure read FOnRPCBFailure write FOnRPCBFailure;
|
---|
124 |
|
---|
125 | property User: TVistaUser read FUser write FUser; // jli
|
---|
126 | property Login: TVistaLogin read FLogin write FLogin; // jli
|
---|
127 | property OnConnectionDropped: TOnConnectionDropped read FOnConnectionDropped write FOnConnectionDropped;
|
---|
128 | {
|
---|
129 | property OnClientConnected: TOnClientConnected read FOnClientConnected write FOnClientConnected;
|
---|
130 | property OnClientDisconnected: TOnClientDisconnected read FOnClientDisconnected write FOnClientDisconnected;
|
---|
131 | }
|
---|
132 | published
|
---|
133 | // Call is he invocation entry point of the RPC call.
|
---|
134 | // The RPC Name, params, server and listener port must all be set up before
|
---|
135 | // making this call
|
---|
136 | procedure Call; override;
|
---|
137 |
|
---|
138 | // lstCall is similar to the method Call, but puts Results in OutputBuffer
|
---|
139 | // lstCall actually calls Call so it is really more efficient to use the
|
---|
140 | // Call method and get the results from the Results property
|
---|
141 | procedure lstCall(OutputBuffer: TStrings); override;
|
---|
142 |
|
---|
143 | // pchCall makes an RPC call and returns the results in a PChar;
|
---|
144 | // pchCall actually calls the Call method and then converts the results
|
---|
145 | // to PChar before returning.
|
---|
146 | // Making a call to Call and then using the Results property to get
|
---|
147 | // results is more efficient
|
---|
148 | function pchCall: PChar; override;
|
---|
149 |
|
---|
150 | // strCall makes an RPC call and returns the results in a string;
|
---|
151 | // strCall actually calls the Call method and then converts the results
|
---|
152 | // to a string before returning.
|
---|
153 | // Making a call to Call and then using the Results property to get
|
---|
154 | // results is more efficient
|
---|
155 | function strCall: string; override;
|
---|
156 |
|
---|
157 | // CreateContext sets up the context for the RPC call on the M server
|
---|
158 | function CreateContext(strContext: string): boolean; override;
|
---|
159 |
|
---|
160 |
|
---|
161 | {
|
---|
162 | // Server sets the server name or direct IP address
|
---|
163 | // Must be set BEFORE making the connection or the default on the system
|
---|
164 | // will be used
|
---|
165 | property Server: TServer read FServer write FServer;
|
---|
166 | }
|
---|
167 | // AllowShared allows this connection to share with and existing one
|
---|
168 | // Must be set BEFORE making a connection
|
---|
169 | property AllowShared: Boolean read FAllowShared write FAllowShared;
|
---|
170 | {
|
---|
171 | // DebugMode turns the debug mode on or off.
|
---|
172 | // Must be set BEFORE making an RPC Call
|
---|
173 | property DebugMode: boolean read FDebugMode write FDebugMode default False;
|
---|
174 |
|
---|
175 | // ListenerPort sets the listener port on the server
|
---|
176 | // Must be set BEFORE making a connection
|
---|
177 | property ListenerPort: integer read FListenerPort write FListenerPort;
|
---|
178 |
|
---|
179 | // Param accesses the parameters for the RPC call.
|
---|
180 | // Set them BEFORE making the RPC call
|
---|
181 | property Param: TParams read FParams write FParams;
|
---|
182 |
|
---|
183 | // Results contains the results of the most recent RPC call
|
---|
184 | property Results: TStrings read FResults write SetResults;
|
---|
185 |
|
---|
186 | // RemoteProcedure sets the name of the RPC to be made
|
---|
187 | // Set this BEFORE making the Call
|
---|
188 | property RemoteProcedure: TRemoteProc read FRemoteProcedure1 write FRemoteProcedure1;
|
---|
189 | // property RemoteProcedure: TRemoteProc read GetRPC write SetRPC;
|
---|
190 |
|
---|
191 | // The RpcVersion property is used to tell the M server on the other end of the RPCBroker connection
|
---|
192 | // which version of the RPC call it is expecting the M server to service. This is for the Client
|
---|
193 | // to specify.
|
---|
194 | // Note: This is NOT the version of the RPCBroker!
|
---|
195 | property RpcVersion: TRpcVersion read GetRpcVersion write SetRpcVersion;
|
---|
196 |
|
---|
197 | // ClearParameters clears out the params data if set to true so one can start over easily with
|
---|
198 | // new parameters
|
---|
199 | property ClearParameters: boolean read FClearParameters write SetClearParameters;
|
---|
200 |
|
---|
201 | // ClearResults clears out the Results data if set to true. This is from legacy code. In
|
---|
202 | // the current implementation the Results from a recent call overwrite the current Results anyway.
|
---|
203 | property ClearResults: boolean read FClearResults write SetClearResults;
|
---|
204 | }
|
---|
205 | // If Connected is set to True then it makes a BrokerConnection call to the VistASessionMgr.
|
---|
206 | // property Connected: boolean read FConnected write SetConnected;
|
---|
207 | property Connected: boolean read GetConnected write SetConnected default False;
|
---|
208 |
|
---|
209 | // RPCTimeLimit allows the application to change the network operation timeout prior to a call.
|
---|
210 | // This may be useful during times when it is known that a certain RPC, by its nature,
|
---|
211 | // can take a significant amount of time to execute. The value of this property is an
|
---|
212 | // integer that can not be less than 30 seconds nor greater that 32767 seconds.
|
---|
213 | // Care should be taken when altering this value, since the network operation will block
|
---|
214 | // the application until the operation finishes or the timeout is triggered.
|
---|
215 | property RPCTimeLimit : integer read FRPCTimeLimit write SetRPCTimeLimit;
|
---|
216 |
|
---|
217 | // OnLogout sets/gets the OnLogout event handler to be called whenever the VistASessionMgr
|
---|
218 | // logs out.
|
---|
219 | // property OnLogout: TNotifyEvent read FOnLogout write SetOnLogout;
|
---|
220 | property OnLogout: TLogout read FOnLogout write SetOnLogout;
|
---|
221 |
|
---|
222 | property Socket: Integer read FSocket;
|
---|
223 |
|
---|
224 | property KernelLogin: Boolean read FKernelLogin write FKernelLogin default True; // jli
|
---|
225 |
|
---|
226 | end;
|
---|
227 |
|
---|
228 | implementation
|
---|
229 |
|
---|
230 | uses ComObj, MfunStr, SharedRPCBrokerSink, fRPCBErrMsg;
|
---|
231 |
|
---|
232 | const
|
---|
233 | {Keys}
|
---|
234 | REG_BROKER = 'Software\Vista\Broker';
|
---|
235 | REG_VISTA = 'Software\Vista';
|
---|
236 | REG_SIGNON = 'Software\Vista\Signon';
|
---|
237 | REG_SERVERS = 'Software\Vista\Broker\Servers';
|
---|
238 |
|
---|
239 |
|
---|
240 | procedure TSharedRPCBroker.SetLoginStr(Str: string);
|
---|
241 |
|
---|
242 | function TorF(Value: String): Boolean;
|
---|
243 | begin
|
---|
244 | Result := False;
|
---|
245 | if Value = '1' then
|
---|
246 | Result := True;
|
---|
247 | end;
|
---|
248 | const
|
---|
249 | SEP_FS = #28;
|
---|
250 | SEP_GS = #29;
|
---|
251 | var
|
---|
252 | DivStr: String;
|
---|
253 | StrFS: String;
|
---|
254 | StrGS: String;
|
---|
255 | ModeVal: String;
|
---|
256 | I: Integer;
|
---|
257 | DivisionList: TStringList;
|
---|
258 | begin
|
---|
259 | StrFS := SEP_FS;
|
---|
260 | StrGS := SEP_GS;
|
---|
261 | with FLogin do
|
---|
262 | begin
|
---|
263 | LoginHandle := Piece(Str,StrFS,1);
|
---|
264 | NTToken := Piece(Str,StrFS,2);
|
---|
265 | AccessCode := Piece(Str,StrFS,3);
|
---|
266 | VerifyCode := Piece(Str,StrFS,4);
|
---|
267 | Division := Piece(Str,StrFS,5);
|
---|
268 | ModeVal := Piece(Str,StrFS,6);
|
---|
269 | DivStr := Piece(Str,StrFS,7);
|
---|
270 | MultiDivision := TorF(Piece(Str,StrFS,8));
|
---|
271 | DUZ := Piece(Str,StrFS,9);
|
---|
272 | PromptDivision := TorF(Piece(Str,StrFS,10));
|
---|
273 | ErrorText := Piece(Str,StrFS,11);
|
---|
274 | if ModeVal = '1' then
|
---|
275 | Mode := lmAVCodes
|
---|
276 | else if ModeVal = '2' then
|
---|
277 | Mode := lmAppHandle
|
---|
278 | else if ModeVal = '3' then
|
---|
279 | Mode := lmNTToken;
|
---|
280 | if DivStr <> '' then
|
---|
281 | begin
|
---|
282 | DivisionList := TStringList.Create;
|
---|
283 | try
|
---|
284 | I := 1;
|
---|
285 | while Piece(DivStr,StrGS,I) <> '' do
|
---|
286 | begin
|
---|
287 | DivisionList.Add(Piece(DivStr,StrGS,I));
|
---|
288 | Inc(I);
|
---|
289 | end; // while
|
---|
290 | DivList.Assign(DivisionList);
|
---|
291 | finally
|
---|
292 | DivisionList.Free;
|
---|
293 | end;
|
---|
294 | end;
|
---|
295 | end; // with
|
---|
296 | end;
|
---|
297 |
|
---|
298 | procedure TSharedRPCBroker.SetUserStr(Str: String);
|
---|
299 | const
|
---|
300 | SEP_FS = #28;
|
---|
301 | var
|
---|
302 | VC: String;
|
---|
303 | StrFS: String;
|
---|
304 | begin
|
---|
305 | StrFS := SEP_FS;
|
---|
306 | with User do
|
---|
307 | begin
|
---|
308 | DUZ := Piece(Str,StrFS,1);
|
---|
309 | Name := Piece(Str,StrFS,2);
|
---|
310 | StandardName := Piece(Str,StrFS,3);
|
---|
311 | Division := Piece(Str,StrFS,4);
|
---|
312 | VC := Piece(Str,StrFS,5);
|
---|
313 | Title := Piece(Str,StrFS,6);
|
---|
314 | ServiceSection := Piece(Str,StrFS,7);
|
---|
315 | Language := Piece(Str,StrFS,8);
|
---|
316 | DTime := Piece(Str,StrFS,9);
|
---|
317 | if VC = '0' then
|
---|
318 | VerifyCodeChngd := False
|
---|
319 | else if VC = '1' then
|
---|
320 | VerifyCodeChngd := True;
|
---|
321 | end; // with
|
---|
322 | end;
|
---|
323 |
|
---|
324 | function TSharedRPCBroker.LoginStr: string;
|
---|
325 | function TorF1(Value: Boolean): String;
|
---|
326 | begin
|
---|
327 | Result := '0';
|
---|
328 | if Value then
|
---|
329 | Result := '1';
|
---|
330 | end;
|
---|
331 |
|
---|
332 | const
|
---|
333 | SEP_FS = #28;
|
---|
334 | SEP_GS = #29;
|
---|
335 | var
|
---|
336 | Str: String;
|
---|
337 | ModeVal: String;
|
---|
338 | DivLst: String;
|
---|
339 | MultiDiv: String;
|
---|
340 | PromptDiv: String;
|
---|
341 | StrFS, StrGS: String;
|
---|
342 | begin
|
---|
343 | Str := '';
|
---|
344 | with FLogin do
|
---|
345 | begin
|
---|
346 | StrFS := SEP_FS;
|
---|
347 | StrGS := SEP_GS;
|
---|
348 | ModeVal := '';
|
---|
349 | if Mode = lmAVCodes then
|
---|
350 | ModeVal := '1'
|
---|
351 | else if Mode = lmAppHandle then
|
---|
352 | ModeVal := '2'
|
---|
353 | else if Mode = lmNTToken then
|
---|
354 | ModeVal := '3';
|
---|
355 | DivLst := '';
|
---|
356 | MultiDiv := TorF1(MultiDivision);
|
---|
357 | PromptDiv := TorF1(PromptDivision);
|
---|
358 | Str := LoginHandle + StrFS + NTToken + StrFS + AccessCode + StrFS;
|
---|
359 | Str := Str + VerifyCode + StrFS + Division + StrFS + ModeVal + StrFS;
|
---|
360 | Str := Str + DivLst + StrFS + MultiDiv + StrFS + DUZ + StrFS;
|
---|
361 | Str := Str + PromptDiv + StrFS + ErrorText + StrFS;
|
---|
362 | end; // with
|
---|
363 | Result := Str;
|
---|
364 | end;
|
---|
365 | // Constructor and Destructor implemented here
|
---|
366 | constructor TSharedRPCBroker.Create(AOwner: TComponent);
|
---|
367 | const
|
---|
368 | ProgID = 'RPCSharedBrokerSessionMgr.Application';
|
---|
369 | //var
|
---|
370 | // brokerError: ISharedBrokerErrorCode;
|
---|
371 | // regResult: WideString;
|
---|
372 | begin
|
---|
373 | inherited Create(AOwner);
|
---|
374 | FConnected := False;
|
---|
375 | DebugMode := False;
|
---|
376 | FParams := TParams.Create(Self);
|
---|
377 | // FResults := TStringList.Create;
|
---|
378 | RpcVersion := '0';
|
---|
379 | FCurrRpcVersion := '0';
|
---|
380 | FRPCTimeLimit := MIN_RPCTIMELIMIT; // MIN_RPCTIMELIMIT comes from TRPCBroker (30 seconds)
|
---|
381 | // FAllowShared := False;
|
---|
382 | FOnLogout := OnLogoutEventHandlerDefault; // Supply this one incase the application doesn't
|
---|
383 | FOnConnectionDropped := OnConnectionDroppedHandler;
|
---|
384 | Server := '';
|
---|
385 | ListenerPort := 0;
|
---|
386 |
|
---|
387 | FKernelLogin := True; // jli
|
---|
388 | FUser := TVistaUser.Create; // jli
|
---|
389 | FLogin := TVistaLogin.Create(Self); // jli
|
---|
390 |
|
---|
391 | // CoInitialize(nil);
|
---|
392 | { try
|
---|
393 | if not (CoInitialize(nil) = S_OK) then
|
---|
394 | ShowMessage('CoInitialize Problem!');
|
---|
395 | except
|
---|
396 | end;
|
---|
397 | }
|
---|
398 | end;
|
---|
399 |
|
---|
400 | destructor TSharedRPCBroker.Destroy;
|
---|
401 | begin
|
---|
402 | if Connected then // FConnected
|
---|
403 | begin
|
---|
404 | Connected := False;
|
---|
405 | FConnected := False;
|
---|
406 | end;
|
---|
407 | FParams.Free;
|
---|
408 | FParams := nil;
|
---|
409 | {
|
---|
410 | FResults.Free;
|
---|
411 | FResults := nil;
|
---|
412 | }
|
---|
413 | if FVistaSession <> nil then
|
---|
414 | begin
|
---|
415 | // FVistaSession.Free;
|
---|
416 | FVistaSession := nil;
|
---|
417 | end;
|
---|
418 | {
|
---|
419 | FUser.Free;
|
---|
420 | FLogin.Free;
|
---|
421 | }
|
---|
422 | inherited;
|
---|
423 | end;
|
---|
424 |
|
---|
425 | //procedure TSharedRPCBroker.OnLogoutEventHandlerDefault(Sender: TObject);
|
---|
426 | procedure TSharedRPCBroker.OnLogoutEventHandlerDefault;
|
---|
427 | begin
|
---|
428 | // This event handler will get called if the application that uses
|
---|
429 | // this component does not supply one.
|
---|
430 | SendMessage(Application.MainForm.Handle,WM_CLOSE,0,0);
|
---|
431 | end;
|
---|
432 |
|
---|
433 | procedure TSharedRPCBroker.OnConnectionDroppedHandler(ConnectionIndex: Integer; ErrorText: WideString);
|
---|
434 | var
|
---|
435 | Str: String;
|
---|
436 | // BrokerError: EBrokerError;
|
---|
437 | begin
|
---|
438 | Str := ErrorText;
|
---|
439 | RPCBShowErrMsg(ErrorText);
|
---|
440 | // FConnected := False;
|
---|
441 | // Raising an error here returns an error 'The Server Threw an exception' back into the server
|
---|
442 | // BrokerError := EBrokerError.Create(Str);
|
---|
443 | // raise BrokerError;
|
---|
444 | end;
|
---|
445 |
|
---|
446 | // Published Methods implemented here
|
---|
447 | procedure TSharedRPCBroker.Call;
|
---|
448 | const
|
---|
449 | SEP_FS = #28;
|
---|
450 | SEP_GS = #29;
|
---|
451 | SEP_US = #30;
|
---|
452 | SEP_RS = #31;
|
---|
453 | var
|
---|
454 | i, j, ErrCode: Integer;
|
---|
455 | rpcParams, ASub, AVal: string;
|
---|
456 | ReturnedResults: WideString;
|
---|
457 | AnError: EBrokerError;
|
---|
458 | ErrCode1: ISharedBrokerErrorCode;
|
---|
459 | begin
|
---|
460 | try
|
---|
461 | rpcParams := '';
|
---|
462 | if not Connected then Connected := True;
|
---|
463 | for i := 0 to Pred(Param.Count) do
|
---|
464 | begin
|
---|
465 | case Param[i].PType of
|
---|
466 | literal: rpcParams := rpcParams + 'L' + SEP_FS;
|
---|
467 | reference: rpcParams := rpcParams + 'R' + SEP_FS;
|
---|
468 | list: rpcParams := rpcParams + 'M' + SEP_FS;
|
---|
469 | else rpcParams := rpcParams + 'U' + SEP_FS;
|
---|
470 | end; {case}
|
---|
471 | if Param[i].PType = list then
|
---|
472 | begin
|
---|
473 | for j := 0 to Pred(Param[i].Mult.Count) do
|
---|
474 | begin
|
---|
475 | ASub := Param[i].Mult.Subscript(j);
|
---|
476 | AVal := Param[i].Mult[ASub];
|
---|
477 | rpcParams := rpcParams + ASub + SEP_US + AVal + SEP_RS;
|
---|
478 | end;
|
---|
479 | rpcParams := rpcParams + SEP_GS;
|
---|
480 | end else
|
---|
481 | begin
|
---|
482 | rpcParams := rpcParams + Param[i].Value + SEP_GS;
|
---|
483 | end; {if Param[i]...else}
|
---|
484 | end; {for i}
|
---|
485 | if RpcVersion <> FCurrRpcVersion then
|
---|
486 | FVistaSession.Set_RPCVersion(RPCVersion);
|
---|
487 |
|
---|
488 | RPCBError := '';
|
---|
489 |
|
---|
490 | ErrCode1 := FVistaSession.BrokerCall(RemoteProcedure, rpcParams, RPCTimeLimit, ReturnedResults, ErrCode);
|
---|
491 |
|
---|
492 | if ClearParameters = true then
|
---|
493 | Param.Clear;
|
---|
494 |
|
---|
495 | if ErrCode1 = Success then
|
---|
496 | Results.Text := ReturnedResults
|
---|
497 | else
|
---|
498 | begin
|
---|
499 | Results.Text := '';
|
---|
500 | RPCBError := FVistaSession.RpcbError;
|
---|
501 | if Assigned(FOnRPCBFailure) then // p13
|
---|
502 | FOnRPCBFailure(Self) // p13
|
---|
503 | else if ShowErrorMsgs = semRaise then
|
---|
504 | begin
|
---|
505 | AnError := EBrokerError.Create(FRPCBError);
|
---|
506 | raise AnError;
|
---|
507 | end
|
---|
508 | else
|
---|
509 | exit;
|
---|
510 | end; {if ErrCode...else}
|
---|
511 | except
|
---|
512 | on e: Exception do
|
---|
513 | begin
|
---|
514 | AnError := EBrokerError.Create('Error: ' + e.Message);
|
---|
515 | raise AnError;
|
---|
516 | end;
|
---|
517 | end;
|
---|
518 | end;
|
---|
519 |
|
---|
520 | function TSharedRPCBroker.CreateContext(strContext: string): boolean;
|
---|
521 | var
|
---|
522 | Intval: Integer;
|
---|
523 | begin
|
---|
524 | // hides the RPCBroker CreateContext
|
---|
525 | if not Connected then SetConnected(TRUE); // FConnected
|
---|
526 |
|
---|
527 | Intval := FVistaSession.BrokerSetContext(strContext);
|
---|
528 | Result := Intval = 1;
|
---|
529 | end;
|
---|
530 |
|
---|
531 | procedure TSharedRPCBroker.lstCall(OutputBuffer: TStrings);
|
---|
532 | begin
|
---|
533 | Call;
|
---|
534 | OutputBuffer.Text := Results.Text;
|
---|
535 | end;
|
---|
536 |
|
---|
537 | function TSharedRPCBroker.pchCall: PChar;
|
---|
538 | begin
|
---|
539 | Call;
|
---|
540 | Result := Results.GetText;
|
---|
541 | end;
|
---|
542 |
|
---|
543 | function TSharedRPCBroker.strCall: string;
|
---|
544 | begin
|
---|
545 | Call;
|
---|
546 | Result := Results.Text;
|
---|
547 | end;
|
---|
548 |
|
---|
549 | procedure TSharedRPCBroker.SetConnected(Value: Boolean);
|
---|
550 | var
|
---|
551 | uniqueClientId: Integer;
|
---|
552 | brokerError: ISharedBrokerErrorCode;
|
---|
553 | regResult: WideString;
|
---|
554 | CurrWindow: HWND;
|
---|
555 | AnError: EBrokerError;
|
---|
556 | UserStr: String;
|
---|
557 | RPCError: WideString;
|
---|
558 | BrokerErrorVal: EBrokerError;
|
---|
559 | ShowErrMsgs: ISharedBrokerShowErrorMsgs;
|
---|
560 | LoginStrX: WideString;
|
---|
561 | SBSink: TSharedRPCBrokerSink;
|
---|
562 | begin
|
---|
563 | try
|
---|
564 | { call connect method for VistaSession }
|
---|
565 | if Value then
|
---|
566 | begin
|
---|
567 | if FVistaSession = nil then
|
---|
568 | begin
|
---|
569 | FVistaSession := CreateComObject(CLASS_SharedBroker) as ISharedBroker; // TSharedBroker.Create(self);
|
---|
570 | // FVistaSession.Connect;
|
---|
571 | //No need to keep hold of event sink. It will be destroyed
|
---|
572 | //through interface reference counting when the client
|
---|
573 | //disconnects from the server in the form's OnDestroy event handler
|
---|
574 | SBSink := TSharedRPCBrokerSink.Create;
|
---|
575 | SBSink.Broker := Self;
|
---|
576 | InterfaceConnect(FVistaSession, ISharedBrokerEvents, SBSink, FSinkCookie);
|
---|
577 |
|
---|
578 | // ConnectEvents(FVistaSession);
|
---|
579 | { If Assigned(FOnLogout) then
|
---|
580 | FVistaSession.OnLogout := FOnLogout;
|
---|
581 | if Assigned(FOnConnectionDropped) then
|
---|
582 | FVistaSession.OnConnectionDropped := OnConnectionDroppedHandler;
|
---|
583 | }
|
---|
584 | regResult := '';
|
---|
585 | brokerError := FVistaSession.ReadRegDataDefault(HKLM,REG_BROKER,'ClearParameters','1',regResult);
|
---|
586 | Assert(brokerError = Success);
|
---|
587 |
|
---|
588 | ClearParameters := boolean(StrToInt(regResult)); // FClearParameters
|
---|
589 |
|
---|
590 | brokerError := FVistaSession.ReadRegDataDefault(HKLM,REG_BROKER,'ClearResults','1',regResult);
|
---|
591 | Assert(brokerError = Success);
|
---|
592 | ClearResults := boolean(StrToInt(regResult)); // FClearResults
|
---|
593 |
|
---|
594 | // DebugMode := False;
|
---|
595 | // FParams := TParams.Create(Self);
|
---|
596 | // FResults := TStringList.Create; ???
|
---|
597 |
|
---|
598 | if Server = '' then
|
---|
599 | begin
|
---|
600 | brokerError := FVistaSession.ReadRegDataDefault(HKLM,REG_BROKER,'Server','BROKERSERVER',regResult);
|
---|
601 | Assert(brokerError = Success);
|
---|
602 | Server := regResult;
|
---|
603 | end;
|
---|
604 |
|
---|
605 | if ListenerPort = 0 then
|
---|
606 | begin
|
---|
607 | brokerError := FVistaSession.ReadRegDataDefault(HKLM,REG_BROKER,'ListenerPort','9000',regResult);
|
---|
608 | Assert(brokerError = Success);
|
---|
609 | ListenerPort := StrToInt(regResult);
|
---|
610 | end;
|
---|
611 |
|
---|
612 | RpcVersion := '0'; // TODO: Remove this when the property is remove. It is UESLESS!
|
---|
613 |
|
---|
614 | // FRPCTimeLimit := MIN_RPCTIMELIMIT; // MIN_RPCTIMELIMIT comes from TRPCBroker (30 seconds)
|
---|
615 | // AllowShared := True;
|
---|
616 | end;
|
---|
617 |
|
---|
618 | if FConnected <> True then // FConnected
|
---|
619 | begin
|
---|
620 | // Connect to the M server through the COm Server
|
---|
621 | CurrWindow := GetActiveWindow;
|
---|
622 | if AccessVerifyCodes <> '' then // p13 handle as AVCode single signon
|
---|
623 | begin
|
---|
624 | Login.AccessCode := Piece(AccessVerifyCodes, ';', 1);
|
---|
625 | Login.VerifyCode := Piece(AccessVerifyCodes, ';', 2);
|
---|
626 | Login.Mode := lmAVCodes;
|
---|
627 | FKernelLogIn := False;
|
---|
628 | end;
|
---|
629 | if ShowErrorMsgs = semRaise then
|
---|
630 | ShowErrMsgs := isemRaise
|
---|
631 | else
|
---|
632 | ShowErrMsgs := isemQuiet;
|
---|
633 | BrokerError := GeneralFailure;
|
---|
634 | LoginStrX := WideString(LoginStr);
|
---|
635 | try
|
---|
636 | brokerError := FVistaSession.BrokerConnect(ParamStr(0),BrokerClient,Server + ':' + IntToStr(ListenerPort),
|
---|
637 | DebugMode, FAllowShared, FKernelLogin, ShowErrMsgs, RPCTimeLimit, LoginStrX, uniqueClientId, RPCError);
|
---|
638 | except
|
---|
639 | end;
|
---|
640 | FRPCBError := RPCError;
|
---|
641 | SetLoginStr(LoginStrX);
|
---|
642 | ShowApplicationAndFocusOK(Application);
|
---|
643 | SetForegroundWindow(CurrWindow);
|
---|
644 | if brokerError = Success then
|
---|
645 | begin
|
---|
646 | FConnected := True; // FConnected
|
---|
647 | FSocket := 1; // temporarily handle socket until it can be pulled from Shared Broker;
|
---|
648 | UserStr := FVistaSession.User;
|
---|
649 | SetUserStr(UserStr);
|
---|
650 | end
|
---|
651 | else
|
---|
652 | begin
|
---|
653 | if Assigned(FOnRPCBFailure) then // p13
|
---|
654 | FOnRPCBFailure(Self) // p13
|
---|
655 | else if ShowErrorMsgs = semRaise then
|
---|
656 | begin
|
---|
657 | BrokerErrorVal := EBrokerError.Create(FRPCBError);
|
---|
658 | raise BrokerErrorVal;
|
---|
659 | end;
|
---|
660 | end;
|
---|
661 | end;
|
---|
662 |
|
---|
663 | end else
|
---|
664 | begin
|
---|
665 | if FVistaSession<>nil then
|
---|
666 | begin
|
---|
667 | if FConnected = true then // FConnected
|
---|
668 | begin
|
---|
669 | // Lets make the OnLogout event handler nil to eliminate
|
---|
670 | // circularity problems before we do the disconnects.
|
---|
671 | OnLogout := nil;
|
---|
672 |
|
---|
673 | FVistaSession.BrokerDisconnect; // Disconnect from the Broker
|
---|
674 | // FVistaSession.Disconnect; // Disconnect from the COM server
|
---|
675 | FSocket := 0; // temporarily handle socket until it can be pulled from Shared Broker
|
---|
676 | end;
|
---|
677 | // FVistaSession.Free;
|
---|
678 | InterfaceDisconnect(FVistaSession, ISharedBrokerEvents, FSinkCookie);
|
---|
679 | FVistaSession := nil;
|
---|
680 | end;
|
---|
681 | FConnected := False; // FConnected
|
---|
682 | end;
|
---|
683 | except
|
---|
684 | on e: Exception do
|
---|
685 | begin
|
---|
686 | AnError := EBrokerError.Create('Error: ' + e.Message);
|
---|
687 | raise AnError;
|
---|
688 | end;
|
---|
689 | end;
|
---|
690 | end;
|
---|
691 |
|
---|
692 | procedure TSharedRPCBroker.SetResults(Value: TStrings);
|
---|
693 | begin
|
---|
694 | Results.Assign(Value); // FResults
|
---|
695 | end;
|
---|
696 |
|
---|
697 | procedure TSharedRPCBroker.SetClearParameters(Value: Boolean);
|
---|
698 | begin
|
---|
699 | if Value then Param.Clear; // FParams
|
---|
700 | FClearParameters := Value; // FClearParameters
|
---|
701 | end;
|
---|
702 |
|
---|
703 | procedure TSharedRPCBroker.SetClearResults(Value: Boolean);
|
---|
704 | begin
|
---|
705 | if Value then Results.Clear; // FResults
|
---|
706 | FClearResults := Value; // FClearResults
|
---|
707 | end;
|
---|
708 |
|
---|
709 | procedure TSharedRPCBroker.SetRPCTimeLimit(Value: integer);
|
---|
710 | begin
|
---|
711 | if Value <> RPCTimeLimit then // FRPCTimeLimit
|
---|
712 | if Value > MIN_RPCTIMELIMIT then
|
---|
713 | FRPCTimeLimit := Value // FRPCTimeLimit
|
---|
714 | else
|
---|
715 | FRPCTimeLimit := MIN_RPCTIMELIMIT; // FRPCTimeLimit
|
---|
716 | end;
|
---|
717 |
|
---|
718 | //procedure TSharedRPCBroker.SetOnLogout(EventHandler: TNotifyEvent);
|
---|
719 | procedure TSharedRPCBroker.SetOnLogout(EventHandler: TLogout);
|
---|
720 | begin
|
---|
721 | FOnLogout := EventHandler;
|
---|
722 | // if FVistaSession <> nil then
|
---|
723 | // FVistaSession.OnLogout := FOnLogout;
|
---|
724 | end;
|
---|
725 |
|
---|
726 | function TSharedRPCBroker.GetRpcVersion: TRpcVersion;
|
---|
727 | begin
|
---|
728 | if FVistaSession <> nil then Result := FVistaSession.RPCVersion else Result := '0';
|
---|
729 | end;
|
---|
730 |
|
---|
731 | procedure TSharedRPCBroker.SetRpcVersion(version: TRpcVersion);
|
---|
732 | begin
|
---|
733 | if FVistaSession <> nil then FVistaSession.RPCVersion:= version;
|
---|
734 | end;
|
---|
735 |
|
---|
736 | function TSharedRPCBroker.GetConnected: Boolean;
|
---|
737 | begin
|
---|
738 | Result := FConnected;
|
---|
739 | end;
|
---|
740 |
|
---|
741 | {
|
---|
742 | procedure TSharedRPCBroker.SetRPC(Value: TRemoteProc);
|
---|
743 | begin
|
---|
744 | RemoteProcedure := Value;
|
---|
745 | end;
|
---|
746 |
|
---|
747 | function TSharedRPCBroker.GetRPC: TRemoteProc;
|
---|
748 | begin
|
---|
749 | Result := FRemoteProcedure1;
|
---|
750 | end;
|
---|
751 | }
|
---|
752 | {
|
---|
753 | procedure Register;
|
---|
754 | begin
|
---|
755 | RegisterComponents('Kernel', [TSharedBrokerDataCollector]);
|
---|
756 | end;
|
---|
757 | }
|
---|
758 |
|
---|
759 | function TSharedRPCBroker.GetBrokerConnectionIndexFromUniqueClientId(UniqueClientId: Integer): Integer;
|
---|
760 | var
|
---|
761 | ConnectionIndex: Integer;
|
---|
762 | begin
|
---|
763 | ConnectionIndex := -1;
|
---|
764 | if FVistaSession <> nil then
|
---|
765 | FVistaSession.GetActiveBrokerConnectionIndexFromUniqueClientId(UniqueClientId, ConnectionIndex);
|
---|
766 | Result := ConnectionIndex;
|
---|
767 | end;
|
---|
768 |
|
---|
769 | end.
|
---|