source: cprs/branches/foia-cprs/CPRS-Lib/ORNet.pas@ 819

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

Uploading from OR_30_258

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