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

Last change on this file since 736 was 654, checked in by Kevin Toppenberg, 15 years ago

Added HTML templating

File size: 17.1 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);
28procedure EnsureBroker;
29procedure RPCCallsClear; //kt added
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
49 DateUtils, //kt
50 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;
191 Time1,Time2 : TDateTime; //kt
192begin
193 RPCLastCall := RPCBrokerV.RemoteProcedure + ' (CallBroker begin)';
194 if uShowRPCs then StatusText(RPCBrokerV.RemoteProcedure);
195 with RPCBrokerV do if not Connected then // happens if broker connection is lost
196 begin
197 ClearResults := True;
198 Exit;
199 end;
200 if uCallList.Count = uMaxCalls then
201 begin
202 AStringList := uCallList.Items[0];
203 AStringList.Free;
204 uCallList.Delete(0);
205 end;
206 AStringList := TStringList.Create;
207 AStringList.Add(RPCBrokerV.RemoteProcedure);
208 if uCurrentContext <> uBaseContext then
209 AStringList.Add('Context: ' + uCurrentContext);
210 Time1 := GetTime; //kt
211 AStringList.Add('Called at: '+ TimeToStr(Time1)); //kt
212 AStringList.Add(' ');
213 AStringList.Add('Params ------------------------------------------------------------------');
214 with RPCBrokerV do for i := 0 to Param.Count - 1 do
215 begin
216 case Param[i].PType of
217 //global: x := 'global';
218 list: x := 'list';
219 literal: x := 'literal';
220 //null: x := 'null';
221 reference: x := 'reference';
222 undefined: x := 'undefined';
223 //wordproc: x := 'wordproc';
224 end;
225 AStringList.Add(x + #9 + Param[i].Value);
226 if Param[i].PType = list then
227 begin
228 for j := 0 to Param[i].Mult.Count - 1 do
229 begin
230 x := Param[i].Mult.Subscript(j);
231 y := Param[i].Mult[x];
232 AStringList.Add(#9 + '(' + x + ')=' + y);
233 end;
234 end;
235 end; {with...for}
236 //RPCBrokerV.Call;
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 DottedIPStr: string;
464{ return the IP address of the local machine as a string in dotted form: nnn.nnn.nnn.nnn }
465const
466 WINSOCK1_1 = $0101; // minimum required version of WinSock
467 SUCCESS = 0; // value returned by WinSock functions if no error
468var
469 //WSAData: TWSAData; // structure to hold startup information
470 HostEnt: PHostEnt; // pointer to Host Info structure (see WinSock 1.1, page 60)
471 IPAddr: PInAddr; // pointer to IP address in network order (4 bytes)
472 LocalName: array[0..255] of Char; // buffer for the name of the client machine
473begin
474 Result := 'No IP Address';
475 // ensure the Winsock DLL has been loaded (should be if there is a broker connection)
476 //if WSAStartup(WINSOCK1_1, WSAData) <> SUCCESS then Exit;
477 //try
478 // get the name of the client machine
479 if gethostname(LocalName, SizeOf(LocalName) - 1) <> SUCCESS then Exit;
480 // get information about the client machine (contained in a record of type THostEnt)
481 HostEnt := gethostbyname(LocalName);
482 if HostEnt = nil then Exit;
483 // get a pointer to the four bytes that contain the IP address
484 // Dereference HostEnt to get the THostEnt record. In turn, dereference the h_addr_list
485 // field to get a pointer to the IP address. The pointer to the IP address is type PChar,
486 // so it needs to be typecast as PInAddr in order to make the call to inet_ntoa.
487 IPAddr := PInAddr(HostEnt^.h_addr_list^);
488 // Dereference IPAddr (which is a PChar typecast as PInAddr) to get the 4 bytes that need
489 // to be passed to inet_ntoa. A string with the IP address in dotted format is returned.
490 Result := inet_ntoa(IPAddr^);
491 //finally
492 // causes the reference counter in Winsock (set by WSAStartup, above) to be decremented
493 //WSACleanup;
494 //end;
495end;
496
497procedure RPCIdleCallDone(Msg: string);
498begin
499 RPCBrokerV.ClearResults := True;
500end;
501
502procedure CallRPCWhenIdle(CallProc: TORIdleCallProc; Msg: String);
503begin
504 CallWhenIdleNotifyWhenDone(CallProc, RPCIdleCallDone, Msg);
505end;
506
507procedure RPCCallsClear;
508//kt Added entire fuction.
509begin
510 while uCallList.Count > 0 do
511 begin
512 TStringList(uCallList.Items[0]).Free;
513 uCallList.Delete(0);
514 end;
515end;
516
517initialization
518 RPCBrokerV := nil;
519 RPCLastCall := 'No RPCs called';
520 uCallList := TList.Create;
521 uMaxCalls := 150; //kt 10
522 uShowRPCs := False;
523
524finalization
525 { //kt commented out
526 while uCallList.Count > 0 do
527 begin
528 TStringList(uCallList.Items[0]).Free;
529 uCallList.Delete(0);
530 end;
531 }
532 RPCCallsClear; //kt added
533 uCallList.Free;
534
535end.
Note: See TracBrowser for help on using the repository browser.