source: cprs/branches/tmg-cprs/BDK32/Source/Trpcb.pas@ 1742

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

Initial upload of TMG-CPRS 1.0.26.69

File size: 59.4 KB
Line 
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: Danila Manapsal, Don Craven, Joel Ivey
6 Description: Contains TRPCBroker and related components.
7 Current Release: Version 1.1 Patch 40 (January 7, 2005))
8*************************************************************** }
9
10{**************************************************
11This is the hierarchy of things:
12 TRPCBroker contains
13 TParams, which contains
14 array of TParamRecord each of which contains
15 TMult
16
17v1.1*4 Silent Login changes (DCM) 10/22/98
18
191.1*6 Polling to support terminating arphaned server jobs. (P6)
20 == DPC 4/99
21
221.1*8 Check for Multi-Division users. (P8) - REM 7/13/99
23
241.1*13 More silent login code; deleted obsolete lines (DCM) 9/10/99 // p13
25LAST UPDATED: 5/24/2001 // p13 JLI
26
271.1*31 Added new read only property BrokerVersion to TRPCBroker which
28 should contain the version number for the RPCBroker
29 (or SharedRPCBroker) in use.
30**************************************************}
31unit Trpcb;
32
33interface
34
35{$I IISBase.inc}
36
37uses
38 {Delphi standard}
39 Classes, Controls, Dialogs, {DsgnIntf,} Forms, Graphics, Messages, SysUtils,
40 WinProcs, WinTypes, Windows,
41 extctrls, {P6}
42 {VA}
43 XWBut1, {RpcbEdtr,} MFunStr, Hash; //P14 -- pack split
44
45const
46 NoMore: boolean = False;
47 MIN_RPCTIMELIMIT: integer = 30;
48 CURRENT_RPC_VERSION: String = 'XWB*1.1*40';
49
50type
51
52TParamType = (literal, reference, list, global, empty, stream, undefined); // 030107 JLI Modified for new message protocol
53
54//P14 -- pack split -- Types moved from RpcbEdtr.pas.
55TAccessVerifyCodes = string[255]; //to use TAccessVerifyCodesProperty editor use this type
56TRemoteProc = string[100]; //to use TRemoteProcProperty editor use this type
57TServer = string[255]; //to use TServerProperty editor use this type
58TRpcVersion = string[255]; //to use TRpcVersionProperty editor use this type
59
60TRPCBroker = class;
61TVistaLogin = class;
62// p13
63TLoginMode = (lmAVCodes, lmAppHandle, lmNTToken);
64TShowErrorMsgs = (semRaise, semQuiet); // p13
65TOnLoginFailure = procedure (VistaLogin: TVistaLogin) of object; //p13
66TOnRPCBFailure = procedure (RPCBroker: TRPCBroker) of object; //p13
67TOnPulseError = procedure(RPCBroker: TRPCBroker; ErrorText: String) of object;
68// TOnRPCCall = procedure (RPCBroker: TRPCBroker; SetNum: Integer; RemoteProcedure: TRemoteProc; CurrentContext: String; RpcVersion: TRpcVersion; Param: TParams; RPCTimeLimit: Integer; Results, Sec, App: PChar; DateTime: TDateTime) of object;
69
70{------ EBrokerError ------}
71EBrokerError = class(Exception)
72public
73 Action: string;
74 Code: integer;
75 Mnemonic: string;
76end;
77
78{------ TString ------}
79
80TString = class(TObject)
81 Str: string;
82end;
83
84{------ TMult ------}
85{:This component defines the multiple field of a parameter. The multiple
86 field is used to pass string-subscripted array of data in a parameter.}
87
88TMult = class(TComponent)
89private
90 FMultiple: TStringList;
91 procedure ClearAll;
92 function GetCount: Word;
93 function GetFirst: string;
94 function GetLast: string;
95 function GetFMultiple(Index: string): string;
96 function GetSorted: boolean;
97 procedure SetFMultiple(Index: string; value: string);
98 procedure SetSorted(Value: boolean);
99protected
100public
101 constructor Create(AOwner: TComponent); override; {1.1T8}
102 destructor Destroy; override;
103 procedure Assign(Source: TPersistent); override;
104 function Order(const StartSubscript: string; Direction: integer): string;
105 function Position(const Subscript: string): longint;
106 function Subscript(const Position: longint): string;
107 property Count: Word read GetCount;
108 property First: string read GetFirst;
109 property Last: string read GetLast;
110 property MultArray[I: string]: string
111 read GetFMultiple write SetFMultiple; default;
112 property Sorted: boolean read GetSorted write SetSorted;
113end;
114
115{------ TParamRecord ------}
116{:This component defines all the fields that comprise a parameter.}
117
118TParamRecord = class(TComponent)
119private
120 FMult: TMult;
121 FValue: string;
122 FPType: TParamType;
123protected
124public
125 constructor Create(AOwner: TComponent); override;
126 destructor Destroy; override;
127 property Value: string read FValue write FValue;
128 property PType: TParamType read FPType write FPType;
129 property Mult: TMult read FMult write FMult;
130end;
131
132{------ TParams ------}
133{:This component is really a collection of parameters. Simple inclusion
134 of this component in the Broker component provides access to all of the
135 parameters that may be needed when calling a remote procedure.}
136
137TParams = class(TComponent)
138private
139 FParameters: TList;
140 function GetCount: Word;
141 function GetParameter(Index: integer): TParamRecord;
142 procedure SetParameter(Index: integer; Parameter: TParamRecord);
143public
144 constructor Create(AOwner: TComponent); override;
145 destructor Destroy; override;
146 procedure Assign(Source: TPersistent); override;
147 procedure Clear;
148 property Count: Word read GetCount;
149 property ParamArray[I: integer]: TParamRecord
150 read GetParameter write SetParameter; default;
151end;
152
153
154{------ TVistaLogin ------} //p13
155TVistaLogin = class(TPersistent)
156private
157 FLogInHandle : string;
158 FNTToken : string;
159 FAccessCode : string;
160 FVerifyCode : string;
161 FDivision : string;
162 FMode: TLoginMode;
163 FDivLst: TStrings;
164 FOnFailedLogin: TOnLoginFailure;
165 FMultiDivision : boolean;
166 FDUZ: string;
167 FErrorText : string;
168 FPromptDiv : boolean;
169 FIsProductionAccount: Boolean;
170 FDomainName: string;
171 procedure SetAccessCode(const Value: String);
172 procedure SetLogInHandle(const Value: String);
173 procedure SetNTToken(const Value: String);
174 procedure SetVerifyCode(const Value: String);
175 procedure SetDivision(const Value: String);
176 //procedure SetWorkstationIPAddress(const Value: String);
177 procedure SetMode(const Value: TLoginMode);
178 procedure SetMultiDivision(Value: Boolean);
179 procedure SetDuz(const Value: string);
180 procedure SetErrorText(const Value: string);
181 procedure SetPromptDiv(const Value: boolean);
182protected
183 procedure FailedLogin(Sender: TObject); dynamic;
184public
185 constructor Create(AOwner: TComponent); virtual;
186 destructor Destroy; override;
187 property LogInHandle: String read FLogInHandle write SetLogInHandle; //for use by a 2ndary DHCP login OR ESSO login
188 property NTToken: String read FNTToken write SetNTToken;
189 property DivList: TStrings read FDivLst;
190 property OnFailedLogin: TOnLoginFailure read FOnFailedLogin write FOnFailedLogin;
191 property MultiDivision: Boolean read FMultiDivision write SetMultiDivision;
192 property DUZ: string read FDUZ write SetDuz;
193 property ErrorText: string read FErrorText write SetErrorText;
194 property IsProductionAccount: Boolean read FIsProductionAccount write
195 FIsProductionAccount;
196 property DomainName: string read FDomainName write FDomainName;
197published
198 property AccessCode: String read FAccessCode write SetAccessCode;
199 property VerifyCode: String read FVerifyCode write SetVerifyCode;
200 property Mode: TLoginMode read FMode write SetMode;
201 property Division: String read FDivision write SetDivision;
202 property PromptDivision: boolean read FPromptDiv write SetPromptDiv;
203
204end;
205
206{------ TVistaUser ------} //holds 'generic' user attributes {p13}
207TVistaUser = class(TObject)
208private
209 FDUZ: string;
210 FName: string;
211 FStandardName: string;
212 FDivision: String;
213 FVerifyCodeChngd: Boolean;
214 FTitle: string;
215 FServiceSection: string;
216 FLanguage: string;
217 FDtime: string;
218 FVpid: String;
219 procedure SetDivision(const Value: String);
220 procedure SetDUZ(const Value: String);
221 procedure SetName(const Value: String);
222 procedure SetVerifyCodeChngd(const Value: Boolean);
223 procedure SetStandardName(const Value: String);
224 procedure SetTitle(const Value: string);
225 procedure SetDTime(const Value: string);
226 procedure SetLanguage(const Value: string);
227 procedure SetServiceSection(const Value: string);
228public
229 property DUZ: String read FDUZ write SetDUZ;
230 property Name: String read FName write SetName;
231 property StandardName: String read FStandardName write SetStandardName;
232 property Division: String read FDivision write SetDivision;
233 property VerifyCodeChngd: Boolean read FVerifyCodeChngd write SetVerifyCodeChngd;
234 property Title: string read FTitle write SetTitle;
235 property ServiceSection: string read FServiceSection write SetServiceSection;
236 property Language: string read FLanguage write SetLanguage;
237 property DTime: string read FDTime write SetDTime;
238 property Vpid: string read FVpid write FVpid;
239end;
240
241{------ TRPCBroker ------}
242{:This component, when placed on a form, allows design-time and run-time
243 connection to the server by simply toggling the Connected property.
244 Once connected you can access server data.}
245
246TRPCBroker = class(TComponent)
247//private
248private
249 FBrokerVersion: String;
250 FIsBackwardCompatibleConnection: Boolean;
251 FIsNewStyleConnection: Boolean;
252 FOldConnectionOnly: Boolean;
253protected
254 FAccessVerifyCodes: TAccessVerifyCodes;
255 FClearParameters: Boolean;
256 FClearResults: Boolean;
257 FConnected: Boolean;
258 FConnecting: Boolean;
259 FCurrentContext: String;
260 FDebugMode: Boolean;
261 FListenerPort: integer;
262 FParams: TParams;
263 FResults: TStrings;
264 FRemoteProcedure: TRemoteProc;
265 FRpcVersion: TRpcVersion;
266 FServer: TServer;
267 FSocket: integer;
268 FRPCTimeLimit : integer; //for adjusting client RPC duration timeouts
269 FPulse : TTimer; //P6
270 FKernelLogIn : Boolean; //p13
271 FLogIn: TVistaLogIn; //p13
272 FUser: TVistaUser; //p13
273 FOnRPCBFailure: TOnRPCBFailure;
274 FShowErrorMsgs: TShowErrorMsgs;
275 FRPCBError: String;
276 FOnPulseError: TOnPulseError;
277protected
278 procedure SetClearParameters(Value: Boolean); virtual;
279 procedure SetClearResults(Value: Boolean); virtual;
280 procedure SetConnected(Value: Boolean); virtual;
281 procedure SetResults(Value: TStrings); virtual;
282 procedure SetServer(Value: TServer); virtual;
283 procedure SetRPCTimeLimit(Value: integer); virtual; //Screen changes to timeout.
284 procedure DoPulseOnTimer(Sender: TObject); virtual; //p6
285 procedure SetKernelLogIn(const Value: Boolean); virtual;
286// procedure SetLogIn(const Value: TVistaLogIn); virtual;
287 procedure SetUser(const Value: TVistaUser); virtual;
288public
289 XWBWinsock: TObject;
290 property AccessVerifyCodes: TAccessVerifyCodes read FAccessVerifyCodes write FAccessVerifyCodes;
291 property Param: TParams read FParams write FParams;
292 property Socket: integer read FSocket;
293 property RPCTimeLimit : integer read FRPCTimeLimit write SetRPCTimeLimit;
294 destructor Destroy; override;
295 procedure Call; virtual;
296 procedure Loaded; override;
297 procedure lstCall(OutputBuffer: TStrings); virtual;
298 function pchCall: PChar; virtual;
299 function strCall: string; virtual;
300 function CreateContext(strContext: string): boolean; virtual;
301 property CurrentContext: String read FCurrentContext;
302 property User: TVistaUser read FUser write SetUser;
303 property OnRPCBFailure: TOnRPCBFailure read FOnRPCBFailure write FOnRPCBFailure;
304 property RPCBError: String read FRPCBError write FRPCBError;
305 property OnPulseError: TOnPulseError read FOnPulseError write FOnPulseError;
306 property BrokerVersion: String read FBrokerVersion;
307 property IsNewStyleConnection: Boolean read FIsNewStyleConnection;
308published
309 constructor Create(AOwner: TComponent); override;
310 property ClearParameters: boolean read FClearParameters
311 write SetClearParameters;
312 property ClearResults: boolean read FClearResults write SetClearResults;
313 property Connected: boolean read FConnected write SetConnected;
314 property DebugMode: boolean read FDebugMode write FDebugMode default False;
315 property ListenerPort: integer read FListenerPort write FListenerPort;
316 property Results: TStrings read FResults write SetResults;
317 property RemoteProcedure: TRemoteProc read FRemoteProcedure
318 write FRemoteProcedure;
319 property RpcVersion: TRpcVersion read FRpcVersion write FRpcVersion;
320 property Server: TServer read FServer write SetServer;
321 property KernelLogIn: Boolean read FKernelLogIn write SetKernelLogIn;
322 property ShowErrorMsgs: TShowErrorMsgs read FShowErrorMsgs write FShowErrorMsgs default semRaise;
323 property LogIn: TVistaLogIn read FLogIn write FLogin; // SetLogIn;
324 property IsBackwardCompatibleConnection: Boolean read
325 FIsBackwardCompatibleConnection write FIsBackwardCompatibleConnection
326 default True;
327 property OldConnectionOnly: Boolean read FOldConnectionOnly write
328 FOldConnectionOnly;
329 end;
330
331{procedure Register;} //P14 --pack split
332procedure StoreConnection(Broker: TRPCBroker);
333function RemoveConnection(Broker: TRPCBroker): boolean;
334function DisconnectAll(Server: string; ListenerPort: integer): boolean;
335function ExistingSocket(Broker: TRPCBroker): integer;
336procedure AuthenticateUser(ConnectingBroker: TRPCBroker);
337procedure GetBrokerInfo(ConnectedBroker : TRPCBroker); //P6
338function NoSignOnNeeded : Boolean;
339function ProcessExecute(Command: string; cShow: Word): Integer;
340function GetAppHandle(ConnectedBroker : TRPCBroker): String;
341function ShowApplicationAndFocusOK(anApplication: TApplication): boolean;
342
343
344var
345 DebugData: string;
346 BrokerConnections: TStringList; {this list stores all connections by socket number}
347 BrokerAllConnections: TStringList; {this list stores all connections to all of
348 the servers, by an application. It's used in DisconnectAll}
349
350implementation
351
352uses
353 Loginfrm, RpcbErr, SelDiv{p8}, RpcSLogin{p13}, fRPCBErrMsg, Wsockc;
354
355const
356 DEFAULT_PULSE : integer = 81000; //P6 default = 45% of 3 minutes.
357 MINIMUM_TIMEOUT : integer = 14; //P6 shortest allowable timeout in secs.
358 PULSE_PERCENTAGE : integer = 45; //P6 % of timeout for pulse frequency.
359
360{-------------------------- TMult.Create --------------------------
361------------------------------------------------------------------}
362constructor TMult.Create(AOwner: TComponent);
363begin
364 inherited Create(AOwner);
365 FMultiple := TStringList.Create;
366end;
367
368{------------------------- TMult.Destroy --------------------------
369------------------------------------------------------------------}
370destructor TMult.Destroy;
371begin
372 ClearAll;
373 FMultiple.Free;
374 FMultiple := nil;
375 inherited Destroy;
376end;
377
378{-------------------------- TMult.Assign --------------------------
379All of the items from source object are copied one by one into the
380target. So if the source is later destroyed, target object will continue
381to hold the copy of all elements, completely unaffected.
382------------------------------------------------------------------}
383procedure TMult.Assign(Source: TPersistent);
384var
385 I: integer;
386 SourceStrings: TStrings;
387 S: TString;
388 SourceMult: TMult;
389begin
390 ClearAll;
391 if Source is TMult then begin
392 SourceMult := Source as TMult;
393 try
394 for I := 0 to SourceMult.FMultiple.Count - 1 do begin
395 S := TString.Create;
396 S.Str := (SourceMult.FMultiple.Objects[I] as TString).Str;
397 Self.FMultiple.AddObject(SourceMult.FMultiple[I], S);
398 end;
399 except
400 end;
401 end
402
403 else begin
404 SourceStrings := Source as TStrings;
405 for I := 0 to SourceStrings.Count - 1 do
406 Self[IntToStr(I)] := SourceStrings[I];
407 end;
408end;
409
410{------------------------- TMult.ClearAll -------------------------
411One by one, all Mult items are freed.
412------------------------------------------------------------------}
413procedure TMult.ClearAll;
414var
415 I: integer;
416begin
417 for I := 0 to FMultiple.Count - 1 do begin
418 FMultiple.Objects[I].Free;
419 FMultiple.Objects[I] := nil;
420 end;
421 FMultiple.Clear;
422end;
423
424{------------------------- TMult.GetCount -------------------------
425Returns the number of elements in the multiple
426------------------------------------------------------------------}
427function TMult.GetCount: Word;
428begin
429 Result := FMultiple.Count;
430end;
431
432{------------------------- TMult.GetFirst -------------------------
433Returns the subscript of the first element in the multiple
434------------------------------------------------------------------}
435function TMult.GetFirst: string;
436begin
437 if FMultiple.Count > 0 then Result := FMultiple[0]
438 else Result := '';
439end;
440
441{------------------------- TMult.GetLast --------------------------
442Returns the subscript of the last element in the multiple
443------------------------------------------------------------------}
444function TMult.GetLast: string;
445begin
446 if FMultiple.Count > 0 then Result := FMultiple[FMultiple.Count - 1]
447 else Result := '';
448end;
449
450{---------------------- TMult.GetFMultiple ------------------------
451Returns the VALUE of the element whose subscript is passed.
452------------------------------------------------------------------}
453function TMult.GetFMultiple(Index: string): string;
454var
455 S: TString;
456 BrokerComponent,ParamRecord: TComponent;
457 I: integer;
458 strError: string;
459begin
460 try
461 S := TString(FMultiple.Objects[FMultiple.IndexOf(Index)]);
462 except
463 on EListError do begin
464 {build appropriate error message}
465 strError := iff(Self.Name <> '', Self.Name, 'TMult_instance');
466 strError := strError + '[' + Index + ']' + #13#10 + 'is undefined';
467 try
468 ParamRecord := Self.Owner;
469 BrokerComponent := Self.Owner.Owner.Owner;
470 if (ParamRecord is TParamRecord) and (BrokerComponent is TRPCBroker) then begin
471 I := 0;
472 {if there is an easier way to figure out which array element points
473 to this instance of a multiple, use it} // p13
474 while TRPCBroker(BrokerComponent).Param[I] <> ParamRecord do inc(I);
475 strError := '.Param[' + IntToStr(I) + '].' + strError;
476 strError := iff(BrokerComponent.Name <> '', BrokerComponent.Name,
477 'TRPCBroker_instance') + strError;
478 end;
479 except
480 end;
481 raise Exception.Create(strError);
482 end;
483 end;
484 Result := S.Str;
485end;
486
487{---------------------- TMult.SetGetSorted ------------------------
488------------------------------------------------------------------}
489function TMult.GetSorted: boolean;
490begin
491 Result := FMultiple.Sorted;
492end;
493
494{---------------------- TMult.SetFMultiple ------------------------
495Stores a new element in the multiple. FMultiple (TStringList) is the
496structure, which is used to hold the subscript and value pair. Subscript
497is stored as the String, value is stored as an object of the string.
498------------------------------------------------------------------}
499procedure TMult.SetFMultiple(Index: string; Value: string);
500var
501 S: TString;
502 Pos: integer;
503begin
504 Pos := FMultiple.IndexOf(Index); {see if this subscript already exists}
505 if Pos = -1 then begin {if subscript is new}
506 S := TString.Create; {create string object}
507 S.Str := Value; {put value in it}
508 FMultiple.AddObject(Index, S); {add it}
509 end
510 else
511 TString(FMultiple.Objects[Pos]).Str := Value; { otherwise replace the value}
512end;
513
514{---------------------- TMult.SetSorted ------------------------
515------------------------------------------------------------------}
516procedure TMult.SetSorted(Value: boolean);
517begin
518 FMultiple.Sorted := Value;
519end;
520
521{-------------------------- TMult.Order --------------------------
522Returns the subscript string of the next or previous element from the
523StartSubscript. This is very similar to the $O function available in M.
524Null string ('') is returned when reaching beyong the first or last
525element, or when list is empty.
526Note: A major difference between the M $O and this function is that
527 in this function StartSubscript must identify a valid subscript
528 in the list.
529------------------------------------------------------------------}
530function TMult.Order(const StartSubscript: string; Direction: integer): string;
531var
532 Index: longint;
533begin
534 Result := '';
535 if StartSubscript = '' then
536 if Direction > 0 then Result := First
537 else Result := Last
538 else begin
539 Index := Position(StartSubscript);
540 if Index > -1 then
541 if (Index < (Count - 1)) and (Direction > 0) then
542 Result := FMultiple[Index + 1]
543 else if (Index > 0) and (Direction < 0) then
544 Result := FMultiple[Index - 1];
545 end
546end;
547
548{------------------------- TMult.Position -------------------------
549Returns the long integer value which is the index position of the
550element in the list. Opposite of TMult.Subscript(). Remember that
551the list is 0 based!
552------------------------------------------------------------------}
553function TMult.Position(const Subscript: string): longint;
554begin
555 Result := FMultiple.IndexOf(Subscript);
556end;
557
558{------------------------ TMult.Subscript -------------------------
559Returns the string subscript of the element whose position in the list
560is passed in. Opposite of TMult.Position(). Remember that the list is 0 based!
561------------------------------------------------------------------}
562function TMult.Subscript(const Position: longint): string;
563begin
564 Result := '';
565 if (Position > -1) and (Position < Count) then
566 Result := FMultiple[Position];
567end;
568
569{---------------------- TParamRecord.Create -----------------------
570Creates TParamRecord instance and automatically creates TMult. The
571name of Mult is also set in case it may be need if exception will be raised.
572------------------------------------------------------------------}
573constructor TParamRecord.Create(AOwner: TComponent);
574begin
575 inherited Create(AOwner);
576 FMult := TMult.Create(Self);
577 FMult.Name := 'Mult';
578 {note: FMult is destroyed in the SetClearParameters method}
579end;
580
581destructor TParamRecord.Destroy;
582begin
583 FMult.Free;
584 FMult := nil;
585 inherited;
586end;
587
588{------------------------- TParams.Create -------------------------
589------------------------------------------------------------------}
590constructor TParams.Create(AOwner: TComponent);
591begin
592 inherited Create(AOwner);
593 FParameters := TList.Create; {for now, empty list}
594end;
595
596{------------------------ TParams.Destroy -------------------------
597------------------------------------------------------------------}
598destructor TParams.Destroy;
599begin
600 Clear; {clear the Multiple first!}
601 FParameters.Free;
602 FParameters := nil;
603 inherited Destroy;
604end;
605
606{------------------------- TParams.Assign -------------------------
607------------------------------------------------------------------}
608procedure TParams.Assign(Source: TPersistent);
609var
610 I: integer;
611 SourceParams: TParams;
612begin
613 Self.Clear;
614 SourceParams := Source as TParams;
615 for I := 0 to SourceParams.Count - 1 do begin
616 Self[I].Value := SourceParams[I].Value;
617 Self[I].PType := SourceParams[I].PType;
618 Self[I].Mult.Assign(SourceParams[I].Mult);
619 end
620end;
621
622{------------------------- TParams.Clear --------------------------
623------------------------------------------------------------------}
624procedure TParams.Clear;
625var
626 ParamRecord: TParamRecord;
627 I: integer;
628begin
629 if FParameters <> nil then begin
630 for I := 0 to FParameters.Count - 1 do begin
631 ParamRecord := TParamRecord(FParameters.Items[I]);
632 if ParamRecord <> nil then begin //could be nil if params were skipped by developer
633 ParamRecord.FMult.Free;
634 ParamRecord.FMult := nil;
635 ParamRecord.Free;
636 end;
637 end;
638 FParameters.Clear; {release FParameters TList}
639 end;
640end;
641
642{------------------------ TParams.GetCount ------------------------
643------------------------------------------------------------------}
644function TParams.GetCount: Word;
645begin
646 if FParameters = nil then Result := 0
647 else Result := FParameters.Count;
648end;
649
650{---------------------- TParams.GetParameter ----------------------
651------------------------------------------------------------------}
652function TParams.GetParameter(Index: integer): TParamRecord;
653begin
654 if Index >= FParameters.Count then {if element out of bounds,}
655 while FParameters.Count <= Index do
656 FParameters.Add(nil); {setup place holders}
657 if FParameters.Items[Index] = nil then begin {if just a place holder,}
658 {point it to new memory block}
659 FParameters.Items[Index] := TParamRecord.Create(Self);
660 TParamRecord(FParameters.Items[Index]).PType := undefined; {initialize}
661 end;
662 Result := FParameters.Items[Index]; {return requested parameter}
663end;
664
665{---------------------- TParams.SetParameter ----------------------
666------------------------------------------------------------------}
667procedure TParams.SetParameter(Index: integer; Parameter: TParamRecord);
668begin
669 if Index >= FParameters.Count then {if element out of bounds,}
670 while FParameters.Count <= Index do
671 FParameters.Add(nil); {setup place holders}
672 if FParameters.Items[Index] = nil then {if just a place holder,}
673 FParameters.Items[Index] := Parameter; {point it to passed parameter}
674end;
675
676{------------------------ TRPCBroker.Create -----------------------
677------------------------------------------------------------------}
678constructor TRPCBroker.Create(AOwner: TComponent);
679begin
680 inherited Create(AOwner);
681 {set defaults}
682
683// This constant defined in the interface section needs to be updated for each release
684 FBrokerVersion := CURRENT_RPC_VERSION;
685
686 FClearParameters := boolean(StrToInt
687 (ReadRegDataDefault(HKLM,REG_BROKER,'ClearParameters','1')));
688 FClearResults := boolean(StrToInt
689 (ReadRegDataDefault(HKLM,REG_BROKER,'ClearResults','1')));
690 FDebugMode := False;
691 FParams := TParams.Create(Self);
692 FResults := TStringList.Create;
693 FServer := ReadRegDataDefault(HKLM,REG_BROKER,'Server','BROKERSERVER');
694 FPulse := TTimer.Create(Self); //P6
695 FListenerPort := StrToInt
696 (ReadRegDataDefault(HKLM,REG_BROKER,'ListenerPort','9200'));
697 FRpcVersion := '0';
698 FRPCTimeLimit := MIN_RPCTIMELIMIT;
699 with FPulse do ///P6
700 begin
701 Enabled := False; //P6
702 Interval := DEFAULT_PULSE; //P6
703 OnTimer := DoPulseOnTimer; //P6
704 end;
705 FLogin := TVistaLogin.Create(Self); //p13
706 FKernelLogin := True; //p13
707 FUser := TVistaUser.Create; //p13
708 FShowErrorMsgs := semRaise; //p13
709 XWBWinsock := TXWBWinsock.Create;
710
711 FIsBackwardCompatibleConnection := True; // default
712 Application.ProcessMessages;
713end;
714
715{----------------------- TRPCBroker.Destroy -----------------------
716------------------------------------------------------------------}
717destructor TRPCBroker.Destroy;
718begin
719 Connected := False;
720 TXWBWinsock(XWBWinsock).Free;
721 FParams.Free;
722 FParams := nil;
723 FResults.Free;
724 FResults := nil;
725 FPulse.Free; //P6
726 FPulse := nil;
727 FUser.Free;
728 FUser := nil;
729 FLogin.Free;
730 FLogin := nil;
731 inherited Destroy;
732end;
733
734{--------------------- TRPCBroker.CreateContext -------------------
735This function is part of the overall Broker security.
736The passed context string is essentially a Client/Server type option
737on the server. The server sets up MenuMan environment variables for this
738context which will later be used to screen RPCs. Only those RPCs which are
739in the multiple field of this context option will be permitted to run.
740------------------------------------------------------------------}
741function TRPCBroker.CreateContext(strContext: string): boolean;
742var
743 InternalBroker: TRPCBroker; {use separate component}
744 Str: String;
745begin
746 Result := False;
747 Connected := True;
748 InternalBroker := nil;
749 try
750 InternalBroker := TRPCBroker.Create(Self);
751 InternalBroker.FSocket := Self.Socket; // p13 -- permits multiple broker connections to same server/port
752 with InternalBroker do
753 begin
754{
755 TXWBWinsock(InternalBroker.XWBWinsock).IsBackwardsCompatible := TXWBWinsock(Self.XWBWinsock).IsBackwardsCompatible;
756 TXWBWinsock(InternalBroker.XWBWinsock).OriginalConnectionOnly := TXWBWinsock(Self.XWBWinsock).OriginalConnectionOnly;
757}
758 Tag := 1234;
759 ShowErrorMsgs := Self.ShowerrorMsgs;
760 Server := Self.Server; {inherit application server}
761 ListenerPort := Self.ListenerPort; {inherit listener port}
762 DebugMode := Self.DebugMode; {inherit debug mode property}
763 RemoteProcedure := 'XWB CREATE CONTEXT'; {set up RPC}
764 Param[0].PType := literal;
765 Param[0].Value := Encrypt(strContext);
766 try
767 Str := strCall;
768 if Str = '1' then
769 begin // make the call // p13
770 Result := True; // p13
771 self.FCurrentContext := strContext; // p13
772 end // p13
773 else
774 begin
775 Result := False;
776 self.FCurrentContext := '';
777 end;
778 except // Code added to return False if User doesn't have access
779 on e: EBrokerError do
780 begin
781 self.FCurrentContext := '';
782 if Pos('does not have access to option',e.Message) > 0 then
783 begin
784 Result := False
785 end
786 else
787 Raise;
788 end;
789 end;
790 if RPCBError <> '' then
791 self.RPCBError := RPCBError;
792 end;
793 finally
794 InternalBroker.XWBWinsock := nil;
795 InternalBroker.Free; {release memory}
796 end;
797end;
798
799{------------------------ TRPCBroker.Loaded -----------------------
800------------------------------------------------------------------}
801procedure TRPCBroker.Loaded;
802begin
803 inherited Loaded;
804end;
805
806{------------------------- TRPCBroker.Call ------------------------
807------------------------------------------------------------------}
808procedure TRPCBroker.Call;
809var
810 ResultBuffer: TStrings;
811begin
812 ResultBuffer := TStringList.Create;
813 try
814 if ClearResults then ClearResults := True;
815 lstCall(ResultBuffer);
816 Self.Results.AddStrings(ResultBuffer);
817 finally
818 ResultBuffer.Clear;
819 ResultBuffer.Free;
820 end;
821end;
822
823{----------------------- TRPCBroker.lstCall -----------------------
824------------------------------------------------------------------}
825procedure TRPCBroker.lstCall(OutputBuffer: TStrings);
826var
827 ManyStrings: PChar;
828begin
829 ManyStrings := pchCall; {make the call}
830 OutputBuffer.SetText(ManyStrings); {parse result of call, format as list}
831 StrDispose(ManyStrings); {raw result no longer needed, get back mem}
832end;
833
834{----------------------- TRPCBroker.strCall -----------------------
835------------------------------------------------------------------}
836function TRPCBroker.strCall: string;
837var
838 ResultString: PChar;
839begin
840 ResultString := pchCall; {make the call}
841 Result := StrPas(ResultString); {convert and present as Pascal string}
842 StrDispose(ResultString); {raw result no longer needed, get back mem}
843end;
844
845{--------------------- TRPCBroker.SetConnected --------------------
846------------------------------------------------------------------}
847procedure TRPCBroker.SetConnected(Value: Boolean);
848var
849 BrokerDir, Str1, Str2, Str3 :string;
850begin
851 RPCBError := '';
852 Login.ErrorText := '';
853 if (Connected <> Value) and not(csReading in ComponentState) then begin
854 if Value and (FConnecting <> Value) then begin {connect}
855 FSocket := ExistingSocket(Self);
856 FConnecting := True; // FConnected := True;
857 try
858 if FSocket = 0 then
859 begin
860 {Execute Client Agent from directory in Registry.}
861 BrokerDir := ReadRegData(HKLM, REG_BROKER, 'BrokerDr');
862 if BrokerDir <> '' then
863 ProcessExecute(BrokerDir + '\ClAgent.Exe', sw_ShowNoActivate)
864 else
865 ProcessExecute('ClAgent.Exe', sw_ShowNoActivate);
866 if DebugMode and (not OldConnectionOnly) then
867 begin
868 Str1 := 'Control of debugging has been moved from the client to the server. To start a Debug session, do the following:'+#13#10#13#10;
869 Str2 := '1. On the server, set initial breakpoints where desired.'+#13#10+'2. DO DEBUG^XWBTCPM.'+#13#10+'3. Enter a unique Listener port number (i.e., a port number not in general use).'+#13#10;
870 Str3 := '4. Connect the client application using the port number entered in Step #3.';
871 ShowMessage(Str1 + Str2 + Str3);
872 end;
873 TXWBWinsock(XWBWinsock).IsBackwardsCompatible := FIsBackwardCompatibleConnection;
874 TXWBWinsock(XWBWinsock).OldConnectionOnly := FOldConnectionOnly;
875 FSocket := TXWBWinsock(XWBWinsock).NetworkConnect(DebugMode, FServer,
876 ListenerPort, FRPCTimeLimit);
877 AuthenticateUser(Self);
878 FPulse.Enabled := True; //P6 Start heartbeat.
879 StoreConnection(Self); //MUST store connection before CreateContext()
880 CreateContext(''); //Closes XUS SIGNON context.
881 end
882 else
883 begin //p13
884 StoreConnection(Self);
885 FPulse.Enabled := True; //p13
886 end; //p13
887 FConnected := True; // jli mod 12/17/01
888 FConnecting := False;
889 except
890 on E: EBrokerError do begin
891 if E.Code = XWB_BadSignOn then
892 TXWBWinsock(XWBWinsock).NetworkDisconnect(FSocket);
893 FSocket := 0;
894 FConnected := False;
895 FConnecting := False;
896 FRPCBError := E.Message; // p13 handle errors as specified
897 if Login.ErrorText <> '' then
898 FRPCBError := E.Message + chr(10) + Login.ErrorText;
899 if Assigned(FOnRPCBFailure) then // p13
900 FOnRPCBFailure(Self) // p13
901 else if ShowErrorMsgs = semRaise then
902 Raise; // p13
903// raise; {this is where I would do OnNetError}
904 end{on};
905 end{try};
906 end{if}
907 else if not Value then
908 begin //p13
909 FConnected := False; //p13
910 FPulse.Enabled := False; //p13
911 if RemoveConnection(Self) = NoMore then begin
912 {FPulse.Enabled := False; ///P6;p13 }
913 TXWBWinsock(XWBWinsock).NetworkDisconnect(Socket); {actually disconnect from server}
914 FSocket := 0; {store internal}
915 //FConnected := False; //p13
916 end{if};
917 end; {else}
918 end{if};
919end;
920
921{----------------- TRPCBroker.SetClearParameters ------------------
922------------------------------------------------------------------}
923procedure TRPCBroker.SetClearParameters(Value: Boolean);
924begin
925 if Value then FParams.Clear;
926 FClearParameters := Value;
927end;
928
929{------------------- TRPCBroker.SetClearResults -------------------
930------------------------------------------------------------------}
931procedure TRPCBroker.SetClearResults(Value: Boolean);
932begin
933 if Value then begin {if True}
934 FResults.Clear;
935 end;
936 FClearResults := Value;
937end;
938
939{---------------------- TRPCBroker.SetResults ---------------------
940------------------------------------------------------------------}
941procedure TRPCBroker.SetResults(Value: TStrings);
942begin
943 FResults.Assign(Value);
944end;
945
946{----------------------- TRPCBroker.SetRPCTimeLimit -----------------
947------------------------------------------------------------------}
948procedure TRPCBroker.SetRPCTimeLimit(Value: integer);
949begin
950 if Value <> FRPCTimeLimit then
951 if Value > MIN_RPCTIMELIMIT then
952 FRPCTimeLimit := Value
953 else
954 FRPCTimeLimit := MIN_RPCTIMELIMIT;
955end;
956
957{----------------------- TRPCBroker.SetServer ---------------------
958------------------------------------------------------------------}
959procedure TRPCBroker.SetServer(Value: TServer);
960begin
961 {if changing the name of the server, make sure to disconnect first}
962 if (Value <> FServer) and Connected then begin
963 Connected := False;
964 end;
965 FServer := Value;
966end;
967
968{--------------------- TRPCBroker.pchCall ----------------------
969Lowest level remote procedure call that a TRPCBroker component can make.
9701. Returns PChar.
9712. Converts Remote Procedure to PChar internally.
972------------------------------------------------------------------}
973function TRPCBroker.pchCall: PChar;
974var
975 Value, Sec, App: PChar;
976 BrokerError: EBrokerError;
977 blnRestartPulse : boolean; //P6
978begin
979 RPCBError := '';
980 Connected := True;
981 BrokerError := nil;
982 Value := nil;
983 blnRestartPulse := False; //P6
984
985 Sec := StrAlloc(255);
986 App := StrAlloc(255);
987
988 try
989 if FPulse.Enabled then ///P6 If Broker was sending pulse,
990 begin
991 FPulse.Enabled := False; /// Stop pulse &
992 blnRestartPulse := True; // Set flag to restart pulse after RPC.
993 end;
994{
995 if Assigned(FOnRPCCall) then
996 begin
997 FOnRPCCall(Self, 1, RemoteProcedure, CurrentContext, RpcVersion, Param, FRPCTimeLimit, '', '', '', Now);
998 end;
999}
1000 try
1001 Value := TXWBWinsock(XWBWinsock).tCall(Socket, RemoteProcedure, RpcVersion, Param,
1002 Sec, App,FRPCTimeLimit);
1003{
1004 if Assigned(FOnRPCCall) then
1005 begin
1006 FOnRPCCall(Self, 2, RemoteProcedure, CurrentContext, RpcVersion, Param, FRPCTimeLimit, Result, Sec, App, Now);
1007 end;
1008}
1009 if (StrLen(Sec) > 0) then
1010 begin
1011 BrokerError := EBrokerError.Create(StrPas(Sec));
1012 BrokerError.Code := 0;
1013 BrokerError.Action := 'Error Returned';
1014 end;
1015 except
1016 on Etemp: EBrokerError do
1017 with Etemp do
1018 begin //save copy of error
1019 BrokerError := EBrokerError.Create(message); //field by field
1020 BrokerError.Action := Action;
1021 BrokerError.Code := Code;
1022 BrokerError.Mnemonic := Mnemonic;
1023 if Value <> nil then
1024 StrDispose(Value);
1025 Value := StrNew('');
1026 {if severe error, mark connection as closed. Per Enrique, we should
1027 replace this check with some function, yet to be developed, which
1028 will test the link.}
1029 if ((Code >= 10050)and(Code <=10058))or(Action = 'connection lost') then
1030 begin
1031 Connected := False;
1032 blnRestartPulse := False; //P6
1033 end;
1034 end;
1035 end;
1036 finally
1037 StrDispose(Sec); {do something with these}
1038 Sec := nil;
1039 StrDispose(App);
1040 App := nil;
1041 if ClearParameters then ClearParameters := True; //prepare for next call
1042 end;
1043 Result := Value;
1044 if Result = nil then Result := StrNew(''); //return empty string
1045 if blnRestartPulse then FPulse.Enabled := True; //Restart pulse. (P6)
1046 if BrokerError <> nil then
1047 begin
1048 FRPCBError := BrokerError.Message; // p13 handle errors as specified
1049 if Login.ErrorText <> '' then
1050 FRPCBError := BrokerError.Message + chr(10) + Login.ErrorText;
1051 if Assigned(FOnRPCBFailure) then // p13
1052 begin
1053 FOnRPCBFailure(Self);
1054 StrDispose(Result);
1055 end
1056 else if FShowErrorMsgs = semRaise then
1057 begin
1058 StrDispose(Result); // return memory we won't use - caused a memory leak
1059 Raise BrokerError; // p13
1060 end
1061 else // silent, just return error message in FRPCBError
1062 BrokerError.Free; // return memory in BrokerError - otherwise is a memory leak
1063// raise; {this is where I would do OnNetError}
1064 end; // if BrokerError <> nil
1065end;
1066
1067
1068{-------------------------- DisconnectAll -------------------------
1069Find all connections in BrokerAllConnections list for the passed in
1070server:listenerport combination and disconnect them. If at least one
1071connection to the server:listenerport is found, then it and all other
1072Brokers to the same server:listenerport will be disconnected; True
1073will be returned. Otherwise False will return.
1074------------------------------------------------------------------}
1075function DisconnectAll(Server: string; ListenerPort: integer): boolean;
1076var
1077 Index: integer;
1078begin
1079 Result := False;
1080 while (Assigned(BrokerAllConnections) and
1081 (BrokerAllConnections.Find(Server + ':' + IntToStr(ListenerPort), Index))) do begin
1082 Result := True;
1083 TRPCBroker(BrokerAllConnections.Objects[Index]).Connected := False;
1084 {if the call above disconnected the last connection in the list, then
1085 the whole list will be destroyed, making it necessary to check if it's
1086 still assigned.}
1087 end;
1088end;
1089
1090{------------------------- StoreConnection ------------------------
1091Each broker connection is stored in BrokerConnections list.
1092------------------------------------------------------------------}
1093procedure StoreConnection(Broker: TRPCBroker);
1094begin
1095 if BrokerConnections = nil then {list is created when 1st entry is added}
1096 try
1097 BrokerConnections := TStringList.Create;
1098 BrokerConnections.Sorted := True;
1099 BrokerConnections.Duplicates := dupAccept; {store every connection}
1100 BrokerAllConnections := TStringList.Create;
1101 BrokerAllConnections.Sorted := True;
1102 BrokerAllConnections.Duplicates := dupAccept;
1103 except
1104 TXWBWinsock(Broker.XWBWinsock).NetError('store connection',XWB_BldConnectList)
1105 end;
1106 BrokerAllConnections.AddObject(Broker.Server + ':' +
1107 IntToStr(Broker.ListenerPort), Broker);
1108 BrokerConnections.AddObject(IntToStr(Broker.Socket), Broker);
1109end;
1110
1111{------------------------ RemoveConnection ------------------------
1112Result of this function will be False, if there are no more connections
1113to the same server:listenerport as the passed in Broker. If at least
1114one other connection is found to the same server:listenerport, then Result
1115will be True.
1116------------------------------------------------------------------}
1117function RemoveConnection(Broker: TRPCBroker): boolean;
1118var
1119 Index: integer;
1120begin
1121 Result := False;
1122 if Assigned(BrokerConnections) then begin
1123 {remove connection record of passed in Broker component}
1124 BrokerConnections.Delete(BrokerConnections.IndexOfObject(Broker));
1125 {look for one other connection to the same server:port}
1126// Result := BrokerConnections.Find(Broker.Server + ':' + IntToStr(Broker.ListenerPort), Index);
1127 Result := BrokerConnections.Find(IntToStr(Broker.Socket), Index);
1128 if BrokerConnections.Count = 0 then begin {if last entry removed,}
1129 BrokerConnections.Free; {destroy whole list structure}
1130 BrokerConnections := nil;
1131 end;
1132 end; // if Assigned(BrokerConnections)
1133 if Assigned(BrokerAllConnections) then begin
1134 BrokerAllConnections.Delete(BrokerAllConnections.IndexOfObject(Broker));
1135 if BrokerAllConnections.Count = 0 then begin
1136 BrokerAllConnections.Free;
1137 BrokerAllConnections := nil;
1138 end;
1139 end; // if Assigned(BrokerAllConnections)
1140end;
1141
1142{------------------------- ExistingSocket -------------------------
1143------------------------------------------------------------------}
1144function ExistingSocket(Broker: TRPCBroker): integer;
1145// var
1146// Index: integer;
1147begin
1148 Result := Broker.Socket;
1149{ Result := 0; // p13 to permit multiple Broker connections
1150
1151 if Assigned(BrokerConnections) and
1152 BrokerConnections.Find(Broker.Server + ':' + IntToStr(Broker.ListenerPort), Index) then
1153 Result := TRPCBroker(BrokerConnections.Objects[Index]).Socket;
1154}
1155end;
1156
1157{------------------------ AuthenticateUser ------------------------
1158------------------------------------------------------------------}
1159procedure AuthenticateUser(ConnectingBroker: TRPCBroker);
1160var
1161 SaveClearParmeters, SaveClearResults: boolean;
1162 SaveParam: TParams;
1163 SaveRemoteProcedure, SaveRpcVersion: string;
1164 SaveResults: TStrings;
1165 blnSignedOn: boolean;
1166 SaveKernelLogin: boolean;
1167 SaveVistaLogin: TVistaLogin;
1168 OldExceptionHandler: TExceptionEvent;
1169 OldHandle: THandle;
1170begin
1171 With ConnectingBroker do
1172 begin
1173 SaveParam := TParams.Create(nil);
1174 SaveParam.Assign(Param); //save off settings
1175 SaveRemoteProcedure := RemoteProcedure;
1176 SaveRpcVersion := RpcVersion;
1177 SaveResults := Results;
1178 SaveClearParmeters := ClearParameters;
1179 SaveClearResults := ClearResults;
1180 ClearParameters := True; //set'em as I need'em
1181 ClearResults := True;
1182 SaveKernelLogin := FKernelLogin; // p13
1183 SaveVistaLogin := FLogin; // p13
1184 end;
1185
1186 blnSignedOn := False; //initialize to bad sign-on
1187
1188 if ConnectingBroker.AccessVerifyCodes <> '' then // p13 handle as AVCode single signon
1189 begin
1190 ConnectingBroker.Login.AccessCode := Piece(ConnectingBroker.AccessVerifyCodes, ';', 1);
1191 ConnectingBroker.Login.VerifyCode := Piece(ConnectingBroker.AccessVerifyCodes, ';', 2);
1192 ConnectingBroker.Login.Mode := lmAVCodes;
1193 ConnectingBroker.FKernelLogIn := False;
1194 end;
1195
1196 if ConnectingBroker.FKernelLogIn then
1197 begin //p13
1198 if Assigned(Application.OnException) then
1199 OldExceptionHandler := Application.OnException
1200 else
1201 OldExceptionHandler := nil;
1202 Application.OnException := TfrmErrMsg.RPCBShowException;
1203 frmSignon := TfrmSignon.Create(Application);
1204 try
1205
1206 // ShowApplicationAndFocusOK(Application);
1207 OldHandle := GetForegroundWindow;
1208 SetForegroundWindow(frmSignon.Handle);
1209 PrepareSignonForm(ConnectingBroker);
1210 if SetUpSignOn then //SetUpSignOn in loginfrm unit.
1211 begin //True if signon needed
1212 { // p13 handle as AVCode single signon
1213 if ConnectingBroker.AccessVerifyCodes <> '' then
1214 begin {do non interactive logon
1215 frmSignon.accessCode.Text := Piece(ConnectingBroker.AccessVerifyCodes, ';', 1);
1216 frmSignon.verifyCode.Text := Piece(ConnectingBroker.AccessVerifyCodes, ';', 2);
1217 //Application.ProcessMessages;
1218 frmSignon.btnOk.Click;
1219 end
1220 else frmSignOn.ShowModal; //do interactive logon
1221 }
1222 // ShowApplicationAndFocusOK(Application);
1223 // SetForegroundWindow(frmSignOn.Handle);
1224 if frmSignOn.lblServer.Caption <> '' then
1225 begin
1226 frmSignOn.ShowModal; //do interactive logon // p13
1227 if frmSignOn.Tag = 1 then //Tag=1 for good logon
1228 blnSignedOn := True; //Successfull logon
1229 end
1230 end
1231 else //False when no logon needed
1232 blnSignedOn := NoSignOnNeeded; //Returns True always (for now!)
1233 if blnSignedOn then //P6 If logged on, retrieve user info.
1234 begin
1235 GetBrokerInfo(ConnectingBroker);
1236 if not SelDiv.ChooseDiv('',ConnectingBroker) then
1237 begin
1238 blnSignedOn := False;//P8
1239 {Select division if multi-division user. First parameter is 'userid'
1240 (DUZ or username) for future use. (P8)}
1241 ConnectingBroker.Login.ErrorText := 'Failed to select Division'; // p13 set some text indicating problem
1242 end;
1243 end;
1244 SetForegroundWindow(OldHandle);
1245 finally
1246 frmSignon.Free;
1247// frmSignon.Release; //get rid of signon form
1248
1249// if ConnectingBroker.Owner is TForm then
1250// SetForegroundWindow(TForm(ConnectingBroker.Owner).Handle)
1251// else
1252// SetForegroundWindow(ActiveWindow);
1253 ShowApplicationAndFocusOK(Application);
1254 end ; //try
1255 if Assigned(OldExceptionHandler) then
1256 Application.OnException := OldExceptionHandler;
1257 end; //if kernellogin
1258 // p13 following section for silent signon
1259 if not ConnectingBroker.FKernelLogIn then
1260 if ConnectingBroker.FLogin <> nil then //the user. vistalogin contains login info
1261 blnsignedon := SilentLogin(ConnectingBroker); // RpcSLogin unit
1262 if not blnsignedon then
1263 begin
1264 ConnectingBroker.FLogin.FailedLogin(ConnectingBroker.FLogin);
1265 TXWBWinsock(ConnectingBroker.XWBWinsock).NetworkDisconnect(ConnectingBroker.FSocket);
1266 end
1267 else
1268 GetBrokerInfo(ConnectingBroker);
1269
1270 //reset the Broker
1271 with ConnectingBroker do
1272 begin
1273 ClearParameters := SaveClearParmeters;
1274 ClearResults := SaveClearResults;
1275 Param.Assign(SaveParam); //restore settings
1276 SaveParam.Free;
1277 RemoteProcedure := SaveRemoteProcedure;
1278 RpcVersion := SaveRpcVersion;
1279 Results := SaveResults;
1280 FKernelLogin := SaveKernelLogin; // p13
1281 FLogin := SaveVistaLogin; // p13
1282 end;
1283
1284 if not blnSignedOn then //Flag for unsuccessful signon.
1285 TXWBWinsock(ConnectingBroker.XWBWinsock).NetError('',XWB_BadSignOn); //Will raise error.
1286
1287end;
1288
1289{------------------------ GetBrokerInfo ------------------------
1290P6 Retrieve information about user with XWB GET BROKER INFO
1291 RPC. For now, only Timeout value is retrieved in Results[0].
1292------------------------------------------------------------------}
1293procedure GetBrokerInfo(ConnectedBroker: TRPCBroker);
1294begin
1295 GetUserInfo(ConnectedBroker); // p13 Get User info into User property (TVistaUser object)
1296 With ConnectedBroker do //(dcm) Use one of objects below
1297 begin // and skip this RPC? or make this and
1298 RemoteProcedure := 'XWB GET BROKER INFO'; // others below as components
1299 try
1300 Call;
1301 if Results.Count > 0 then
1302 if StrToInt(Results[0]) > MINIMUM_TIMEOUT then
1303 FPulse.Interval := (StrToInt(Results[0]) * 10 * PULSE_PERCENTAGE);
1304 except
1305 On e: EBrokerError do
1306 ShowMessage('A problem was encountered getting Broker information. '+e.Message); //TODO
1307 end;
1308 end;
1309end;
1310
1311{------------------------ NoSignOnNeeded ------------------------
1312------------------------------------------------------------------}
1313{Currently a placeholder for actions that may be needed in connection
1314with authenticating a user who needn't sign on (Single Sign on feature).
1315Returns True if no signon is needed
1316 False if signon is needed.}
1317function NoSignOnNeeded : Boolean;
1318begin
1319 Result := True;
1320end;
1321
1322{------------------------- ProcessExecute -------------------------
1323This function is borrowed from "Delphi 2 Developer's Guide" by Pacheco & Teixera.
1324See chapter 11, page 406. It encapsulates and simplifies use of
1325Windows CreateProcess function.
1326------------------------------------------------------------------}
1327function ProcessExecute(Command: string; cShow: Word): Integer;
1328{ This method encapsulates the call to CreateProcess() which creates
1329 a new process and its primary thread. This is the method used in
1330 Win32 to execute another application, This method requires the use
1331 of the TStartInfo and TProcessInformation structures. These structures
1332 are not documented as part of the Delphi 2.0 online help but rather
1333 the Win32 help as STARTUPINFO and PROCESS_INFORMATION.
1334
1335 The CommandLine paremeter specifies the pathname of the file to
1336 execute.
1337
1338 The cShow paremeter specifies one of the SW_XXXX constants which
1339 specifies how to display the window. This value is assigned to the
1340 sShowWindow field of the TStartupInfo structure. }
1341var
1342 Rslt: LongBool;
1343 StartUpInfo: TStartUpInfo; // documented as STARTUPINFO
1344 ProcessInfo: TProcessInformation; // documented as PROCESS_INFORMATION
1345begin
1346 { Clear the StartupInfo structure }
1347 FillChar(StartupInfo, SizeOf(TStartupInfo), 0);
1348 { Initialize the StartupInfo structure with required data.
1349 Here, we assign the SW_XXXX constant to the wShowWindow field
1350 of StartupInfo. When specifing a value to this field the
1351 STARTF_USESSHOWWINDOW flag must be set in the dwFlags field.
1352 Additional information on the TStartupInfo is provided in the Win32
1353 online help under STARTUPINFO. }
1354 with StartupInfo do begin
1355 cb := SizeOf(TStartupInfo); // Specify size of structure
1356 dwFlags := STARTF_USESHOWWINDOW or STARTF_FORCEONFEEDBACK;
1357 wShowWindow := cShow
1358 end;
1359
1360 { Create the process by calling CreateProcess(). This function
1361 fills the ProcessInfo structure with information about the new
1362 process and its primary thread. Detailed information is provided
1363 in the Win32 online help for the TProcessInfo structure under
1364 PROCESS_INFORMATION. }
1365 Rslt := CreateProcess(PChar(Command), nil, nil, nil, False,
1366 NORMAL_PRIORITY_CLASS, nil, nil, StartupInfo, ProcessInfo);
1367 { If Rslt is true, then the CreateProcess call was successful.
1368 Otherwise, GetLastError will return an error code representing the
1369 error which occurred. }
1370 if Rslt then
1371 with ProcessInfo do begin
1372 { Wait until the process is in idle. }
1373 WaitForInputIdle(hProcess, INFINITE);
1374 CloseHandle(hThread); // Free the hThread handle
1375 CloseHandle(hProcess);// Free the hProcess handle
1376 Result := 0; // Set Result to 0, meaning successful
1377 end
1378 else Result := GetLastError; // Set result to the error code.
1379end;
1380
1381
1382{----------------------- GetAppHandle --------------------------
1383Library function to return an Application Handle from the server
1384which can be passed as a command line argument to an application
1385the current application is starting. The new application can use
1386this AppHandle to perform a silent login via the lmAppHandle mode
1387----------------------------------------------------------------}
1388function GetAppHandle(ConnectedBroker : TRPCBroker): String; // p13
1389begin
1390 Result := '';
1391 with ConnectedBroker do
1392 begin
1393 RemoteProcedure := 'XUS GET TOKEN';
1394 Call;
1395 Result := Results[0];
1396 end;
1397end;
1398
1399{----------------------- TRPCBroker.DoPulseOnTimer-----------------
1400Called from the OnTimer event of the Pulse property.
1401Broker environment should be the same after the procedure as before.
1402Note: Results is not changed by strCall; so, Results needn't be saved.
1403------------------------------------------------------------------}
1404procedure TRPCBroker.DoPulseOnTimer(Sender: TObject); //P6
1405var
1406 SaveClearParameters : Boolean;
1407 SaveParam : TParams;
1408 SaveRemoteProcedure, SaveRPCVersion : string;
1409begin
1410 SaveClearParameters := ClearParameters; //Save existing properties
1411 SaveParam := TParams.Create(nil);
1412 SaveParam.Assign(Param);
1413 SaveRemoteProcedure := RemoteProcedure;
1414 SaveRPCVersion := RPCVersion;
1415 RemoteProcedure := 'XWB IM HERE'; //Set Properties for IM HERE
1416 ClearParameters := True; //Erase existing PARAMs
1417 RPCVersion := '1.106';
1418 try
1419 try
1420 strCall; //Make the call
1421 except on e: EBrokerError do
1422 begin
1423// Connected := False; // set the connection as disconnected
1424 if Assigned(FOnPulseError) then
1425 FOnPulseError(Self, e.Message)
1426 else
1427 raise e;
1428 end;
1429 end;
1430 finally
1431 ClearParameters := SaveClearParameters; //Restore pre-existing properties.
1432 Param.Assign(SaveParam);
1433 SaveParam.Free;
1434 RemoteProcedure := SaveRemoteProcedure;
1435 RPCVersion := SaveRPCVersion;
1436 end;
1437
1438end;
1439
1440procedure TRPCBroker.SetKernelLogIn(const Value: Boolean); // p13
1441begin
1442 FKernelLogIn := Value;
1443end;
1444{
1445procedure TRPCBroker.SetLogIn(const Value: TVistaLogIn); // p13
1446begin
1447 FLogIn := Value;
1448end;
1449}
1450procedure TRPCBroker.SetUser(const Value: TVistaUser); // p13
1451begin
1452 FUser := Value;
1453end;
1454
1455
1456{*****TVistaLogin***** p13}
1457
1458constructor TVistaLogin.Create(AOwner: TComponent); // p13
1459begin
1460 inherited create;
1461 FDivLst := TStringList.Create;
1462end;
1463
1464destructor TVistaLogin.Destroy; // p13
1465begin
1466 FDivLst.Free;
1467 FDivLst := nil;
1468 inherited;
1469end;
1470
1471procedure TVistaLogin.FailedLogin(Sender: TObject); // p13
1472begin
1473 if Assigned(FOnFailedLogin) then FOnFailedLogin(Self)
1474 else TXWBWinsock(TRPCBroker(Sender).XWBWinsock).NetError('',XWB_BadSignOn);
1475end;
1476
1477procedure TVistaLogin.SetAccessCode(const Value: String); // p13
1478begin
1479 FAccessCode := Value;
1480end;
1481
1482procedure TVistaLogin.SetDivision(const Value: String); // p13
1483begin
1484 FDivision := Value;
1485end;
1486
1487procedure TVistaLogin.SetDuz(const Value: string); // p13
1488begin
1489 FDUZ := Value;
1490end;
1491
1492procedure TVistaLogin.SetErrorText(const Value: string); // p13
1493begin
1494 FErrorText := Value;
1495end;
1496
1497procedure TVistaLogin.SetLogInHandle(const Value: String); // p13
1498begin
1499 FLogInHandle := Value;
1500end;
1501
1502procedure TVistaLogin.SetMode(const Value: TLoginMode); // p13
1503begin
1504 FMode := Value;
1505end;
1506
1507procedure TVistaLogin.SetMultiDivision(Value: Boolean); // p13
1508begin
1509 FMultiDivision := Value;
1510end;
1511
1512procedure TVistaLogin.SetNTToken(const Value: String); // p13
1513begin
1514end;
1515
1516procedure TVistaLogin.SetPromptDiv(const Value: boolean); // p13
1517begin
1518 FPromptDiv := Value;
1519end;
1520
1521procedure TVistaLogin.SetVerifyCode(const Value: String); // p13
1522begin
1523 FVerifyCode := Value;
1524end;
1525
1526{***** TVistaUser ***** p13 }
1527
1528procedure TVistaUser.SetDivision(const Value: String); // p13
1529begin
1530 FDivision := Value;
1531end;
1532
1533procedure TVistaUser.SetDTime(const Value: string); // p13
1534begin
1535 FDTime := Value;
1536end;
1537
1538procedure TVistaUser.SetDUZ(const Value: String); // p13
1539begin
1540 FDUZ := Value;
1541end;
1542
1543procedure TVistaUser.SetLanguage(const Value: string); // p13
1544begin
1545 FLanguage := Value;
1546end;
1547
1548procedure TVistaUser.SetName(const Value: String); // p13
1549begin
1550 FName := Value;
1551end;
1552
1553procedure TVistaUser.SetServiceSection(const Value: string); // p13
1554begin
1555 FServiceSection := Value;
1556end;
1557
1558procedure TVistaUser.SetStandardName(const Value: String); // p13
1559begin
1560 FStandardName := Value;
1561end;
1562
1563procedure TVistaUser.SetTitle(const Value: string); // p13
1564begin
1565 FTitle := Value;
1566end;
1567
1568procedure TVistaUser.SetVerifyCodeChngd(const Value: Boolean); // p13
1569begin
1570 FVerifyCodeChngd := Value;
1571end;
1572
1573Function ShowApplicationAndFocusOK(anApplication: TApplication): boolean;
1574var
1575 j: integer;
1576 Stat2: set of (sWinVisForm,sWinVisApp,sIconized);
1577 hFGWnd: THandle;
1578begin
1579 Stat2 := []; {sWinVisForm,sWinVisApp,sIconized}
1580
1581 If anApplication.MainForm <> nil then
1582 If IsWindowVisible(anApplication.MainForm.Handle)
1583 then Stat2 := Stat2 + [sWinVisForm];
1584
1585 If IsWindowVisible(anApplication.Handle)
1586 then Stat2 := Stat2 + [sWinVisApp];
1587
1588 If IsIconic(anApplication.Handle)
1589 then Stat2 := Stat2 + [sIconized];
1590
1591 Result := true;
1592 If sIconized in Stat2 then begin {A}
1593 j := SendMessage(anApplication.Handle,WM_SYSCOMMAND,SC_RESTORE,0);
1594 Result := j<>0;
1595 end;
1596 If Stat2 * [sWinVisForm,sIconized] = [] then begin {S}
1597 if anApplication.MainForm <> nil then
1598 anApplication.MainForm.Show;
1599 end;
1600 If (Stat2 * [sWinVisForm,sIconized] <> []) or
1601 (sWinVisApp in Stat2) then begin {G}
1602{$IFNDEF D6_OR_HIGHER}
1603 hFGWnd := GetForegroundWindow;
1604 try
1605 AttachThreadInput(
1606 GetWindowThreadProcessId(hFGWnd, nil),
1607 GetCurrentThreadId,True);
1608 Result := SetForegroundWindow(anApplication.Handle);
1609 finally
1610 AttachThreadInput(
1611 GetWindowThreadProcessId(hFGWnd, nil),
1612 GetCurrentThreadId, False);
1613 end;
1614{$ENDIF}
1615 end;
1616end;
1617
1618end.
1619
Note: See TracBrowser for help on using the repository browser.