source: cprs/branches/HealthSevak-CPRS/CPRS-Lib/ORNet.pas@ 1689

Last change on this file since 1689 was 829, checked in by Kevin Toppenberg, 14 years ago

Upgrade to version 27

File size: 16.9 KB
Line 
1unit ORNet;
2
3{$DEFINE CCOWBROKER}
4
5interface
6
7uses SysUtils, Windows, Classes, Forms, Controls, ORFn, TRPCB, RPCConf1, Dialogs
8{$IFDEF CCOWBROKER}, CCOWRPCBroker {$ENDIF} ; //, SharedRPCBroker;
9
10
11procedure SetBrokerServer(const AName: string; APort: Integer; WantDebug: Boolean);
12function AuthorizedOption(const OptionName: string): Boolean;
13function ConnectToServer(const OptionName: string): Boolean;
14function MRef(glvn: string): string;
15procedure CallV(const RPCName: string; const AParam: array of const);
16function sCallV(const RPCName: string; const AParam: array of const): string;
17procedure tCallV(ReturnData: TStrings; const RPCName: string; const AParam: array of const);
18function UpdateContext(NewContext: string): boolean;
19function IsBaseContext: boolean;
20procedure CallBrokerInContext;
21procedure CallBroker;
22function RetainedRPCCount: Integer;
23procedure SetRetainedRPCMax(Value: Integer);
24function GetRPCMax: integer;
25procedure LoadRPCData(Dest: TStrings; ID: Integer);
26function DottedIPStr: string;
27procedure CallRPCWhenIdle(CallProc: TORIdleCallProc; Msg: String);
28
29procedure EnsureBroker;
30
31(*
32function pCallV(const RPCName: string; const AParam: array of const): PChar;
33procedure wCallV(AControl: TControl; const RPCName: string; const AParam: array of const);
34procedure WrapWP(Buf: pChar);
35*)
36
37var
38{$IFDEF CCOWBROKER}
39 RPCBrokerV: TCCOWRPCBroker;
40{$ELSE}
41 RPCBrokerV: TRPCBroker;
42 //RPCBrokerV: TSharedRPCBroker;
43{$ENDIF}
44 RPCLastCall: string;
45
46 AppStartedCursorForm: TForm = nil;
47
48implementation
49
50uses Winsock;
51
52const
53 // *** these are constants from RPCBErr.pas, will broker document them????
54 XWB_M_REJECT = 20000 + 2; // M error
55 XWB_BadSignOn = 20000 + 4; // SignOn 'Error' (happens when cancel pressed)
56
57var
58 uCallList: TList;
59 uMaxCalls: Integer;
60 uShowRPCs: Boolean;
61 uBaseContext: string = '';
62 uCurrentContext: string = '';
63
64{ private procedures and functions ---------------------------------------------------------- }
65
66procedure EnsureBroker;
67{ ensures that a broker object has been created - creates & initializes it if necessary }
68begin
69 if RPCBrokerV = nil then
70 begin
71{$IFDEF CCOWBROKER}
72 RPCBrokerV := TCCOWRPCBroker.Create(Application);
73{$ELSE}
74 RPCBrokerV := TRPCBroker.Create(Application);
75 //RPCBrokerV := TSharedRPCBroker.Create(Application);
76{$ENDIF}
77 with RPCBrokerV do
78 begin
79 KernelLogIn := True;
80 Login.Mode := lmAppHandle;
81 ClearParameters := True;
82 ClearResults := True;
83 DebugMode := False;
84 end;
85 end;
86end;
87
88procedure SetList(AStringList: TStrings; ParamIndex: Integer);
89{ places TStrings into RPCBrokerV.Mult[n], where n is a 1-based (not 0-based) index }
90var
91 i: Integer;
92begin
93 with RPCBrokerV.Param[ParamIndex] do
94 begin
95 PType := list;
96 with AStringList do for i := 0 to Count - 1 do Mult[IntToStr(i+1)] := Strings[i];
97 end;
98end;
99
100procedure SetParams(const RPCName: string; const AParam: array of const);
101{ takes the params (array of const) passed to xCallV and sets them into RPCBrokerV.Param[i] }
102const
103 BoolChar: array[boolean] of char = ('0', '1');
104var
105 i: integer;
106 TmpExt: Extended;
107begin
108 RPCLastCall := RPCName + ' (SetParam begin)';
109 if Length(RPCName) = 0 then raise Exception.Create('No RPC Name');
110 EnsureBroker;
111 with RPCBrokerV do
112 begin
113 ClearParameters := True;
114 RemoteProcedure := RPCName;
115 for i := 0 to High(AParam) do with AParam[i] do
116 begin
117 Param[i].PType := literal;
118 case VType of
119 vtInteger: Param[i].Value := IntToStr(VInteger);
120 vtBoolean: Param[i].Value := BoolChar[VBoolean];
121 vtChar: if VChar = #0 then
122 Param[i].Value := ''
123 else
124 Param[i].Value := VChar;
125 //vtExtended: Param[i].Value := FloatToStr(VExtended^);
126 vtExtended: begin
127 TmpExt := VExtended^;
128 if(abs(TmpExt) < 0.0000000000001) then TmpExt := 0;
129 Param[i].Value := FloatToStr(TmpExt);
130 end;
131 vtString: with Param[i] do
132 begin
133 Value := VString^;
134 if (Length(Value) > 0) and (Value[1] = #1) then
135 begin
136 Value := Copy(Value, 2, Length(Value));
137 PType := reference;
138 end;
139 end;
140 vtPChar: Param[i].Value := StrPas(VPChar);
141 vtPointer: if VPointer = nil
142 then ClearParameters := True {Param[i].PType := null}
143 else raise Exception.Create('Pointer type must be nil.');
144 vtObject: if VObject is TStrings then SetList(TStrings(VObject), i);
145 vtAnsiString: with Param[i] do
146 begin
147 Value := string(VAnsiString);
148 if (Length(Value) > 0) and (Value[1] = #1) then
149 begin
150 Value := Copy(Value, 2, Length(Value));
151 PType := reference;
152 end;
153 end;
154 vtInt64: Param[i].Value := IntToStr(VInt64^);
155 else raise Exception.Create('Unable to pass parameter type to Broker.');
156 end; {case}
157 end; {for}
158 end; {with}
159 RPCLastCall := RPCName + ' (SetParam end)';
160end;
161
162{ public procedures and functions ----------------------------------------------------------- }
163
164function UpdateContext(NewContext: string): boolean;
165begin
166 if NewContext = uCurrentContext then
167 Result := TRUE
168 else
169 begin
170 Result := RPCBrokerV.CreateContext(NewContext);
171 if Result then
172 uCurrentContext := NewContext
173 else
174 if (NewContext <> uBaseContext) and RPCBrokerV.CreateContext(uBaseContext) then
175 uCurrentContext := uBaseContext
176 else
177 uCurrentContext := '';
178 end;
179end;
180
181function IsBaseContext: boolean;
182begin
183 Result := ((uCurrentContext = uBaseContext) or (uCurrentContext = ''));
184end;
185
186procedure CallBrokerInContext;
187var
188 AStringList: TStringList;
189 i, j: Integer;
190 x, y: string;
191begin
192 RPCLastCall := RPCBrokerV.RemoteProcedure + ' (CallBroker begin)';
193 if uShowRPCs then StatusText(RPCBrokerV.RemoteProcedure);
194 with RPCBrokerV do if not Connected then // happens if broker connection is lost
195 begin
196 ClearResults := True;
197 Exit;
198 end;
199 if uCallList.Count = uMaxCalls then
200 begin
201 AStringList := uCallList.Items[0];
202 AStringList.Free;
203 uCallList.Delete(0);
204 end;
205 AStringList := TStringList.Create;
206 AStringList.Add(RPCBrokerV.RemoteProcedure);
207 if uCurrentContext <> uBaseContext then
208 AStringList.Add('Context: ' + uCurrentContext);
209 AStringList.Add(' ');
210 AStringList.Add('Params ------------------------------------------------------------------');
211 with RPCBrokerV do for i := 0 to Param.Count - 1 do
212 begin
213 case Param[i].PType of
214 //global: x := 'global';
215 list: x := 'list';
216 literal: x := 'literal';
217 //null: x := 'null';
218 reference: x := 'reference';
219 undefined: x := 'undefined';
220 //wordproc: x := 'wordproc';
221 end;
222 AStringList.Add(x + #9 + Param[i].Value);
223 if Param[i].PType = list then
224 begin
225 for j := 0 to Param[i].Mult.Count - 1 do
226 begin
227 x := Param[i].Mult.Subscript(j);
228 y := Param[i].Mult[x];
229 AStringList.Add(#9 + '(' + x + ')=' + y);
230 end;
231 end;
232 end; {with...for}
233 //RPCBrokerV.Call;
234 try
235 RPCBrokerV.Call;
236 except
237 // The broker erroneously sets connected to false if there is any error (including an
238 // error on the M side). It should only set connection to false if there is no connection.
239 on E:EBrokerError do
240 begin
241 if E.Code = XWB_M_REJECT then
242 begin
243 x := 'An error occurred on the server.' + CRLF + CRLF + E.Action;
244 Application.MessageBox(PChar(x), 'Server Error', MB_OK);
245 end
246 else raise;
247 (*
248 case E.Code of
249 XWB_M_REJECT: begin
250 x := 'An error occurred on the server.' + CRLF + CRLF + E.Action;
251 Application.MessageBox(PChar(x), 'Server Error', MB_OK);
252 end;
253 else begin
254 x := 'An error occurred with the network connection.' + CRLF +
255 'Action was: ' + E.Action + CRLF + 'Code was: ' + E.Mnemonic +
256 CRLF + CRLF + 'Application cannot continue.';
257 Application.MessageBox(PChar(x), 'Network Error', MB_OK);
258 end;
259 end;
260 *)
261 // make optional later...
262 if not RPCBrokerV.Connected then Application.Terminate;
263 end;
264 end;
265 AStringList.Add(' ');
266 AStringList.Add('Results -----------------------------------------------------------------');
267 FastAddStrings(RPCBrokerV.Results, AStringList);
268 uCallList.Add(AStringList);
269 if uShowRPCs then StatusText('');
270 RPCLastCall := RPCBrokerV.RemoteProcedure + ' (completed)';
271end;
272
273procedure CallBroker;
274begin
275 UpdateContext(uBaseContext);
276 CallBrokerInContext;
277end;
278
279procedure SetBrokerServer(const AName: string; APort: Integer; WantDebug: Boolean);
280{ makes the initial connection to a server }
281begin
282 EnsureBroker;
283 with RPCBrokerV do
284 begin
285 Server := AName;
286 if APort > 0 then ListenerPort := APort;
287 DebugMode := WantDebug;
288 Connected := True;
289 end;
290end;
291
292function AuthorizedOption(const OptionName: string): Boolean;
293{ checks to see if the user is authorized to use this application }
294begin
295 EnsureBroker;
296 Result := RPCBrokerV.CreateContext(OptionName);
297 if Result then
298 begin
299 if (uBaseContext = '') then
300 uBaseContext := OptionName;
301 uCurrentContext := OptionName;
302 end;
303end;
304
305function ConnectToServer(const OptionName: string): Boolean;
306{ establish initial connection to server using optional command line parameters and check that
307 this application (option) is allowed for this user }
308var
309 WantDebug: Boolean;
310 AServer, APort, x: string;
311 i, ModalResult: Integer;
312begin
313 Result := False;
314 WantDebug := False;
315 AServer := '';
316 APort := '';
317 for i := 1 to ParamCount do // params may be: S[ERVER]=hostname P[ORT]=port DEBUG
318 begin
319 if UpperCase(ParamStr(i)) = 'DEBUG' then WantDebug := True;
320 if UpperCase(ParamStr(i)) = 'SHOWRPCS' then uShowRPCs := True;
321 x := UpperCase(Piece(ParamStr(i), '=', 1));
322 if (x = 'S') or (x = 'SERVER') then AServer := Piece(ParamStr(i), '=', 2);
323 if (x = 'P') or (x = 'PORT') then APort := Piece(ParamStr(i), '=', 2);
324 end;
325 if (AServer = '') or (APort = '') then
326 begin
327 ModalResult := GetServerInfo(AServer, APort);
328 if ModalResult = mrCancel then Exit;
329 end;
330 // use try..except to work around errors in the Broker SignOn screen
331 try
332 SetBrokerServer(AServer, StrToIntDef(APort, 9200), WantDebug);
333 Result := AuthorizedOption(OptionName);
334 if Result then Result := RPCBrokerV.Connected;
335 RPCBrokerV.RPCTimeLimit := 300;
336 except
337 on E:EBrokerError do
338 begin
339 if E.Code <> XWB_BadSignOn then InfoBox(E.Message, 'Error', MB_OK or MB_ICONERROR);
340 Result := False;
341 end;
342 end;
343end;
344
345function MRef(glvn: string): string;
346{ prepends ASCII 1 to string, allows SetParams to interpret as an M reference }
347begin
348 Result := #1 + glvn;
349end;
350
351function GetRPCCursor: TCursor;
352var
353 pt: TPoint;
354begin
355 Result := crHourGlass;
356 if assigned(AppStartedCursorForm) and (AppStartedCursorForm.Visible) then
357 begin
358 pt := Mouse.CursorPos;
359 if PtInRect(AppStartedCursorForm.BoundsRect, pt) then
360 Result := crAppStart;
361 end;
362end;
363
364procedure CallV(const RPCName: string; const AParam: array of const);
365{ calls the broker leaving results in results property which must be read by caller }
366var
367 SavedCursor: TCursor;
368begin
369 SavedCursor := Screen.Cursor;
370 Screen.Cursor := GetRPCCursor;
371 SetParams(RPCName, AParam);
372 CallBroker; //RPCBrokerV.Call;
373 Screen.Cursor := SavedCursor;
374end;
375
376function sCallV(const RPCName: string; const AParam: array of const): string;
377{ calls the broker and returns a scalar value. }
378var
379 SavedCursor: TCursor;
380begin
381 SavedCursor := Screen.Cursor;
382 Screen.Cursor := GetRPCCursor;
383 SetParams(RPCName, AParam);
384 CallBroker; //RPCBrokerV.Call;
385 if RPCBrokerV.Results.Count > 0 then Result := RPCBrokerV.Results[0] else Result := '';
386 Screen.Cursor := SavedCursor;
387end;
388
389procedure tCallV(ReturnData: TStrings; const RPCName: string; const AParam: array of const);
390{ calls the broker and returns TStrings data }
391var
392 SavedCursor: TCursor;
393begin
394 if ReturnData = nil then raise Exception.Create('TString not created');
395 SavedCursor := Screen.Cursor;
396 Screen.Cursor := GetRPCCursor;
397 SetParams(RPCName, AParam);
398 CallBroker; //RPCBrokerV.Call;
399 FastAssign(RPCBrokerV.Results, ReturnData);
400 Screen.Cursor := SavedCursor;
401end;
402
403(* uncomment if these are needed -
404
405function pCallV(const RPCName: string; const AParam: array of const): PChar;
406{ Calls the Broker. Result is a PChar containing raw Broker data. }
407{ -- Caller must dispose the string that is returned -- }
408var
409 SavedCursor: TCursor;
410begin
411 SavedCursor := Screen.Cursor;
412 Screen.Cursor := GetRPCCursor;
413 SetParams(RPCName, AParam);
414 RPCBrokerV.Call;
415 pCallV := StrNew(RPCBrokerV.Results.GetText);
416 Screen.Cursor := SavedCursor;
417end;
418
419procedure wCallV(AControl: TControl; const RPCName: string; const AParam: array of const);
420{ Calls the Broker. Places data into control (wrapped). }
421var
422 BufPtr: PChar;
423begin
424 BufPtr := pCallV(RPCName, AParam);
425 WrapWP(BufPtr);
426 AControl.SetTextBuf(BufPtr);
427 StrDispose(BufPtr);
428end;
429
430procedure WrapWP(Buf: pChar);
431{ Iterates through Buf and wraps text in the same way that FM wraps text. }
432var
433 PSub: PChar;
434begin
435 PSub := StrScan(Buf, #13);
436 while PSub <> nil do
437 begin
438 if Ord(PSub[2]) > 32 then
439 begin
440 StrMove(PSub, PSub + SizeOf(Char), StrLen(PSub));
441 PSub[0] := #32;
442 end
443 else repeat Inc(PSub, SizeOf(Char)) until (Ord(PSub[0]) > 32) or (PSub = StrEnd(PSub));
444 PSub := StrScan(PSub, #13);
445 end;
446end;
447
448*)
449
450function RetainedRPCCount: Integer;
451begin
452 Result := uCallList.Count;
453end;
454
455procedure SetRetainedRPCMax(Value: Integer);
456begin
457 if Value > 0 then uMaxCalls := Value;
458end;
459
460function GetRPCMax: integer;
461begin
462 Result := uMaxCalls;
463end;
464
465procedure LoadRPCData(Dest: TStrings; ID: Integer);
466begin
467 if (ID > -1) and (ID < uCallList.Count) then FastAssign(TStringList(uCallList.Items[ID]), Dest);
468end;
469
470function DottedIPStr: string;
471{ return the IP address of the local machine as a string in dotted form: nnn.nnn.nnn.nnn }
472const
473 WINSOCK1_1 = $0101; // minimum required version of WinSock
474 SUCCESS = 0; // value returned by WinSock functions if no error
475var
476 //WSAData: TWSAData; // structure to hold startup information
477 HostEnt: PHostEnt; // pointer to Host Info structure (see WinSock 1.1, page 60)
478 IPAddr: PInAddr; // pointer to IP address in network order (4 bytes)
479 LocalName: array[0..255] of Char; // buffer for the name of the client machine
480begin
481 Result := 'No IP Address';
482 // ensure the Winsock DLL has been loaded (should be if there is a broker connection)
483 //if WSAStartup(WINSOCK1_1, WSAData) <> SUCCESS then Exit;
484 //try
485 // get the name of the client machine
486 if gethostname(LocalName, SizeOf(LocalName) - 1) <> SUCCESS then Exit;
487 // get information about the client machine (contained in a record of type THostEnt)
488 HostEnt := gethostbyname(LocalName);
489 if HostEnt = nil then Exit;
490 // get a pointer to the four bytes that contain the IP address
491 // Dereference HostEnt to get the THostEnt record. In turn, dereference the h_addr_list
492 // field to get a pointer to the IP address. The pointer to the IP address is type PChar,
493 // so it needs to be typecast as PInAddr in order to make the call to inet_ntoa.
494 IPAddr := PInAddr(HostEnt^.h_addr_list^);
495 // Dereference IPAddr (which is a PChar typecast as PInAddr) to get the 4 bytes that need
496 // to be passed to inet_ntoa. A string with the IP address in dotted format is returned.
497 Result := inet_ntoa(IPAddr^);
498 //finally
499 // causes the reference counter in Winsock (set by WSAStartup, above) to be decremented
500 //WSACleanup;
501 //end;
502end;
503
504procedure RPCIdleCallDone(Msg: string);
505begin
506 RPCBrokerV.ClearResults := True;
507end;
508
509procedure CallRPCWhenIdle(CallProc: TORIdleCallProc; Msg: String);
510begin
511 CallWhenIdleNotifyWhenDone(CallProc, RPCIdleCallDone, Msg);
512end;
513
514initialization
515 RPCBrokerV := nil;
516 RPCLastCall := 'No RPCs called';
517 uCallList := TList.Create;
518 uMaxCalls := 10;
519 uShowRPCs := False;
520
521finalization
522 while uCallList.Count > 0 do
523 begin
524 TStringList(uCallList.Items[0]).Free;
525 uCallList.Delete(0);
526 end;
527 uCallList.Free;
528
529end.
Note: See TracBrowser for help on using the repository browser.