source: cprs/branches/HealthSevak-CPRS/BDK50/BDK32_P50/Source/Trpcb.pas

Last change on this file was 1691, checked in by healthsevak, 10 years ago

Committing the files for first time to this new branch
File size: 76.7 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 47 (Jun. 17, 2008))
8*************************************************************** }
9
10{*
11 Adding use of SSH tunneling as command line option (or property)
12 It appears that tunneling with Attachmate Reflection will be
13 used within the VA. However, code for the use of Plink.exe
14 for ssh tunneling is also provided to permit secure connections
15 for those using VistA outside of the VA.
16
17 for SSH Tunneling using Attachmate Reflection
18 SSH set as commandline option or as a property
19 (set to Attachmate Reflection) will
20 also be set to true if either of the following
21 command line parameters are set.
22 SSHPort=portnumber to specify a particular port number
23 if not specified, it will use the port
24 number for the remote server.
25 SSHUser=username for remote server
26 if not specified, user will be prompted
27
28
29
30 for SSH tunneling with Plink.exe
31 UsePlink set as command line option or as a property
32 (set to Plink).
33 SSHPort=portnumber
34*}
35
36{**************************************************
37This is the hierarchy of things:
38 TRPCBroker contains
39 TParams, which contains
40 array of TParamRecord each of which contains
41 TMult
42
43v1.1*4 Silent Login changes (DCM) 10/22/98
44
451.1*6 Polling to support terminating arphaned server jobs. (P6)
46 == DPC 4/99
47
481.1*8 Check for Multi-Division users. (P8) - REM 7/13/99
49
501.1*13 More silent login code; deleted obsolete lines (DCM) 9/10/99 // p13
51LAST UPDATED: 5/24/2001 // p13 JLI
52
531.1*31 Added new read only property BrokerVersion to TRPCBroker which
54 should contain the version number for the RPCBroker
55 (or SharedRPCBroker) in use.
56**************************************************}
57unit Trpcb;
58
59interface
60
61{$I IISBase.inc}
62
63uses
64 {Delphi standard}
65 Classes, Controls, Dialogs, {DsgnIntf,} Forms, Graphics, Messages, SysUtils,
66 WinProcs, WinTypes, Windows,
67 extctrls, {P6}
68 {VA}
69 XWBut1, {RpcbEdtr,} MFunStr, Hash, //; //P14 -- pack split
70 ComObj, ActiveX, OleCtrls, VERGENCECONTEXTORLib_TLB;
71
72const
73 NoMore: boolean = False;
74 MIN_RPCTIMELIMIT: integer = 30;
75 CURRENT_RPC_VERSION: String = 'XWB*1.1*50';
76
77type
78
79TParamType = (literal, reference, list, global, empty, stream, undefined); // 030107 JLI Modified for new message protocol
80
81//P14 -- pack split -- Types moved from RpcbEdtr.pas.
82TAccessVerifyCodes = string[255]; //to use TAccessVerifyCodesProperty editor use this type
83TRemoteProc = string[100]; //to use TRemoteProcProperty editor use this type
84TServer = string[255]; //to use TServerProperty editor use this type
85TRpcVersion = string[255]; //to use TRpcVersionProperty editor use this type
86
87TRPCBroker = class;
88TVistaLogin = class;
89// p13
90TLoginMode = (lmAVCodes, lmAppHandle, lmNTToken);
91TShowErrorMsgs = (semRaise, semQuiet); // p13
92TOnLoginFailure = procedure (VistaLogin: TVistaLogin) of object; //p13
93TOnRPCBFailure = procedure (RPCBroker: TRPCBroker) of object; //p13
94TOnPulseError = procedure(RPCBroker: TRPCBroker; ErrorText: String) of object;
95// TOnRPCCall = procedure (RPCBroker: TRPCBroker; SetNum: Integer; RemoteProcedure: TRemoteProc; CurrentContext: String; RpcVersion: TRpcVersion; Param: TParams; RPCTimeLimit: Integer; Results, Sec, App: PChar; DateTime: TDateTime) of object;
96TSecure = (secureNone, secureAttachmate, securePlink);
97
98{------ EBrokerError ------}
99EBrokerError = class(Exception)
100public
101 Action: string;
102 Code: integer;
103 Mnemonic: string;
104end;
105
106{------ TString ------}
107
108TString = class(TObject)
109 Str: string;
110end;
111
112{------ TMult ------}
113{:This component defines the multiple field of a parameter. The multiple
114 field is used to pass string-subscripted array of data in a parameter.}
115
116TMult = class(TComponent)
117private
118 FMultiple: TStringList;
119 procedure ClearAll;
120 function GetCount: Word;
121 function GetFirst: string;
122 function GetLast: string;
123 function GetFMultiple(Index: string): string;
124 function GetSorted: boolean;
125 procedure SetFMultiple(Index: string; value: string);
126 procedure SetSorted(Value: boolean);
127protected
128public
129 constructor Create(AOwner: TComponent); override; {1.1T8}
130 destructor Destroy; override;
131 procedure Assign(Source: TPersistent); override;
132 function Order(const StartSubscript: string; Direction: integer): string;
133 function Position(const Subscript: string): longint;
134 function Subscript(const Position: longint): string;
135 property Count: Word read GetCount;
136 property First: string read GetFirst;
137 property Last: string read GetLast;
138 property MultArray[I: string]: string
139 read GetFMultiple write SetFMultiple; default;
140 property Sorted: boolean read GetSorted write SetSorted;
141end;
142
143{------ TParamRecord ------}
144{:This component defines all the fields that comprise a parameter.}
145
146TParamRecord = class(TComponent)
147private
148 FMult: TMult;
149 FValue: string;
150 FPType: TParamType;
151protected
152public
153 constructor Create(AOwner: TComponent); override;
154 destructor Destroy; override;
155 property Value: string read FValue write FValue;
156 property PType: TParamType read FPType write FPType;
157 property Mult: TMult read FMult write FMult;
158end;
159
160{------ TParams ------}
161{:This component is really a collection of parameters. Simple inclusion
162 of this component in the Broker component provides access to all of the
163 parameters that may be needed when calling a remote procedure.}
164
165TParams = class(TComponent)
166private
167 FParameters: TList;
168 function GetCount: Word;
169 function GetParameter(Index: integer): TParamRecord;
170 procedure SetParameter(Index: integer; Parameter: TParamRecord);
171public
172 constructor Create(AOwner: TComponent); override;
173 destructor Destroy; override;
174 procedure Assign(Source: TPersistent); override;
175 procedure Clear;
176 property Count: Word read GetCount;
177 property ParamArray[I: integer]: TParamRecord
178 read GetParameter write SetParameter; default;
179end;
180
181
182{------ TVistaLogin ------} //p13
183TVistaLogin = class(TPersistent)
184private
185 FLogInHandle : string;
186 FNTToken : string;
187 FAccessCode : string;
188 FVerifyCode : string;
189 FDivision : string;
190 FMode: TLoginMode;
191 FDivLst: TStrings;
192 FOnFailedLogin: TOnLoginFailure;
193 FMultiDivision : boolean;
194 FDUZ: string;
195 FErrorText : string;
196 FPromptDiv : boolean;
197 FIsProductionAccount: Boolean;
198 FDomainName: string;
199 procedure SetAccessCode(const Value: String);
200 procedure SetLogInHandle(const Value: String);
201 procedure SetNTToken(const Value: String);
202 procedure SetVerifyCode(const Value: String);
203 procedure SetDivision(const Value: String);
204 //procedure SetWorkstationIPAddress(const Value: String);
205 procedure SetMode(const Value: TLoginMode);
206 procedure SetMultiDivision(Value: Boolean);
207 procedure SetDuz(const Value: string);
208 procedure SetErrorText(const Value: string);
209 procedure SetPromptDiv(const Value: boolean);
210protected
211 procedure FailedLogin(Sender: TObject); dynamic;
212public
213 constructor Create(AOwner: TComponent); virtual;
214 destructor Destroy; override;
215 property LogInHandle: String read FLogInHandle write SetLogInHandle; //for use by a 2ndary DHCP login OR ESSO login
216 property NTToken: String read FNTToken write SetNTToken;
217 property DivList: TStrings read FDivLst;
218 property OnFailedLogin: TOnLoginFailure read FOnFailedLogin write FOnFailedLogin;
219 property MultiDivision: Boolean read FMultiDivision write SetMultiDivision;
220 property DUZ: string read FDUZ write SetDuz;
221 property ErrorText: string read FErrorText write SetErrorText;
222 property IsProductionAccount: Boolean read FIsProductionAccount write
223 FIsProductionAccount;
224 property DomainName: string read FDomainName write FDomainName;
225published
226 property AccessCode: String read FAccessCode write SetAccessCode;
227 property VerifyCode: String read FVerifyCode write SetVerifyCode;
228 property Mode: TLoginMode read FMode write SetMode;
229 property Division: String read FDivision write SetDivision;
230 property PromptDivision: boolean read FPromptDiv write SetPromptDiv;
231
232end;
233
234{------ TVistaUser ------} //holds 'generic' user attributes {p13}
235TVistaUser = class(TObject)
236private
237 FDUZ: string;
238 FName: string;
239 FStandardName: string;
240 FDivision: String;
241 FVerifyCodeChngd: Boolean;
242 FTitle: string;
243 FServiceSection: string;
244 FLanguage: string;
245 FDtime: string;
246 FVpid: String;
247 procedure SetDivision(const Value: String);
248 procedure SetDUZ(const Value: String);
249 procedure SetName(const Value: String);
250 procedure SetVerifyCodeChngd(const Value: Boolean);
251 procedure SetStandardName(const Value: String);
252 procedure SetTitle(const Value: string);
253 procedure SetDTime(const Value: string);
254 procedure SetLanguage(const Value: string);
255 procedure SetServiceSection(const Value: string);
256public
257 property DUZ: String read FDUZ write SetDUZ;
258 property Name: String read FName write SetName;
259 property StandardName: String read FStandardName write SetStandardName;
260 property Division: String read FDivision write SetDivision;
261 property VerifyCodeChngd: Boolean read FVerifyCodeChngd write SetVerifyCodeChngd;
262 property Title: string read FTitle write SetTitle;
263 property ServiceSection: string read FServiceSection write SetServiceSection;
264 property Language: string read FLanguage write SetLanguage;
265 property DTime: string read FDTime write SetDTime;
266 property Vpid: string read FVpid write FVpid;
267end;
268
269{------ TRPCBroker ------}
270{:This component, when placed on a form, allows design-time and run-time
271 connection to the server by simply toggling the Connected property.
272 Once connected you can access server data.}
273
274TRPCBroker = class(TComponent)
275//private
276private
277protected
278 FBrokerVersion: String;
279 FIsBackwardCompatibleConnection: Boolean;
280 FIsNewStyleConnection: Boolean;
281 FOldConnectionOnly: Boolean;
282 FAccessVerifyCodes: TAccessVerifyCodes;
283 FClearParameters: Boolean;
284 FClearResults: Boolean;
285 FConnected: Boolean;
286 FConnecting: Boolean;
287 FCurrentContext: String;
288 FDebugMode: Boolean;
289 FListenerPort: integer;
290 FParams: TParams;
291 FResults: TStrings;
292 FRemoteProcedure: TRemoteProc;
293 FRpcVersion: TRpcVersion;
294 FServer: TServer;
295 FSocket: integer;
296 FRPCTimeLimit : integer; //for adjusting client RPC duration timeouts
297 FPulse : TTimer; //P6
298 FKernelLogIn : Boolean; //p13
299 FLogIn: TVistaLogIn; //p13
300 FUser: TVistaUser; //p13
301 FOnRPCBFailure: TOnRPCBFailure;
302 FShowErrorMsgs: TShowErrorMsgs;
303 FRPCBError: String;
304 FOnPulseError: TOnPulseError;
305 FSecurityPhrase: String; // BSE JLI 060130
306 // Added from CCOWRPCBroker
307 FCCOWLogonIDName: String;
308 FCCOWLogonIDValue: String;
309 FCCOWLogonName: String;
310 FCCOWLogonNameValue: String;
311 FContextor: TContextorControl; //CCOW
312 FCCOWtoken: string; //CCOW
313 FVistaDomain: String;
314 FCCOWLogonVpid: String;
315 FCCOWLogonVpidValue: String;
316 FWasUserDefined: Boolean;
317 // end of values from CCOWRPCBroker
318 // values for handling SSH tunnels
319 FUseSecureConnection: TSecure;
320 FSSHPort: String;
321 FSSHUser: String;
322 FSSHpw: String;
323 FSSHhide: Boolean;
324 FLastServer: String;
325 FLastPort: Integer;
326 // end SSH tunnel values
327 function GetCCOWHandle(ConnectedBroker: TRPCBroker): string;
328 procedure CCOWsetUser(Uname, token, Domain, Vpid: string; Contextor:
329 TContextorControl);
330 function GetCCOWduz( Contextor: TContextorControl): string;
331protected
332 procedure SetClearParameters(Value: Boolean); virtual;
333 procedure SetClearResults(Value: Boolean); virtual;
334 procedure SetConnected(Value: Boolean); virtual;
335 procedure SetResults(Value: TStrings); virtual;
336 procedure SetServer(Value: TServer); virtual;
337 procedure SetRPCTimeLimit(Value: integer); virtual; //Screen changes to timeout.
338 procedure DoPulseOnTimer(Sender: TObject); virtual; //p6
339 procedure SetKernelLogIn(const Value: Boolean); virtual;
340// procedure SetLogIn(const Value: TVistaLogIn); virtual;
341 procedure SetUser(const Value: TVistaUser); virtual;
342 procedure CheckSSH;
343 function getSSHPassWord: string;
344 function getSSHUsername: string;
345 function StartSecureConnection(var PseudoServer, PseudoPort: String): Boolean;
346public
347 XWBWinsock: TObject;
348 // 060919 added for multiple brokers with both old and new
349 Prefix: String;
350 property AccessVerifyCodes: TAccessVerifyCodes read FAccessVerifyCodes write FAccessVerifyCodes;
351 property Param: TParams read FParams write FParams;
352 property Socket: integer read FSocket;
353 property RPCTimeLimit : integer read FRPCTimeLimit write SetRPCTimeLimit;
354 destructor Destroy; override;
355 procedure Call; virtual;
356 procedure Loaded; override;
357 procedure lstCall(OutputBuffer: TStrings); virtual;
358 function pchCall: PChar; virtual;
359 function strCall: string; virtual;
360 function CreateContext(strContext: string): boolean; virtual;
361 property CurrentContext: String read FCurrentContext;
362 property User: TVistaUser read FUser write SetUser;
363 property OnRPCBFailure: TOnRPCBFailure read FOnRPCBFailure write FOnRPCBFailure;
364 property RPCBError: String read FRPCBError write FRPCBError;
365 property OnPulseError: TOnPulseError read FOnPulseError write FOnPulseError;
366 property BrokerVersion: String read FBrokerVersion;
367 property IsNewStyleConnection: Boolean read FIsNewStyleConnection;
368 property SecurityPhrase: String read FSecurityPhrase write FSecurityPhrase; // BSE JLI 060130
369 // brought in from CCOWRPCBroker
370 function GetCCOWtoken(Contextor: TContextorControl): string;
371 function IsUserCleared: Boolean;
372 function WasUserDefined: Boolean;
373 function IsUserContextPending(aContextItemCollection: IContextItemCollection):
374 Boolean;
375 property Contextor: TContextorControl
376 read Fcontextor write FContextor; //CCOW
377 property CCOWLogonIDName: String read FCCOWLogonIDName;
378 property CCOWLogonIDValue: String read FCCOWLogonIDValue;
379 property CCOWLogonName: String read FCCOWLogonName;
380 property CCOWLogonNameValue: String read FCCOWLogonNameValue;
381 property CCOWLogonVpid: String read FCCOWLogonVpid;
382 property CCOWLogonVpidValue: String read FCCOWLogonVpidValue;
383 // added for secure connection via SSH
384 property SSHport: String read FSSHPort write FSSHPort;
385 property SSHUser: String read FSSHUser write FSSHUser;
386 property SSHpw: String read FSSHpw write FSSHpw;
387published
388 constructor Create(AOwner: TComponent); override;
389 property ClearParameters: boolean read FClearParameters
390 write SetClearParameters;
391 property ClearResults: boolean read FClearResults write SetClearResults;
392 property Connected: boolean read FConnected write SetConnected;
393 property DebugMode: boolean read FDebugMode write FDebugMode default False;
394 property ListenerPort: integer read FListenerPort write FListenerPort;
395 property Results: TStrings read FResults write SetResults;
396 property RemoteProcedure: TRemoteProc read FRemoteProcedure
397 write FRemoteProcedure;
398 property RpcVersion: TRpcVersion read FRpcVersion write FRpcVersion;
399 property Server: TServer read FServer write SetServer;
400 property KernelLogIn: Boolean read FKernelLogIn write SetKernelLogIn;
401 property ShowErrorMsgs: TShowErrorMsgs read FShowErrorMsgs write FShowErrorMsgs default semRaise;
402 property LogIn: TVistaLogIn read FLogIn write FLogin; // SetLogIn;
403 property IsBackwardCompatibleConnection: Boolean read
404 FIsBackwardCompatibleConnection write FIsBackwardCompatibleConnection
405 default True;
406 property OldConnectionOnly: Boolean read FOldConnectionOnly write
407 FOldConnectionOnly;
408 // 080624 added property to permit app to set secure connection if desired
409// property UseSecureConnection: Boolean read FUseSecureConnection write
410// FUseSecureConnection;
411 property UseSecureConnection: TSecure read FUseSecureConnection write
412 FUSeSecureConnection;
413 property SSHHide: Boolean read FSSHHide write FSSHHide;
414end;
415
416{procedure Register;} //P14 --pack split
417procedure StoreConnection(Broker: TRPCBroker);
418function RemoveConnection(Broker: TRPCBroker): boolean;
419function DisconnectAll(Server: string; ListenerPort: integer): boolean;
420function ExistingSocket(Broker: TRPCBroker): integer;
421procedure AuthenticateUser(ConnectingBroker: TRPCBroker);
422procedure GetBrokerInfo(ConnectedBroker : TRPCBroker); //P6
423function NoSignOnNeeded : Boolean;
424function ProcessExecute(Command: string; cShow: Word): Integer;
425function GetAppHandle(ConnectedBroker : TRPCBroker): String;
426function ShowApplicationAndFocusOK(anApplication: TApplication): boolean;
427
428
429var
430 DebugData: string;
431 BrokerConnections: TStringList; {this list stores all connections by socket number}
432 BrokerAllConnections: TStringList; {this list stores all connections to all of
433 the servers, by an application. It's used in DisconnectAll}
434 // 080618 following 2 variables added to handle closing of command box for SSH
435 CommandBoxProcessHandle: THandle;
436 CommandBoxThreadHandle: THandle;
437
438implementation
439
440uses
441 Loginfrm, RpcbErr, SelDiv{p8}, RpcSLogin{p13}, fRPCBErrMsg, Wsockc,
442 CCOW_const, fPlinkpw, fSSHUsername;
443
444var
445 CCOWToken: String;
446 Domain: String;
447 PassCode1: String;
448 PassCode2: String;
449
450const
451 DEFAULT_PULSE : integer = 81000; //P6 default = 45% of 3 minutes.
452 MINIMUM_TIMEOUT : integer = 14; //P6 shortest allowable timeout in secs.
453 PULSE_PERCENTAGE : integer = 45; //P6 % of timeout for pulse frequency.
454
455{-------------------------- TMult.Create --------------------------
456------------------------------------------------------------------}
457constructor TMult.Create(AOwner: TComponent);
458begin
459 inherited Create(AOwner);
460 FMultiple := TStringList.Create;
461end;
462
463{------------------------- TMult.Destroy --------------------------
464------------------------------------------------------------------}
465destructor TMult.Destroy;
466begin
467 ClearAll;
468 FMultiple.Free;
469 FMultiple := nil;
470 inherited Destroy;
471end;
472
473{-------------------------- TMult.Assign --------------------------
474All of the items from source object are copied one by one into the
475target. So if the source is later destroyed, target object will continue
476to hold the copy of all elements, completely unaffected.
477------------------------------------------------------------------}
478procedure TMult.Assign(Source: TPersistent);
479var
480 I: integer;
481 SourceStrings: TStrings;
482 S: TString;
483 SourceMult: TMult;
484begin
485 ClearAll;
486 if Source is TMult then begin
487 SourceMult := Source as TMult;
488 try
489 for I := 0 to SourceMult.FMultiple.Count - 1 do begin
490 S := TString.Create;
491 S.Str := (SourceMult.FMultiple.Objects[I] as TString).Str;
492 Self.FMultiple.AddObject(SourceMult.FMultiple[I], S);
493 end;
494 except
495 end;
496 end
497
498 else begin
499 SourceStrings := Source as TStrings;
500 for I := 0 to SourceStrings.Count - 1 do
501 Self[IntToStr(I)] := SourceStrings[I];
502 end;
503end;
504
505{------------------------- TMult.ClearAll -------------------------
506One by one, all Mult items are freed.
507------------------------------------------------------------------}
508procedure TMult.ClearAll;
509var
510 I: integer;
511begin
512 for I := 0 to FMultiple.Count - 1 do begin
513 FMultiple.Objects[I].Free;
514 FMultiple.Objects[I] := nil;
515 end;
516 FMultiple.Clear;
517end;
518
519{------------------------- TMult.GetCount -------------------------
520Returns the number of elements in the multiple
521------------------------------------------------------------------}
522function TMult.GetCount: Word;
523begin
524 Result := FMultiple.Count;
525end;
526
527{------------------------- TMult.GetFirst -------------------------
528Returns the subscript of the first element in the multiple
529------------------------------------------------------------------}
530function TMult.GetFirst: string;
531begin
532 if FMultiple.Count > 0 then Result := FMultiple[0]
533 else Result := '';
534end;
535
536{------------------------- TMult.GetLast --------------------------
537Returns the subscript of the last element in the multiple
538------------------------------------------------------------------}
539function TMult.GetLast: string;
540begin
541 if FMultiple.Count > 0 then Result := FMultiple[FMultiple.Count - 1]
542 else Result := '';
543end;
544
545{---------------------- TMult.GetFMultiple ------------------------
546Returns the VALUE of the element whose subscript is passed.
547------------------------------------------------------------------}
548function TMult.GetFMultiple(Index: string): string;
549var
550 S: TString;
551 BrokerComponent,ParamRecord: TComponent;
552 I: integer;
553 strError: string;
554begin
555 try
556 S := TString(FMultiple.Objects[FMultiple.IndexOf(Index)]);
557 except
558 on EListError do begin
559 {build appropriate error message}
560 strError := iff(Self.Name <> '', Self.Name, 'TMult_instance');
561 strError := strError + '[' + Index + ']' + #13#10 + 'is undefined';
562 try
563 ParamRecord := Self.Owner;
564 BrokerComponent := Self.Owner.Owner.Owner;
565 if (ParamRecord is TParamRecord) and (BrokerComponent is TRPCBroker) then begin
566 I := 0;
567 {if there is an easier way to figure out which array element points
568 to this instance of a multiple, use it} // p13
569 while TRPCBroker(BrokerComponent).Param[I] <> ParamRecord do inc(I);
570 strError := '.Param[' + IntToStr(I) + '].' + strError;
571 strError := iff(BrokerComponent.Name <> '', BrokerComponent.Name,
572 'TRPCBroker_instance') + strError;
573 end;
574 except
575 end;
576 raise Exception.Create(strError);
577 end;
578 end;
579 Result := S.Str;
580end;
581
582{---------------------- TMult.SetGetSorted ------------------------
583------------------------------------------------------------------}
584function TMult.GetSorted: boolean;
585begin
586 Result := FMultiple.Sorted;
587end;
588
589{---------------------- TMult.SetFMultiple ------------------------
590Stores a new element in the multiple. FMultiple (TStringList) is the
591structure, which is used to hold the subscript and value pair. Subscript
592is stored as the String, value is stored as an object of the string.
593------------------------------------------------------------------}
594procedure TMult.SetFMultiple(Index: string; Value: string);
595var
596 S: TString;
597 Pos: integer;
598begin
599 Pos := FMultiple.IndexOf(Index); {see if this subscript already exists}
600 if Pos = -1 then begin {if subscript is new}
601 S := TString.Create; {create string object}
602 S.Str := Value; {put value in it}
603 FMultiple.AddObject(Index, S); {add it}
604 end
605 else
606 TString(FMultiple.Objects[Pos]).Str := Value; { otherwise replace the value}
607end;
608
609{---------------------- TMult.SetSorted ------------------------
610------------------------------------------------------------------}
611procedure TMult.SetSorted(Value: boolean);
612begin
613 FMultiple.Sorted := Value;
614end;
615
616{-------------------------- TMult.Order --------------------------
617Returns the subscript string of the next or previous element from the
618StartSubscript. This is very similar to the $O function available in M.
619Null string ('') is returned when reaching beyong the first or last
620element, or when list is empty.
621Note: A major difference between the M $O and this function is that
622 in this function StartSubscript must identify a valid subscript
623 in the list.
624------------------------------------------------------------------}
625function TMult.Order(const StartSubscript: string; Direction: integer): string;
626var
627 Index: longint;
628begin
629 Result := '';
630 if StartSubscript = '' then
631 if Direction > 0 then Result := First
632 else Result := Last
633 else begin
634 Index := Position(StartSubscript);
635 if Index > -1 then
636 if (Index < (Count - 1)) and (Direction > 0) then
637 Result := FMultiple[Index + 1]
638 else if (Index > 0) and (Direction < 0) then
639 Result := FMultiple[Index - 1];
640 end
641end;
642
643{------------------------- TMult.Position -------------------------
644Returns the long integer value which is the index position of the
645element in the list. Opposite of TMult.Subscript(). Remember that
646the list is 0 based!
647------------------------------------------------------------------}
648function TMult.Position(const Subscript: string): longint;
649begin
650 Result := FMultiple.IndexOf(Subscript);
651end;
652
653{------------------------ TMult.Subscript -------------------------
654Returns the string subscript of the element whose position in the list
655is passed in. Opposite of TMult.Position(). Remember that the list is 0 based!
656------------------------------------------------------------------}
657function TMult.Subscript(const Position: longint): string;
658begin
659 Result := '';
660 if (Position > -1) and (Position < Count) then
661 Result := FMultiple[Position];
662end;
663
664{---------------------- TParamRecord.Create -----------------------
665Creates TParamRecord instance and automatically creates TMult. The
666name of Mult is also set in case it may be need if exception will be raised.
667------------------------------------------------------------------}
668constructor TParamRecord.Create(AOwner: TComponent);
669begin
670 inherited Create(AOwner);
671 FMult := TMult.Create(Self);
672 FMult.Name := 'Mult';
673 {note: FMult is destroyed in the SetClearParameters method}
674end;
675
676destructor TParamRecord.Destroy;
677begin
678 FMult.Free;
679 FMult := nil;
680 inherited;
681end;
682
683{------------------------- TParams.Create -------------------------
684------------------------------------------------------------------}
685constructor TParams.Create(AOwner: TComponent);
686begin
687 inherited Create(AOwner);
688 FParameters := TList.Create; {for now, empty list}
689end;
690
691{------------------------ TParams.Destroy -------------------------
692------------------------------------------------------------------}
693destructor TParams.Destroy;
694begin
695 Clear; {clear the Multiple first!}
696 FParameters.Free;
697 FParameters := nil;
698 inherited Destroy;
699end;
700
701{------------------------- TParams.Assign -------------------------
702------------------------------------------------------------------}
703procedure TParams.Assign(Source: TPersistent);
704var
705 I: integer;
706 SourceParams: TParams;
707begin
708 Self.Clear;
709 SourceParams := Source as TParams;
710 for I := 0 to SourceParams.Count - 1 do begin
711 Self[I].Value := SourceParams[I].Value;
712 Self[I].PType := SourceParams[I].PType;
713 Self[I].Mult.Assign(SourceParams[I].Mult);
714 end
715end;
716
717{------------------------- TParams.Clear --------------------------
718------------------------------------------------------------------}
719procedure TParams.Clear;
720var
721 ParamRecord: TParamRecord;
722 I: integer;
723begin
724 if FParameters <> nil then begin
725 for I := 0 to FParameters.Count - 1 do begin
726 ParamRecord := TParamRecord(FParameters.Items[I]);
727 if ParamRecord <> nil then begin //could be nil if params were skipped by developer
728 ParamRecord.FMult.Free;
729 ParamRecord.FMult := nil;
730 ParamRecord.Free;
731 end;
732 end;
733 FParameters.Clear; {release FParameters TList}
734 end;
735end;
736
737{------------------------ TParams.GetCount ------------------------
738------------------------------------------------------------------}
739function TParams.GetCount: Word;
740begin
741 if FParameters = nil then Result := 0
742 else Result := FParameters.Count;
743end;
744
745{---------------------- TParams.GetParameter ----------------------
746------------------------------------------------------------------}
747function TParams.GetParameter(Index: integer): TParamRecord;
748begin
749 if Index >= FParameters.Count then {if element out of bounds,}
750 while FParameters.Count <= Index do
751 FParameters.Add(nil); {setup place holders}
752 if FParameters.Items[Index] = nil then begin {if just a place holder,}
753 {point it to new memory block}
754 FParameters.Items[Index] := TParamRecord.Create(Self);
755 TParamRecord(FParameters.Items[Index]).PType := undefined; {initialize}
756 end;
757 Result := FParameters.Items[Index]; {return requested parameter}
758end;
759
760{---------------------- TParams.SetParameter ----------------------
761------------------------------------------------------------------}
762procedure TParams.SetParameter(Index: integer; Parameter: TParamRecord);
763begin
764 if Index >= FParameters.Count then {if element out of bounds,}
765 while FParameters.Count <= Index do
766 FParameters.Add(nil); {setup place holders}
767 if FParameters.Items[Index] = nil then {if just a place holder,}
768 FParameters.Items[Index] := Parameter; {point it to passed parameter}
769end;
770
771{------------------------ TRPCBroker.Create -----------------------
772------------------------------------------------------------------}
773constructor TRPCBroker.Create(AOwner: TComponent);
774begin
775 inherited Create(AOwner);
776 {set defaults}
777
778// This constant defined in the interface section needs to be updated for each release
779 FBrokerVersion := CURRENT_RPC_VERSION;
780
781 FClearParameters := boolean(StrToInt
782 (ReadRegDataDefault(HKLM,REG_BROKER,'ClearParameters','1')));
783 FClearResults := boolean(StrToInt
784 (ReadRegDataDefault(HKLM,REG_BROKER,'ClearResults','1')));
785 FDebugMode := False;
786 FParams := TParams.Create(Self);
787 FResults := TStringList.Create;
788 FServer := ReadRegDataDefault(HKLM,REG_BROKER,'Server','BROKERSERVER');
789 FPulse := TTimer.Create(Self); //P6
790 FListenerPort := StrToInt
791 (ReadRegDataDefault(HKLM,REG_BROKER,'ListenerPort','9200'));
792 FRpcVersion := '0';
793 FRPCTimeLimit := MIN_RPCTIMELIMIT;
794 with FPulse do ///P6
795 begin
796 Enabled := False; //P6
797 Interval := DEFAULT_PULSE; //P6
798 OnTimer := DoPulseOnTimer; //P6
799 end;
800 FLogin := TVistaLogin.Create(Self); //p13
801 FKernelLogin := True; //p13
802 FUser := TVistaUser.Create; //p13
803 FShowErrorMsgs := semRaise; //p13
804 XWBWinsock := TXWBWinsock.Create;
805
806 FIsBackwardCompatibleConnection := True; // default
807 Application.ProcessMessages;
808end;
809
810{----------------------- TRPCBroker.Destroy -----------------------
811------------------------------------------------------------------}
812destructor TRPCBroker.Destroy;
813begin
814 Connected := False;
815 TXWBWinsock(XWBWinsock).Free;
816 FParams.Free;
817 FParams := nil;
818 FResults.Free;
819 FResults := nil;
820 FPulse.Free; //P6
821 FPulse := nil;
822 FUser.Free;
823 FUser := nil;
824 FLogin.Free;
825 FLogin := nil;
826 inherited Destroy;
827end;
828
829{--------------------- TRPCBroker.CreateContext -------------------
830This function is part of the overall Broker security.
831The passed context string is essentially a Client/Server type option
832on the server. The server sets up MenuMan environment variables for this
833context which will later be used to screen RPCs. Only those RPCs which are
834in the multiple field of this context option will be permitted to run.
835------------------------------------------------------------------}
836function TRPCBroker.CreateContext(strContext: string): boolean;
837var
838 InternalBroker: TRPCBroker; {use separate component}
839 Str: String;
840begin
841 Result := False;
842 Connected := True;
843 InternalBroker := nil;
844 try
845 InternalBroker := TRPCBroker.Create(Self);
846 InternalBroker.FSocket := Self.Socket; // p13 -- permits multiple broker connections to same server/port
847 with InternalBroker do
848 begin
849{
850 TXWBWinsock(InternalBroker.XWBWinsock).IsBackwardsCompatible := TXWBWinsock(Self.XWBWinsock).IsBackwardsCompatible;
851 TXWBWinsock(InternalBroker.XWBWinsock).OriginalConnectionOnly := TXWBWinsock(Self.XWBWinsock).OriginalConnectionOnly;
852}
853 Tag := 1234;
854 // 060919 added to support multiple brokers with both old and new connections
855 Prefix := Self.Prefix; // type of connection
856 TXWBWinsock(InternalBroker.XWBWinsock).Prefix := Prefix;
857 // 060919 end of addition
858 ShowErrorMsgs := Self.ShowerrorMsgs;
859 Server := Self.Server; {inherit application server}
860 ListenerPort := Self.ListenerPort; {inherit listener port}
861 DebugMode := Self.DebugMode; {inherit debug mode property}
862 RemoteProcedure := 'XWB CREATE CONTEXT'; {set up RPC}
863 Param[0].PType := literal;
864 Param[0].Value := Encrypt(strContext);
865 try
866 Str := strCall;
867 if Str = '1' then
868 begin // make the call // p13
869 Result := True; // p13
870 self.FCurrentContext := strContext; // p13
871 end // p13
872 else
873 begin
874 Result := False;
875 self.FCurrentContext := '';
876 end;
877 except // Code added to return False if User doesn't have access
878 on e: EBrokerError do
879 begin
880 self.FCurrentContext := '';
881 if Pos('does not have access to option',e.Message) > 0 then
882 begin
883 Result := False
884 end
885 else
886 Raise;
887 end;
888 end;
889 if RPCBError <> '' then
890 self.RPCBError := RPCBError;
891 end;
892 finally
893 InternalBroker.XWBWinsock := nil;
894 InternalBroker.Free; {release memory}
895 end;
896end;
897
898{------------------------ TRPCBroker.Loaded -----------------------
899------------------------------------------------------------------}
900procedure TRPCBroker.Loaded;
901begin
902 inherited Loaded;
903end;
904
905{------------------------- TRPCBroker.Call ------------------------
906------------------------------------------------------------------}
907procedure TRPCBroker.Call;
908var
909 ResultBuffer: TStrings;
910begin
911 ResultBuffer := TStringList.Create;
912 try
913 if ClearResults then ClearResults := True;
914 lstCall(ResultBuffer);
915 Self.Results.AddStrings(ResultBuffer);
916 finally
917 ResultBuffer.Clear;
918 ResultBuffer.Free;
919 end;
920end;
921
922{----------------------- TRPCBroker.lstCall -----------------------
923------------------------------------------------------------------}
924procedure TRPCBroker.lstCall(OutputBuffer: TStrings);
925var
926 ManyStrings: PChar;
927begin
928 ManyStrings := pchCall; {make the call}
929 OutputBuffer.SetText(ManyStrings); {parse result of call, format as list}
930 StrDispose(ManyStrings); {raw result no longer needed, get back mem}
931end;
932
933{----------------------- TRPCBroker.strCall -----------------------
934------------------------------------------------------------------}
935function TRPCBroker.strCall: string;
936var
937 ResultString: PChar;
938begin
939 ResultString := pchCall; {make the call}
940 Result := StrPas(ResultString); {convert and present as Pascal string}
941 StrDispose(ResultString); {raw result no longer needed, get back mem}
942end;
943
944{--------------------- TRPCBroker.SetConnected --------------------
945------------------------------------------------------------------}
946procedure TRPCBroker.SetConnected(Value: Boolean);
947var
948 thisOwner: TComponent;
949 RPCBContextor: TContextorControl;
950 thisParent: TForm;
951 BrokerDir, Str1, Str2, Str3 :string;
952 // 060920 added to support SSH connection
953 PseudoPort: Integer;
954 PseudoServer, PseudoPortStr: String;
955begin
956 RPCBError := '';
957 Login.ErrorText := '';
958 if (Connected <> Value) and not(csReading in ComponentState) then
959 begin
960 if Value and (FConnecting <> Value) then
961 begin {connect}
962 // if change servers, remove SSH port, username, pw
963 if not (FLastServer = '') then
964 begin
965 if (not (FLastServer = Server))
966 or (not (FLastPort = ListenerPort)) then
967 begin
968 SSHport := '';
969 SSHUser := '';
970 SSHpw := '';
971 end;
972 end;
973 FLastServer := Server;
974 FLastPort := ListenerPort;
975 //
976 FSocket := ExistingSocket(Self);
977 FConnecting := True; // FConnected := True;
978 try
979 if FSocket = 0 then
980 begin
981 {Execute Client Agent from directory in Registry.}
982 BrokerDir := ReadRegData(HKLM, REG_BROKER, 'BrokerDr');
983 if BrokerDir <> '' then
984 ProcessExecute(BrokerDir + '\ClAgent.Exe', sw_ShowNoActivate)
985 else
986 ProcessExecute('ClAgent.Exe', sw_ShowNoActivate);
987
988 if DebugMode and (not OldConnectionOnly) then
989 begin
990 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;
991 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;
992 Str3 := '4. Connect the client application using the port number entered in Step #3.';
993 ShowMessage(Str1 + Str2 + Str3);
994 end;
995
996
997
998 CheckSSH;
999 if not (FUseSecureConnection = secureNone) then
1000 begin
1001 if not StartSecureConnection(PseudoServer, PseudoPortStr) then
1002 exit;
1003 // Val(PseudoPortStr,PseudoPort,Code)
1004 PseudoPort := StrToInt(PseudoPortStr);
1005 end
1006 else
1007 begin
1008 PseudoPort := ListenerPort;
1009 PseudoServer := Server;
1010 end;
1011 TXWBWinsock(XWBWinsock).IsBackwardsCompatible := FIsBackwardCompatibleConnection;
1012 TXWBWinsock(XWBWinsock).OldConnectionOnly := FOldConnectionOnly;
1013 FSocket := TXWBWinsock(XWBWinsock).NetworkConnect(DebugMode, PseudoServer, // FServer,
1014 PseudoPort, FRPCTimeLimit);
1015 Prefix := TXWBWinsock(XWBWinsock).Prefix;
1016 FIsNewStyleConnection := TXWBWinsock(XWBWinsock).IsNewStyle;
1017 AuthenticateUser(Self);
1018 StoreConnection(Self); //MUST store connection before CreateContext()
1019 //CCOW start
1020 if (FContextor <> nil) and (length(CCOWtoken) = 0) then
1021 begin
1022 //Get new CCOW token
1023 CCOWToken := GetCCOWHandle(Self);
1024 if Length(CCOWToken) > 0 then
1025 begin
1026 try
1027 RPCBContextor := TContextorControl.Create(Application);
1028 RPCBContextor.Run('BrokerLoginModule#', PassCode1+PassCode2, TRUE, '*');
1029 CCOWsetUser(user.name, CCOWToken, Domain, user.Vpid, RPCBContextor); //Clear token
1030 FCCOWLogonIDName := CCOW_LOGON_ID;
1031 FCCOWLogonIdValue := Domain;
1032 FCCOWLogonName := CCOW_LOGON_NAME;
1033 FCCOWLogonNameValue := user.name;
1034 if user.name <> '' then
1035 FWasUserDefined := True;
1036 FCCOWLogonVpid := CCOW_LOGON_VPID;
1037 FCCOWLogonVpidValue := user.Vpid;
1038 RPCBContextor.Free;
1039 RPCBContextor := nil;
1040 except
1041 ShowMessage('Problem with Contextor.Run');
1042 FreeAndNil(RPCBContextor);
1043 end;
1044 end; // if Length(CCOWToken) > 0
1045 end; //if
1046 //CCOW end
1047 FPulse.Enabled := True; //P6 Start heartbeat.
1048 CreateContext(''); //Closes XUS SIGNON context.
1049 end
1050 else
1051 begin //p13
1052 StoreConnection(Self);
1053 FPulse.Enabled := True; //p13
1054 end; //p13
1055 FConnected := True; // jli mod 12/17/01
1056 FConnecting := False;
1057 // 080620 If connected via SSH, With no command box
1058 // visible, should let users know they have it.
1059 if not (CommandBoxProcessHandle = 0) then
1060 begin
1061 thisOwner := self.Owner;
1062 if (thisOwner is TForm) then
1063 begin
1064 thisParent := TForm(self.Owner);
1065 if not (Pos('(SSH Secure connection)',thisParent.Caption) > 0) then
1066 thisParent.Caption := thisParent.Caption + ' (SSH Secure connection)';
1067 end;
1068 end;
1069 except
1070 on E: EBrokerError do begin
1071 if E.Code = XWB_BadSignOn then
1072 TXWBWinsock(XWBWinsock).NetworkDisconnect(FSocket);
1073 FSocket := 0;
1074 FConnected := False;
1075 FConnecting := False;
1076 if not (CommandBoxProcessHandle = 0) then
1077 TerminateProcess(CommandBoxProcessHandle,10);
1078 FRPCBError := E.Message; // p13 handle errors as specified
1079 if Login.ErrorText <> '' then
1080 FRPCBError := E.Message + chr(10) + Login.ErrorText;
1081 if Assigned(FOnRPCBFailure) then // p13
1082 FOnRPCBFailure(Self) // p13
1083 else if ShowErrorMsgs = semRaise then
1084 Raise; // p13
1085// raise; {this is where I would do OnNetError}
1086 end{on};
1087 end{try};
1088 end{if}
1089 else if not Value then
1090 begin //p13
1091 FConnected := False; //p13
1092 FPulse.Enabled := False; //p13
1093 if RemoveConnection(Self) = NoMore then begin
1094 {FPulse.Enabled := False; ///P6;p13 }
1095 TXWBWinsock(XWBWinsock).NetworkDisconnect(Socket); {actually disconnect from server}
1096 FSocket := 0; {store internal}
1097 //FConnected := False; //p13
1098 // 080618 following added to close command box if SSH is being used
1099 if not (CommandBoxProcessHandle = 0) then
1100 begin
1101 TerminateProcess(CommandBoxProcessHandle,10);
1102 thisOwner := self.Owner;
1103 if (thisOwner is TForm) then
1104 begin
1105 thisParent := TForm(self.Owner);
1106 if (Pos('(SSH Secure connection)',thisParent.Caption) > 0) then
1107 begin
1108 // 080620 remove ' (SSH Secure connection)' on disconnection
1109 thisParent.Caption := Copy(thisParent.Caption,1,Length(thisParent.Caption)-24);
1110 end;
1111 end;
1112 end;
1113 end{if};
1114 end; {else}
1115 end{if};
1116end;
1117
1118{----------------- TRPCBroker.SetClearParameters ------------------
1119------------------------------------------------------------------}
1120procedure TRPCBroker.SetClearParameters(Value: Boolean);
1121begin
1122 if Value then FParams.Clear;
1123 FClearParameters := Value;
1124end;
1125
1126{------------------- TRPCBroker.SetClearResults -------------------
1127------------------------------------------------------------------}
1128procedure TRPCBroker.SetClearResults(Value: Boolean);
1129begin
1130 if Value then begin {if True}
1131 FResults.Clear;
1132 end;
1133 FClearResults := Value;
1134end;
1135
1136{---------------------- TRPCBroker.SetResults ---------------------
1137------------------------------------------------------------------}
1138procedure TRPCBroker.SetResults(Value: TStrings);
1139begin
1140 FResults.Assign(Value);
1141end;
1142
1143{----------------------- TRPCBroker.SetRPCTimeLimit -----------------
1144------------------------------------------------------------------}
1145procedure TRPCBroker.SetRPCTimeLimit(Value: integer);
1146begin
1147 if Value <> FRPCTimeLimit then
1148 if Value > MIN_RPCTIMELIMIT then
1149 FRPCTimeLimit := Value
1150 else
1151 FRPCTimeLimit := MIN_RPCTIMELIMIT;
1152end;
1153
1154{----------------------- TRPCBroker.SetServer ---------------------
1155------------------------------------------------------------------}
1156procedure TRPCBroker.SetServer(Value: TServer);
1157begin
1158 {if changing the name of the server, make sure to disconnect first}
1159 if (Value <> FServer) and Connected then begin
1160 Connected := False;
1161 end;
1162 FServer := Value;
1163end;
1164
1165{--------------------- TRPCBroker.pchCall ----------------------
1166Lowest level remote procedure call that a TRPCBroker component can make.
11671. Returns PChar.
11682. Converts Remote Procedure to PChar internally.
1169------------------------------------------------------------------}
1170function TRPCBroker.pchCall: PChar;
1171var
1172 Value, Sec, App: PChar;
1173 BrokerError: EBrokerError;
1174 blnRestartPulse : boolean; //P6
1175begin
1176 RPCBError := '';
1177 Connected := True;
1178 BrokerError := nil;
1179 Value := nil;
1180 blnRestartPulse := False; //P6
1181
1182 Sec := StrAlloc(255);
1183 App := StrAlloc(255);
1184
1185 try
1186 if FPulse.Enabled then ///P6 If Broker was sending pulse,
1187 begin
1188 FPulse.Enabled := False; /// Stop pulse &
1189 blnRestartPulse := True; // Set flag to restart pulse after RPC.
1190 end;
1191{
1192 if Assigned(FOnRPCCall) then
1193 begin
1194 FOnRPCCall(Self, 1, RemoteProcedure, CurrentContext, RpcVersion, Param, FRPCTimeLimit, '', '', '', Now);
1195 end;
1196}
1197 try
1198 Value := TXWBWinsock(XWBWinsock).tCall(Socket, RemoteProcedure, RpcVersion, Param,
1199 Sec, App,FRPCTimeLimit);
1200{
1201 if Assigned(FOnRPCCall) then
1202 begin
1203 FOnRPCCall(Self, 2, RemoteProcedure, CurrentContext, RpcVersion, Param, FRPCTimeLimit, Result, Sec, App, Now);
1204 end;
1205}
1206 if (StrLen(Sec) > 0) then
1207 begin
1208 BrokerError := EBrokerError.Create(StrPas(Sec));
1209 BrokerError.Code := 0;
1210 BrokerError.Action := 'Error Returned';
1211 end;
1212 except
1213 on Etemp: EBrokerError do
1214 with Etemp do
1215 begin //save copy of error
1216 BrokerError := EBrokerError.Create(message); //field by field
1217 BrokerError.Action := Action;
1218 BrokerError.Code := Code;
1219 BrokerError.Mnemonic := Mnemonic;
1220 if Value <> nil then
1221 StrDispose(Value);
1222 Value := StrNew('');
1223 {if severe error, mark connection as closed. Per Enrique, we should
1224 replace this check with some function, yet to be developed, which
1225 will test the link.}
1226 if ((Code >= 10050)and(Code <=10058))or(Action = 'connection lost') then
1227 begin
1228 Connected := False;
1229 blnRestartPulse := False; //P6
1230 end;
1231 end;
1232 end;
1233 finally
1234 StrDispose(Sec); {do something with these}
1235 Sec := nil;
1236 StrDispose(App);
1237 App := nil;
1238 if ClearParameters then ClearParameters := True; //prepare for next call
1239 end;
1240 Result := Value;
1241 if Result = nil then Result := StrNew(''); //return empty string
1242 if blnRestartPulse then FPulse.Enabled := True; //Restart pulse. (P6)
1243 if BrokerError <> nil then
1244 begin
1245 FRPCBError := BrokerError.Message; // p13 handle errors as specified
1246 if Login.ErrorText <> '' then
1247 FRPCBError := BrokerError.Message + chr(10) + Login.ErrorText;
1248 if Assigned(FOnRPCBFailure) then // p13
1249 begin
1250 FOnRPCBFailure(Self);
1251 StrDispose(Result);
1252 end
1253 else if FShowErrorMsgs = semRaise then
1254 begin
1255 StrDispose(Result); // return memory we won't use - caused a memory leak
1256 Raise BrokerError; // p13
1257 end
1258 else // silent, just return error message in FRPCBError
1259 BrokerError.Free; // return memory in BrokerError - otherwise is a memory leak
1260// raise; {this is where I would do OnNetError}
1261 end; // if BrokerError <> nil
1262end;
1263
1264
1265{-------------------------- DisconnectAll -------------------------
1266Find all connections in BrokerAllConnections list for the passed in
1267server:listenerport combination and disconnect them. If at least one
1268connection to the server:listenerport is found, then it and all other
1269Brokers to the same server:listenerport will be disconnected; True
1270will be returned. Otherwise False will return.
1271------------------------------------------------------------------}
1272function DisconnectAll(Server: string; ListenerPort: integer): boolean;
1273var
1274 Index: integer;
1275begin
1276 Result := False;
1277 while (Assigned(BrokerAllConnections) and
1278 (BrokerAllConnections.Find(Server + ':' + IntToStr(ListenerPort), Index))) do begin
1279 Result := True;
1280 TRPCBroker(BrokerAllConnections.Objects[Index]).Connected := False;
1281 {if the call above disconnected the last connection in the list, then
1282 the whole list will be destroyed, making it necessary to check if it's
1283 still assigned.}
1284 end;
1285end;
1286
1287{------------------------- StoreConnection ------------------------
1288Each broker connection is stored in BrokerConnections list.
1289------------------------------------------------------------------}
1290procedure StoreConnection(Broker: TRPCBroker);
1291begin
1292 if BrokerConnections = nil then {list is created when 1st entry is added}
1293 try
1294 BrokerConnections := TStringList.Create;
1295 BrokerConnections.Sorted := True;
1296 BrokerConnections.Duplicates := dupAccept; {store every connection}
1297 BrokerAllConnections := TStringList.Create;
1298 BrokerAllConnections.Sorted := True;
1299 BrokerAllConnections.Duplicates := dupAccept;
1300 except
1301 TXWBWinsock(Broker.XWBWinsock).NetError('store connection',XWB_BldConnectList)
1302 end;
1303 BrokerAllConnections.AddObject(Broker.Server + ':' +
1304 IntToStr(Broker.ListenerPort), Broker);
1305 BrokerConnections.AddObject(IntToStr(Broker.Socket), Broker);
1306end;
1307
1308{------------------------ RemoveConnection ------------------------
1309Result of this function will be False, if there are no more connections
1310to the same server:listenerport as the passed in Broker. If at least
1311one other connection is found to the same server:listenerport, then Result
1312will be True.
1313------------------------------------------------------------------}
1314function RemoveConnection(Broker: TRPCBroker): boolean;
1315var
1316 Index: integer;
1317begin
1318 Result := False;
1319 if Assigned(BrokerConnections) then begin
1320 {remove connection record of passed in Broker component}
1321 BrokerConnections.Delete(BrokerConnections.IndexOfObject(Broker));
1322 {look for one other connection to the same server:port}
1323// Result := BrokerConnections.Find(Broker.Server + ':' + IntToStr(Broker.ListenerPort), Index);
1324 Result := BrokerConnections.Find(IntToStr(Broker.Socket), Index);
1325 if BrokerConnections.Count = 0 then begin {if last entry removed,}
1326 BrokerConnections.Free; {destroy whole list structure}
1327 BrokerConnections := nil;
1328 end;
1329 end; // if Assigned(BrokerConnections)
1330 if Assigned(BrokerAllConnections) then begin
1331 BrokerAllConnections.Delete(BrokerAllConnections.IndexOfObject(Broker));
1332 if BrokerAllConnections.Count = 0 then begin
1333 BrokerAllConnections.Free;
1334 BrokerAllConnections := nil;
1335 end;
1336 end; // if Assigned(BrokerAllConnections)
1337end;
1338
1339{------------------------- ExistingSocket -------------------------
1340------------------------------------------------------------------}
1341function ExistingSocket(Broker: TRPCBroker): integer;
1342// var
1343// Index: integer;
1344begin
1345 Result := Broker.Socket;
1346{ Result := 0; // p13 to permit multiple Broker connections
1347
1348 if Assigned(BrokerConnections) and
1349 BrokerConnections.Find(Broker.Server + ':' + IntToStr(Broker.ListenerPort), Index) then
1350 Result := TRPCBroker(BrokerConnections.Objects[Index]).Socket;
1351}
1352end;
1353
1354{------------------------ AuthenticateUser ------------------------
1355------------------------------------------------------------------}
1356procedure AuthenticateUser(ConnectingBroker: TRPCBroker);
1357var
1358 SaveClearParmeters, SaveClearResults: boolean;
1359 SaveParam: TParams;
1360 SaveRemoteProcedure, SaveRpcVersion: string;
1361 SaveResults: TStrings;
1362 blnSignedOn: boolean;
1363 SaveKernelLogin: boolean;
1364 SaveVistaLogin: TVistaLogin;
1365 OldExceptionHandler: TExceptionEvent;
1366 OldHandle: THandle;
1367begin
1368 With ConnectingBroker do
1369 begin
1370 SaveParam := TParams.Create(nil);
1371 SaveParam.Assign(Param); //save off settings
1372 SaveRemoteProcedure := RemoteProcedure;
1373 SaveRpcVersion := RpcVersion;
1374 SaveResults := Results;
1375 SaveClearParmeters := ClearParameters;
1376 SaveClearResults := ClearResults;
1377 ClearParameters := True; //set'em as I need'em
1378 ClearResults := True;
1379 SaveKernelLogin := FKernelLogin; // p13
1380 SaveVistaLogin := FLogin; // p13
1381 end;
1382 try
1383 blnSignedOn := False; //initialize to bad sign-on
1384
1385 if ConnectingBroker.AccessVerifyCodes <> '' then // p13 handle as AVCode single signon
1386 begin
1387 ConnectingBroker.Login.AccessCode := Piece(ConnectingBroker.AccessVerifyCodes, ';', 1);
1388 ConnectingBroker.Login.VerifyCode := Piece(ConnectingBroker.AccessVerifyCodes, ';', 2);
1389 ConnectingBroker.Login.Mode := lmAVCodes;
1390 ConnectingBroker.FKernelLogIn := False;
1391 end;
1392
1393 //CCOW start
1394 if ConnectingBroker.KernelLogIn and (not (ConnectingBroker.Contextor = nil)) then
1395 begin
1396 CCOWtoken := ConnectingBroker.GetCCOWtoken(ConnectingBroker.Contextor);
1397 if length(CCOWtoken)>0 then
1398 begin
1399 ConnectingBroker.FKernelLogIn := false;
1400 ConnectingBroker.Login.Mode := lmAppHandle;
1401 ConnectingBroker.Login.LogInHandle := CCOWtoken;
1402 end;
1403 end;
1404 //CCOW end
1405
1406 if ConnectingBroker.FKernelLogIn then
1407 begin //p13
1408 CCOWToken := ''; // 061201 JLI if can't sign on with Token clear it so can get new one
1409 if Assigned(Application.OnException) then
1410 OldExceptionHandler := Application.OnException
1411 else
1412 OldExceptionHandler := nil;
1413 Application.OnException := TfrmErrMsg.RPCBShowException;
1414 frmSignon := TfrmSignon.Create(Application);
1415 try
1416
1417 // ShowApplicationAndFocusOK(Application);
1418 OldHandle := GetForegroundWindow;
1419 SetForegroundWindow(frmSignon.Handle);
1420 PrepareSignonForm(ConnectingBroker);
1421 if SetUpSignOn then //SetUpSignOn in loginfrm unit.
1422 begin //True if signon needed
1423 if frmSignOn.lblServer.Caption <> '' then
1424 begin
1425 frmSignOn.ShowModal; //do interactive logon // p13
1426 if frmSignOn.Tag = 1 then //Tag=1 for good logon
1427 blnSignedOn := True; //Successfull logon
1428 end
1429 end
1430 else //False when no logon needed
1431 blnSignedOn := NoSignOnNeeded; //Returns True always (for now!)
1432 if blnSignedOn then //P6 If logged on, retrieve user info.
1433 begin
1434 GetBrokerInfo(ConnectingBroker);
1435 if not SelDiv.ChooseDiv('',ConnectingBroker) then
1436 begin
1437 blnSignedOn := False;//P8
1438 {Select division if multi-division user. First parameter is 'userid'
1439 (DUZ or username) for future use. (P8)}
1440 ConnectingBroker.Login.ErrorText := 'Failed to select Division'; // p13 set some text indicating problem
1441 end;
1442 end;
1443 SetForegroundWindow(OldHandle);
1444 finally
1445 frmSignon.Free;
1446// frmSignon.Release; //get rid of signon form
1447
1448// if ConnectingBroker.Owner is TForm then
1449// SetForegroundWindow(TForm(ConnectingBroker.Owner).Handle)
1450// else
1451// SetForegroundWindow(ActiveWindow);
1452 ShowApplicationAndFocusOK(Application);
1453 end ; //try
1454 if Assigned(OldExceptionHandler) then
1455 Application.OnException := OldExceptionHandler;
1456 end; //if kernellogin
1457 // p13 following section for silent signon
1458 if not ConnectingBroker.FKernelLogIn then
1459 if ConnectingBroker.FLogin <> nil then //the user. vistalogin contains login info
1460 blnsignedon := SilentLogin(ConnectingBroker); // RpcSLogin unit
1461 if not blnsignedon then
1462 begin
1463 ConnectingBroker.FLogin.FailedLogin(ConnectingBroker.FLogin);
1464 TXWBWinsock(ConnectingBroker.XWBWinsock).NetworkDisconnect(ConnectingBroker.FSocket);
1465 end
1466 else
1467 GetBrokerInfo(ConnectingBroker);
1468 finally
1469 //reset the Broker
1470 with ConnectingBroker do
1471 begin
1472 ClearParameters := SaveClearParmeters;
1473 ClearResults := SaveClearResults;
1474 Param.Assign(SaveParam); //restore settings
1475 SaveParam.Free;
1476 RemoteProcedure := SaveRemoteProcedure;
1477 RpcVersion := SaveRpcVersion;
1478 Results := SaveResults;
1479 FKernelLogin := SaveKernelLogin; // p13
1480 FLogin := SaveVistaLogin; // p13
1481 end;
1482 end;
1483
1484 if not blnSignedOn then //Flag for unsuccessful signon.
1485 TXWBWinsock(ConnectingBroker.XWBWinsock).NetError('',XWB_BadSignOn); //Will raise error.
1486
1487end;
1488
1489
1490{------------------------ GetBrokerInfo ------------------------
1491P6 Retrieve information about user with XWB GET BROKER INFO
1492 RPC. For now, only Timeout value is retrieved in Results[0].
1493------------------------------------------------------------------}
1494procedure GetBrokerInfo(ConnectedBroker: TRPCBroker);
1495begin
1496 GetUserInfo(ConnectedBroker); // p13 Get User info into User property (TVistaUser object)
1497 With ConnectedBroker do //(dcm) Use one of objects below
1498 begin // and skip this RPC? or make this and
1499 RemoteProcedure := 'XWB GET BROKER INFO'; // others below as components
1500 try
1501 Call;
1502 if Results.Count > 0 then
1503 if StrToInt(Results[0]) > MINIMUM_TIMEOUT then
1504 FPulse.Interval := (StrToInt(Results[0]) * 10 * PULSE_PERCENTAGE);
1505 except
1506 On e: EBrokerError do
1507 ShowMessage('A problem was encountered getting Broker information. '+e.Message); //TODO
1508 end;
1509 end;
1510end;
1511
1512{------------------------ NoSignOnNeeded ------------------------
1513------------------------------------------------------------------}
1514{Currently a placeholder for actions that may be needed in connection
1515with authenticating a user who needn't sign on (Single Sign on feature).
1516Returns True if no signon is needed
1517 False if signon is needed.}
1518function NoSignOnNeeded : Boolean;
1519begin
1520 Result := True;
1521end;
1522
1523{------------------------- ProcessExecute -------------------------
1524This function is borrowed from "Delphi 2 Developer's Guide" by Pacheco & Teixera.
1525See chapter 11, page 406. It encapsulates and simplifies use of
1526Windows CreateProcess function.
1527------------------------------------------------------------------}
1528function ProcessExecute(Command: string; cShow: Word): Integer;
1529{ This method encapsulates the call to CreateProcess() which creates
1530 a new process and its primary thread. This is the method used in
1531 Win32 to execute another application, This method requires the use
1532 of the TStartInfo and TProcessInformation structures. These structures
1533 are not documented as part of the Delphi 2.0 online help but rather
1534 the Win32 help as STARTUPINFO and PROCESS_INFORMATION.
1535
1536 The CommandLine paremeter specifies the pathname of the file to
1537 execute.
1538
1539 The cShow paremeter specifies one of the SW_XXXX constants which
1540 specifies how to display the window. This value is assigned to the
1541 sShowWindow field of the TStartupInfo structure. }
1542var
1543 Rslt: LongBool;
1544 StartUpInfo: TStartUpInfo; // documented as STARTUPINFO
1545 ProcessInfo: TProcessInformation; // documented as PROCESS_INFORMATION
1546begin
1547 { Clear the StartupInfo structure }
1548 FillChar(StartupInfo, SizeOf(TStartupInfo), 0);
1549 { Initialize the StartupInfo structure with required data.
1550 Here, we assign the SW_XXXX constant to the wShowWindow field
1551 of StartupInfo. When specifing a value to this field the
1552 STARTF_USESSHOWWINDOW flag must be set in the dwFlags field.
1553 Additional information on the TStartupInfo is provided in the Win32
1554 online help under STARTUPINFO. }
1555 with StartupInfo do begin
1556 cb := SizeOf(TStartupInfo); // Specify size of structure
1557 dwFlags := STARTF_USESHOWWINDOW or STARTF_FORCEONFEEDBACK;
1558 wShowWindow := cShow
1559 end;
1560
1561 { Create the process by calling CreateProcess(). This function
1562 fills the ProcessInfo structure with information about the new
1563 process and its primary thread. Detailed information is provided
1564 in the Win32 online help for the TProcessInfo structure under
1565 PROCESS_INFORMATION. }
1566 Rslt := CreateProcess(PChar(Command), nil, nil, nil, False,
1567 NORMAL_PRIORITY_CLASS, nil, nil, StartupInfo, ProcessInfo);
1568 { If Rslt is true, then the CreateProcess call was successful.
1569 Otherwise, GetLastError will return an error code representing the
1570 error which occurred. }
1571 if Rslt then
1572 with ProcessInfo do begin
1573 { Wait until the process is in idle. }
1574 WaitForInputIdle(hProcess, INFINITE);
1575 CloseHandle(hThread); // Free the hThread handle
1576 CloseHandle(hProcess);// Free the hProcess handle
1577 Result := 0; // Set Result to 0, meaning successful
1578 end
1579 else Result := GetLastError; // Set result to the error code.
1580end;
1581
1582
1583{----------------------- GetAppHandle --------------------------
1584Library function to return an Application Handle from the server
1585which can be passed as a command line argument to an application
1586the current application is starting. The new application can use
1587this AppHandle to perform a silent login via the lmAppHandle mode
1588----------------------------------------------------------------}
1589function GetAppHandle(ConnectedBroker : TRPCBroker): String; // p13
1590begin
1591 Result := '';
1592 with ConnectedBroker do
1593 begin
1594 RemoteProcedure := 'XUS GET TOKEN';
1595 Call;
1596 Result := Results[0];
1597 end;
1598end;
1599
1600{----------------------- TRPCBroker.DoPulseOnTimer-----------------
1601Called from the OnTimer event of the Pulse property.
1602Broker environment should be the same after the procedure as before.
1603Note: Results is not changed by strCall; so, Results needn't be saved.
1604------------------------------------------------------------------}
1605procedure TRPCBroker.DoPulseOnTimer(Sender: TObject); //P6
1606var
1607 SaveClearParameters : Boolean;
1608 SaveParam : TParams;
1609 SaveRemoteProcedure, SaveRPCVersion : string;
1610begin
1611 SaveClearParameters := ClearParameters; //Save existing properties
1612 SaveParam := TParams.Create(nil);
1613 SaveParam.Assign(Param);
1614 SaveRemoteProcedure := RemoteProcedure;
1615 SaveRPCVersion := RPCVersion;
1616 RemoteProcedure := 'XWB IM HERE'; //Set Properties for IM HERE
1617 ClearParameters := True; //Erase existing PARAMs
1618 RPCVersion := '1.106';
1619 try
1620 try
1621 strCall; //Make the call
1622 except on e: EBrokerError do
1623 begin
1624// Connected := False; // set the connection as disconnected
1625 if Assigned(FOnPulseError) then
1626 FOnPulseError(Self, e.Message)
1627 else
1628 raise e;
1629 end;
1630 end;
1631 finally
1632 ClearParameters := SaveClearParameters; //Restore pre-existing properties.
1633 Param.Assign(SaveParam);
1634 SaveParam.Free;
1635 RemoteProcedure := SaveRemoteProcedure;
1636 RPCVersion := SaveRPCVersion;
1637 end;
1638end;
1639
1640procedure TRPCBroker.SetKernelLogIn(const Value: Boolean); // p13
1641begin
1642 FKernelLogIn := Value;
1643end;
1644{
1645procedure TRPCBroker.SetLogIn(const Value: TVistaLogIn); // p13
1646begin
1647 FLogIn := Value;
1648end;
1649}
1650procedure TRPCBroker.SetUser(const Value: TVistaUser); // p13
1651begin
1652 FUser := Value;
1653end;
1654
1655
1656{*****TVistaLogin***** p13}
1657
1658constructor TVistaLogin.Create(AOwner: TComponent); // p13
1659begin
1660 inherited create;
1661 FDivLst := TStringList.Create;
1662end;
1663
1664destructor TVistaLogin.Destroy; // p13
1665begin
1666 FDivLst.Free;
1667 FDivLst := nil;
1668 inherited;
1669end;
1670
1671procedure TVistaLogin.FailedLogin(Sender: TObject); // p13
1672begin
1673 if Assigned(FOnFailedLogin) then FOnFailedLogin(Self)
1674 else TXWBWinsock(TRPCBroker(Sender).XWBWinsock).NetError('',XWB_BadSignOn);
1675end;
1676
1677procedure TVistaLogin.SetAccessCode(const Value: String); // p13
1678begin
1679 FAccessCode := Value;
1680end;
1681
1682procedure TVistaLogin.SetDivision(const Value: String); // p13
1683begin
1684 FDivision := Value;
1685end;
1686
1687procedure TVistaLogin.SetDuz(const Value: string); // p13
1688begin
1689 FDUZ := Value;
1690end;
1691
1692procedure TVistaLogin.SetErrorText(const Value: string); // p13
1693begin
1694 FErrorText := Value;
1695end;
1696
1697procedure TVistaLogin.SetLogInHandle(const Value: String); // p13
1698begin
1699 FLogInHandle := Value;
1700end;
1701
1702procedure TVistaLogin.SetMode(const Value: TLoginMode); // p13
1703begin
1704 FMode := Value;
1705end;
1706
1707procedure TVistaLogin.SetMultiDivision(Value: Boolean); // p13
1708begin
1709 FMultiDivision := Value;
1710end;
1711
1712procedure TVistaLogin.SetNTToken(const Value: String); // p13
1713begin
1714end;
1715
1716procedure TVistaLogin.SetPromptDiv(const Value: boolean); // p13
1717begin
1718 FPromptDiv := Value;
1719end;
1720
1721procedure TVistaLogin.SetVerifyCode(const Value: String); // p13
1722begin
1723 FVerifyCode := Value;
1724end;
1725
1726{***** TVistaUser ***** p13 }
1727
1728procedure TVistaUser.SetDivision(const Value: String); // p13
1729begin
1730 FDivision := Value;
1731end;
1732
1733procedure TVistaUser.SetDTime(const Value: string); // p13
1734begin
1735 FDTime := Value;
1736end;
1737
1738procedure TVistaUser.SetDUZ(const Value: String); // p13
1739begin
1740 FDUZ := Value;
1741end;
1742
1743procedure TVistaUser.SetLanguage(const Value: string); // p13
1744begin
1745 FLanguage := Value;
1746end;
1747
1748procedure TVistaUser.SetName(const Value: String); // p13
1749begin
1750 FName := Value;
1751end;
1752
1753procedure TVistaUser.SetServiceSection(const Value: string); // p13
1754begin
1755 FServiceSection := Value;
1756end;
1757
1758procedure TVistaUser.SetStandardName(const Value: String); // p13
1759begin
1760 FStandardName := Value;
1761end;
1762
1763procedure TVistaUser.SetTitle(const Value: string); // p13
1764begin
1765 FTitle := Value;
1766end;
1767
1768procedure TVistaUser.SetVerifyCodeChngd(const Value: Boolean); // p13
1769begin
1770 FVerifyCodeChngd := Value;
1771end;
1772
1773Function ShowApplicationAndFocusOK(anApplication: TApplication): boolean;
1774var
1775 j: integer;
1776 Stat2: set of (sWinVisForm,sWinVisApp,sIconized);
1777 hFGWnd: THandle;
1778begin
1779 Stat2 := []; {sWinVisForm,sWinVisApp,sIconized}
1780
1781 If anApplication.MainForm <> nil then
1782 If IsWindowVisible(anApplication.MainForm.Handle)
1783 then Stat2 := Stat2 + [sWinVisForm];
1784
1785 If IsWindowVisible(anApplication.Handle)
1786 then Stat2 := Stat2 + [sWinVisApp];
1787
1788 If IsIconic(anApplication.Handle)
1789 then Stat2 := Stat2 + [sIconized];
1790
1791 Result := true;
1792 If sIconized in Stat2 then begin {A}
1793 j := SendMessage(anApplication.Handle,WM_SYSCOMMAND,SC_RESTORE,0);
1794 Result := j<>0;
1795 end;
1796 If Stat2 * [sWinVisForm,sIconized] = [] then begin {S}
1797 if anApplication.MainForm <> nil then
1798 anApplication.MainForm.Show;
1799 end;
1800 If (Stat2 * [sWinVisForm,sIconized] <> []) or
1801 (sWinVisApp in Stat2) then begin {G}
1802{$IFNDEF D6_OR_HIGHER}
1803 hFGWnd := GetForegroundWindow;
1804 try
1805 AttachThreadInput(
1806 GetWindowThreadProcessId(hFGWnd, nil),
1807 GetCurrentThreadId,True);
1808 Result := SetForegroundWindow(anApplication.Handle);
1809 finally
1810 AttachThreadInput(
1811 GetWindowThreadProcessId(hFGWnd, nil),
1812 GetCurrentThreadId, False);
1813 end;
1814{$ENDIF}
1815 end;
1816end;
1817
1818function TRPCBroker.WasUserDefined: Boolean;
1819begin
1820 Result := FWasUserDefined;
1821end;
1822
1823function TRPCBroker.IsUserCleared: Boolean;
1824var
1825 CCOWcontextItem: IContextItemCollection; //CCOW
1826 CCOWdataItem1: IContextItem; //CCOW
1827 Name: String;
1828begin
1829 Result := False;
1830 Name := CCOW_LOGON_ID;
1831 if (Contextor <> nil) then
1832 try
1833 //See if context contains the ID item
1834 CCOWcontextItem := Contextor.CurrentContext;
1835 CCOWDataItem1 := CCowContextItem.Present(Name);
1836 if (CCOWdataItem1 <> nil) then //1
1837 begin
1838 If CCOWdataItem1.Value = '' then
1839 Result := True
1840 else
1841 FWasUserDefined := True;
1842 end
1843 else
1844 Result := True;
1845 finally
1846 end; //try
1847end;
1848
1849
1850{----------------------- GetCCOWHandle --------------------------
1851Private function to return a special CCOW Handle from the server
1852which is set into the CCOW context.
1853The Broker of a new application can get the CCOWHandle from the context
1854and use it to do a ImAPPHandle Sign-on.
1855----------------------------------------------------------------}
1856function TRPCBroker.GetCCOWHandle(ConnectedBroker : TRPCBroker): String; // p13
1857begin
1858 Result := '';
1859 with ConnectedBroker do
1860 try // to permit it to work correctly if CCOW is not installed on the server.
1861 begin
1862 RemoteProcedure := 'XUS GET CCOW TOKEN';
1863 Call;
1864 Result := Results[0];
1865 Domain := Results[1];
1866 RemoteProcedure := 'XUS CCOW VAULT PARAM';
1867 Call;
1868 PassCode1 := Results[0];
1869 PassCode2 := Results[1];
1870 end;
1871 except
1872 Result := '';
1873 end;
1874end;
1875
1876//CCOW start
1877procedure TRPCBroker.CCOWsetUser(Uname, token, Domain, Vpid: string; Contextor:
1878 TContextorControl);
1879var
1880 CCOWdata: IContextItemCollection; //CCOW
1881 CCOWdataItem1,CCOWdataItem2,CCOWdataItem3: IContextItem;
1882 CCOWdataItem4,CCOWdataItem5: IContextItem; //CCOW
1883 Cname: string;
1884begin
1885 if Contextor <> nil then
1886 begin
1887 try
1888 //Part 1
1889 Contextor.StartContextChange;
1890 //Part 2 Set the new proposed context data
1891 CCOWdata := CoContextItemCollection.Create;
1892 CCOWdataItem1 := CoContextItem.Create;
1893 Cname := CCOW_LOGON_ID;
1894 CCOWdataItem1.Name := Cname;
1895 CCOWdataItem1.Value := domain;
1896 CCOWData.Add(CCOWdataItem1);
1897 CCOWdataItem2 := CoContextItem.Create;
1898 Cname := CCOW_LOGON_TOKEN;
1899 CCOWdataItem2.Name := Cname;
1900 CCOWdataItem2.Value := token;
1901 CCOWdata.Add(CCOWdataItem2);
1902 CCOWdataItem3 := CoContextItem.Create;
1903 Cname := CCOW_LOGON_NAME;
1904 CCOWdataItem3.Name := Cname;
1905 CCOWdataItem3.Value := Uname;
1906 CCOWdata.Add(CCOWdataItem3);
1907 //
1908 CCOWdataItem4 := CoContextItem.Create;
1909 Cname := CCOW_LOGON_VPID;
1910 CCOWdataItem4.Name := Cname;
1911 CCOWdataItem4.Value := Vpid;
1912 CCOWdata.Add(CCOWdataItem4);
1913 //
1914 CCOWdataItem5 := CoContextItem.Create;
1915 Cname := CCOW_USER_NAME;
1916 CCOWdataItem5.Name := Cname;
1917 CCOWdataItem5.Value := Uname;
1918 CCOWdata.Add(CCOWdataItem5);
1919 //Part 3 Make change
1920 Contextor.EndContextChange(true, CCOWdata);
1921 //We don't need to check CCOWresponce
1922 finally
1923 end; //try
1924 end; //if
1925end;
1926
1927//Get Token from CCOW context
1928function TRPCBroker.GetCCOWtoken(Contextor: TContextorControl): string;
1929var
1930 CCOWdataItem1: IContextItem; //CCOW
1931 CCOWcontextItem: IContextItemCollection; //CCOW
1932 name: string;
1933begin
1934 result := '';
1935 name := CCOW_LOGON_TOKEN;
1936 if (Contextor <> nil) then
1937 try
1938 CCOWcontextItem := Contextor.CurrentContext;
1939 //See if context contains the ID item
1940 CCOWdataItem1 := CCOWcontextItem.Present(name);
1941 if (CCOWdataItem1 <> nil) then //1
1942 begin
1943 result := CCOWdataItem1.Value;
1944 if not (result = '') then
1945 FWasUserDefined := True;
1946 end;
1947 FCCOWLogonIDName := CCOW_LOGON_ID;
1948 FCCOWLogonName := CCOW_LOGON_NAME;
1949 FCCOWLogonVpid := CCOW_LOGON_VPID;
1950 CCOWdataItem1 := CCOWcontextItem.Present(CCOW_LOGON_ID);
1951 if CCOWdataItem1 <> nil then
1952 FCCOWLogonIdValue := CCOWdataItem1.Value;
1953 CCOWdataItem1 := CCOWcontextItem.Present(CCOW_LOGON_NAME);
1954 if CCOWdataItem1 <> nil then
1955 FCCOWLogonNameValue := CCOWdataItem1.Value;
1956 CCOWdataItem1 := CCOWcontextItem.Present(CCOW_LOGON_VPID);
1957 if CCOWdataItem1 <> nil then
1958 FCCOWLogonVpidValue := CCOWdataItem1.Value;
1959 finally
1960 end; //try
1961end;
1962
1963//Get Name from CCOW context
1964function TRPCBroker.GetCCOWduz(Contextor: TContextorControl): string;
1965var
1966 CCOWdataItem1: IContextItem; //CCOW
1967 CCOWcontextItem: IContextItemCollection; //CCOW
1968 name: string;
1969begin
1970 result := '';
1971 name := CCOW_LOGON_ID;
1972 if (Contextor <> nil) then
1973 try
1974 CCOWcontextItem := Contextor.CurrentContext;
1975 //See if context contains the ID item
1976 CCOWdataItem1 := CCOWcontextItem.Present(name);
1977 if (CCOWdataItem1 <> nil) then //1
1978 begin
1979 result := CCOWdataItem1.Value;
1980 if result <> '' then
1981 FWasUserDefined := True;
1982 end;
1983 finally
1984 end; //try
1985end;
1986
1987function TRPCBroker.IsUserContextPending(aContextItemCollection:
1988 IContextItemCollection): Boolean;
1989var
1990 CCOWdataItem1: IContextItem; //CCOW
1991 Val1: String;
1992begin
1993 result := false;
1994 if WasUserDefined() then // indicates data was defined
1995 begin
1996 Val1 := ''; // look for any USER Context items defined
1997 result := True;
1998 //
1999 CCOWdataItem1 := aContextItemCollection.Present(CCOW_LOGON_ID);
2000 if CCOWdataItem1 <> nil then
2001 if not (CCOWdataItem1.Value = FCCOWLogonIDValue) then
2002 Val1 := '^' + CCOWdataItem1.Value;
2003 //
2004 CCOWdataItem1 := aContextItemCollection.Present(CCOW_LOGON_NAME);
2005 if CCOWdataItem1 <> nil then
2006 if not (CCOWdataItem1.Value = FCCOWLogonNameValue) then
2007 Val1 := Val1 + '^' + CCOWdataItem1.Value;
2008 //
2009 CCOWdataItem1 := aContextItemCollection.Present(CCOW_LOGON_VPID);
2010 if CCOWdataItem1 <> nil then
2011 if not (CCOWdataItem1.Value = FCCOWLogonVpidValue) then
2012 Val1 := Val1 + '^' + CCOWdataItem1.Value;
2013 //
2014 CCOWdataItem1 := aContextItemCollection.Present(CCOW_USER_NAME);
2015 if CCOWdataItem1 <> nil then
2016 if not (CCOWdataItem1.Value = user.Name) then
2017 Val1 := Val1 + '^' + CCOWdataItem1.Value;
2018 //
2019 if Val1 = '' then // nothing defined or all matches, so not user context change
2020 result := False;
2021 end;
2022end;
2023
2024{*
2025 procedure CheckSSH was extracted to remove duplicate code
2026 in the SetConnected method of Trpcb and derived classes
2027*}
2028procedure TRpcBroker.CheckSSH;
2029var
2030 ParamNum: Integer;
2031 ParamVal: String;
2032 ParamValNormal: String;
2033begin
2034 ParamNum := 1;
2035 while (not (ParamStr(ParamNum) = '')) do
2036 begin
2037 ParamValNormal := ParamStr(ParamNum);
2038 ParamVal := UpperCase(ParamValNormal);
2039 // check for command line specifiction of connection
2040 // method if not set as a property
2041 if FUseSecureConnection = secureNone then
2042 begin
2043 if ParamVal = 'SSH' then
2044 FUseSecureConnection := secureAttachmate;
2045 if ParamVal = 'PLINK' then
2046 FUseSecureConnection := securePlink;
2047 end;
2048 // check for SSH specifications on command line
2049 if Pos('SSHPORT=',ParamVal) = 1 then
2050 FSSHPort := Copy(ParamVal,9,Length(ParamVal));
2051 if Pos('SSHUSER=',ParamVal) = 1 then
2052 FSSHUser := Copy(ParamValNormal,9,Length(ParamVal));
2053 if Pos('SSHPW=',ParamVal) = 1 then
2054 FSSHpw := Copy(ParamValNormal,7,Length(ParamVal));
2055 if ParamVal = 'SSHHIDE' then
2056 FSSHhide := true;
2057 ParamNum := ParamNum + 1;
2058 end;
2059end;
2060
2061function TRPCBroker.getSSHUsername: string;
2062var
2063 UsernameEntry: TSSHUsername;
2064begin
2065 UsernameEntry := TSSHUsername.Create(Self);
2066 UsernameEntry.ShowModal;
2067 Result := UsernameEntry.Edit1.Text;
2068 UsernameEntry.Free;
2069end;
2070
2071function TRPCBroker.getSSHPassWord: string;
2072var
2073 PasswordEntry: TfPlinkPassword;
2074begin
2075 PasswordEntry := TfPlinkPassword.Create(Self);
2076 PasswordEntry.ShowModal;
2077 Result := PasswordEntry.Edit1.Text;
2078 PasswordEntry.Free;
2079end;
2080
2081function TRPCBroker.StartSecureConnection(var PseudoServer, PseudoPort:
2082 String): Boolean;
2083var
2084 CmndLine: String;
2085begin
2086 // PseudoPort := NewSocket();
2087 PseudoPort := FSSHPort;
2088 if FSSHPort = '' then
2089 PseudoPort := IntToStr(ListenerPort);
2090 PseudoServer := '127.0.0.1';
2091 if (FSSHUser = '') then
2092 begin
2093 FSSHUser := getSSHUsername;
2094 end;
2095 if FUseSecureConnection = secureAttachmate then
2096 begin
2097 CmndLine := 'SSH2 -L '+PseudoPort+':'+FServer+':'+IntToStr(ListenerPort)+' -S -o "TryEmptyPassword yes" -o "MACs=hmac-sha1" -o "FipsMode yes" -o "StrictHostKeyChecking no" -o "connectionReuse no" '+FSSHUser+'@'+Server;
2098 end;
2099 if FUseSecureConnection = securePlink then
2100 begin
2101 if FSSHpw = '' then
2102 begin
2103 FSSHpw := getSSHPassWord
2104 end;
2105 CmndLine := 'plink.exe -L '+PseudoPort // -v
2106 +':'+PseudoServer+':'+
2107 IntToStr(ListenerPort)+' '+FSSHUser+'@'+FServer +' -pw '+ FSSHpw;
2108 // IntToStr(ListenerPort)+' '+FSSHUser+'@'+FServer+' -pw 914Qemu5';
2109 end;
2110 if FSSHhide then
2111 StartProgSLogin(CmndLine, nil, SW_HIDE)
2112 else
2113 StartProgSLogin(CmndLine, nil, SW_SHOWMINIMIZED);
2114 Sleep(5000);
2115 result := true;
2116end;
2117
2118end.
2119
Note: See TracBrowser for help on using the repository browser.