source: cprs/branches/tmg-cprs/CPRS-Lib/ORNet.pas@ 1722

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

Bug fixes. Improved Adding Image

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