source: cprs/branches/HealthSevak-CPRS/BDK50/BDK32_P50/Samples D2006/RPCBroker/BrokerEx/fBrokerExample.pas@ 1727

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

Committing the files for first time to this new branch
File size: 16.8 KB
Line 
1{**************************************************
2RPC Broker Example form ver. 1.1 9/3/97
3 Broker Development Team
4 San Francisco IRM Field Office, Dept. of Veterans Affairs
5
6Disclaimer:
7 This example does not attempt to teach general Delphi and M programming.
8 We intentionally removed any safeguards from the code that prevents
9 passing values that are too small or too large. Therefore, the important
10 code remains uncluttered and the programmer is free to experiment and
11 push the program beyond its limits.
12
13Purpose:
14 This sample application is an example of how to program client/server
15 applications in Delphi and M using the RPC Broker. The demonstrated features
16 include:
17 - Connecting to an M server
18 - Creating an application context
19 - Using the GetServerInfo function
20 - Displaying the VistA splash screen
21 - Setting the TRPCBroker Param property for each Param PType (literal,
22 reference, list)
23 - Calling RPCs with the Call method
24 - Calling RPCs with the lstCall and strCall methods
25
26 We encourage you to study the Delphi and M source code to see how the
27 Broker is used to accomplish these tasks. Try changing some of the
28 RPCBroker1 component properties to see what happens. Also, try other
29 values in the fields of the remote procedure records in the
30 REMOTE PROCEDURE file.
31
32Warning: "Get list" and "Sort numbers" tabs can potentially take excessively
33large data samples which can either crash server process or cause the
34connection timeout. Final note, memory allocation errors are not recorded
35in the Kernel error trap. They are recorded in the operating system error
36trap.
37
38Context option for this application:
39 XWB BROKER EXAMPLE
40
41Remote procedures used:
42 XWB EXAMPLE ECHO STRING
43 XWB EXAMPLE GET LIST
44 XWB EXAMPLE SORT NUMBERS
45 XWB EXAMPLE WPTEXT
46 XWB GET VARIABLE VALUE
47
48Server M routine:
49 XWBEXMPL
50**************************************************}
51
52{************************************************
53
54 For patch XWB*1.1*50, code has been added to show
55 handling within a program of SSH connectivity.
56
57 Two menu items were added under the Options menu
58 to permit specification of Secure connection with
59 SSH of either Attachmate Reflection or Plink.
60 When one of these is selected, it clears settings
61 for the properties SSHUser, SSHPort, and SSHPw.
62
63 Also, the ButtonConnectClick event checks for whether
64 the server and/or port number have changed, and if
65 so, it clears the settings for the same properties.
66
67 A user may select one SSH connection type, and connect
68 and re-connect to the same location without having
69 to enter the properties each time, but if a server,
70 port, or type of connection changes, it will clear
71 the properties so the user has to specify new values.
72
73*************************************************}
74unit fBrokerExample;
75
76interface
77
78uses
79 SysUtils,Forms, StdCtrls,Graphics, Dialogs, WinTypes,
80 Controls, Classes, ExtCtrls, TRPCB, XWBut1, MFunStr, Menus, WinProcs,
81 RpcConf1, Spin, ComCtrls, fVistAAbout, Buttons,
82 ActiveX, ActnList, OleCtrls, VERGENCECONTEXTORLib_TLB, CCOWRPCBroker;
83
84type
85 TfrmBrokerExample = class(TForm)
86 GroupBox2: TGroupBox;
87 Label2: TLabel;
88 Label3: TLabel;
89 MainMenu1: TMainMenu;
90 Help1: TMenuItem;
91 AboutExample: TMenuItem;
92 btnConnect: TButton;
93 edtPort: TEdit;
94 edtServer: TEdit;
95 PageControl1: TPageControl;
96 TabSheet1: TTabSheet;
97 TabSheet2: TTabSheet;
98 TabSheet3: TTabSheet;
99 TabSheet4: TTabSheet;
100 TabSheet5: TTabSheet;
101 lblSend: TLabel;
102 edtStrOrig: TEdit;
103 lblReturn: TLabel;
104 edtStrRtrn: TEdit;
105 btnEchoString: TButton;
106 lblList: TLabel;
107 Label1: TLabel;
108 edtReference: TEdit;
109 Label4: TLabel;
110 edtValue: TEdit;
111 btnPassByRef: TButton;
112 lstData: TListBox;
113 Label5: TLabel;
114 btnGetList: TButton;
115 btnWPText: TButton;
116 Label6: TLabel;
117 lstSorted: TListBox;
118 btnSortNum: TButton;
119 spnNumbers: TSpinEdit;
120 Label7: TLabel;
121 rgrDirection: TRadioGroup;
122 RadioButton1: TRadioButton;
123 RadioButton2: TRadioButton;
124 spnLines: TSpinEdit;
125 spnKbytes: TSpinEdit;
126 Timer1: TTimer;
127 mmoText: TMemo;
128 lblStatus: TLabel;
129 BitBtn1: TBitBtn;
130 btnGetServerInfo: TBitBtn;
131 Memo1: TMemo;
132 Memo2: TMemo;
133 Memo3: TMemo;
134 Memo4: TMemo;
135 Memo5: TMemo;
136 rgArrayType: TRadioGroup;
137 cbxBackwardCompatible: TCheckBox;
138 mnuOptions: TMenuItem;
139 mnuOptBackwardCompatible: TMenuItem;
140 mnuOptDebugMode: TMenuItem;
141 mnuOptUserContext: TMenuItem;
142 mnuOptOldConnectionOnly: TMenuItem;
143 ActionList1: TActionList;
144 actBackwardCompatible: TAction;
145 actOldConnectionOnly: TAction;
146 actDebugMode: TAction;
147 actUserContext: TAction;
148 mnuOptUseSSHAttachmate: TMenuItem;
149 mnuOptUseSSHPlink: TMenuItem;
150 actUseSSHAttachmate: TAction;
151 actUseSSHPlink: TAction;
152 RPCBroker1: TRPCBroker;
153 timerHalt: TTimer;
154 procedure timerHaltTimer(Sender: TObject);
155 procedure AboutExampleClick(Sender: TObject);
156 procedure btnEchoStringClick(Sender: TObject);
157 procedure btnConnectClick(Sender: TObject);
158 procedure btnPassByRefClick(Sender: TObject);
159 procedure btnGetListClick(Sender: TObject);
160 procedure btnSortNumClick(Sender: TObject);
161 procedure btnWPTextClick(Sender: TObject);
162 procedure Timer1Timer(Sender: TObject);
163 procedure btnGetServerInfoClick(Sender: TObject);
164 procedure edtServerChange(Sender: TObject);
165 procedure FormCreate(Sender: TObject);
166 procedure rgArrayTypeClick(Sender: TObject);
167 procedure actBackwardCompatibleExecute(Sender: TObject);
168 procedure actDebugModeExecute(Sender: TObject);
169 procedure actUserContextExecute(Sender: TObject);
170 procedure actOldConnectionOnlyExecute(Sender: TObject);
171 procedure actUseSSHAttachmateExecute(Sender: TObject);
172 procedure actUseSSHPlinkExecute(Sender: TObject);
173 protected
174 // MAKE IT SO CAN CHECK ON CHANGE IN SERVER/PORT
175 lastServer: String;
176 lastPort: Integer;
177 public
178 procedure OnCCOWCommit(Sender: TObject); // CCOW related
179 procedure HandlePendingEvent(Sender: TObject; const aContextItemCollection:
180 IDispatch);
181end;
182
183
184
185var
186 frmBrokerExample: TfrmBrokerExample;
187 ContextorControl1: TContextorControl; // CCOW related
188
189
190implementation
191
192uses fOKToTerminate;
193
194{$R *.DFM}
195
196procedure TfrmBrokerExample.btnEchoStringClick(Sender: TObject);
197begin
198 RPCBroker1.RemoteProcedure := 'XWB EXAMPLE ECHO STRING';
199 RPCBroker1.Param[0].Value := edtStrOrig.Text;
200 RPCBroker1.Param[0].PType := literal;
201 RPCBroker1.Call; //execute RPC
202 edtStrRtrn.Text := RPCBroker1.Results[0]; //for single value use Results[0]
203end;
204
205
206
207procedure TfrmBrokerExample.btnPassByRefClick(Sender: TObject);
208begin
209 RPCBroker1.RemoteProcedure := 'XWB GET VARIABLE VALUE';
210 RPCBroker1.Param[0].Value := edtReference.Text;
211 RPCBroker1.Param[0].PType := reference;
212 edtValue.Text := RPCBroker1.strCall; //execute RPC and show result in one call
213end;
214
215
216
217procedure TfrmBrokerExample.btnGetListClick(Sender: TObject);
218begin
219 RPCBroker1.RemoteProcedure := 'XWB EXAMPLE GET LIST';
220 if RadioButton1.Checked then begin
221 RPCBroker1.Param[0].Value := 'LINES';
222 RPCBroker1.Param[0].PType := literal;
223 RPCBroker1.Param[1].Value := IntToStr(spnLines.Value);
224 RPCBroker1.Param[1].PType := literal;
225 end
226 else begin
227 RPCBroker1.Param[0].Value := 'KILOBYTES';
228 RPCBroker1.Param[0].PType := literal;
229 RPCBroker1.Param[1].Value := IntToStr(spnKbytes.Value);
230 RPCBroker1.Param[1].PType := literal
231 end;
232 RPCBroker1.Call; //execute RPC
233 lstData.Items := RPCBroker1.Results; //show results of the call
234end;
235
236
237
238procedure TfrmBrokerExample.btnWPTextClick(Sender: TObject);
239begin
240 RPCBroker1.RemoteProcedure := 'XWB EXAMPLE WPTEXT';
241 RPCBroker1.lstCall(mmoText.Lines); //execute RPC and show results in one call
242end;
243
244
245
246procedure TfrmBrokerExample.btnSortNumClick(Sender: TObject);
247var
248 I, SaveRPCTimeLimit, DefaultRange: integer;
249begin
250 lblStatus.Visible := True; //turn on status label
251 lblStatus.Caption := 'building'; //tell user what's happenning
252 Application.ProcessMessages; //give Windows chance to paint
253 with RPCBroker1 do
254 begin
255 if rgArrayType.ItemIndex = 0 then
256 begin
257 RemoteProcedure := 'XWB EXAMPLE SORT NUMBERS';
258 DefaultRange := 10000;
259 end
260 else
261 begin
262 RemoteProcedure := 'XWB EXAMPLE GLOBAL SORT';
263 DefaultRange := 100000;
264 end;
265
266 if rgrDirection.ItemIndex = 0 then Param[0].Value := 'LO'
267 else Param[0].Value := 'HI';
268 Param[0].PType := literal;
269 with Param[1] do begin
270 if rgArrayType.ItemIndex = 0 then
271 PType := list //tells Broker to pass Mult
272 else
273 PType := global;
274 for I := 0 to spnNumbers.Value - 1 do //build Mult one by one
275 Mult['"A'+IntToStr(I)+'"'] := IntToStr(Random(DefaultRange)+1); //subscript and value are strings!
276 end;
277 lblStatus.Caption := 'RPC running';
278 Application.ProcessMessages; //give Windows chance to paint
279 SaveRPCTimeLimit := RPCTimeLimit;
280 RPCTimeLimit := spnNumbers.Value div 10; //adjust in case a lot of numbers
281 Call; //execute RPC
282 lstSorted.Items := Results; //show results of the call
283 RPCTimeLimit := SaveRPCTimeLimit; //restore original value
284 end;
285 lblStatus.Visible := False; //turn off status label
286end;
287
288
289
290procedure TfrmBrokerExample.btnConnectClick(Sender: TObject);
291begin
292 if btnConnect.Caption = '&Connect' then
293 begin //connect
294 RpcBroker1.IsBackwardCompatibleConnection := actBackwardCompatible.Checked;
295 RpcBroker1.OldConnectionOnly := actOldConnectionOnly.Checked;
296 RpcBroker1.DebugMode := actDebugMode.Checked;
297 if RpcBroker1.IsBackwardCompatibleConnection or RpcBroker1.OldConnectionOnly then
298 begin
299 rgArrayType.ItemIndex := 0;
300 rgArrayType.Enabled := False;
301 end
302 else
303 begin
304 rgArrayType.Enabled := True;
305 end;
306
307 // *********************** CCOW User Context ****************************
308 if actUserContext.Checked then
309 begin
310 if (RPCBroker1.Contextor = nil) then
311 begin
312 if ContextorControl1 = nil then
313 begin
314 try
315 ContextorControl1 := TContextorControl.Create(Self);
316 ContextorControl1.OnCommitted := OnCCOWCommit;
317 ContextorControl1.OnPending := HandlePendingEvent;
318 ContextorControl1.Run('CCOWTerm#', '', TRUE, '*');
319 except
320 ShowMessage('Problem with Contextor.Run');
321 ContextorControl1.Free;
322 ContextorControl1 := nil;
323 end;
324 end;
325 end;
326 RPCBroker1.Contextor := ContextorControl1;
327 end
328 else
329 RPCBroker1.Contextor := nil;
330
331 // *********************** End CCOW User Context *************************
332
333 RPCBroker1.ClearParameters := True; //try False, see what happens
334 try
335 RPCBroker1.Connected := True; //establish connection
336 if not RPCBroker1.CreateContext('XWB BROKER EXAMPLE') then
337 ShowMessage('Context could not be created!');
338 except
339 on e: Exception do
340 ShowMessage('Error: ' + e.Message);
341 end;
342 end
343 else //disconnect
344 RPCBroker1.Connected := False;
345end;
346
347
348
349procedure TfrmBrokerExample.btnGetServerInfoClick(Sender: TObject);
350var
351 strServer, strPort: string;
352begin
353 if GetServerInfo(strServer, strPort)<> mrCancel then
354 begin {getsvrinfo}
355 edtServer.Text := strServer; //use chosen server
356 edtPort.Text := strPort; //use chosen port
357 end;
358end;
359
360
361
362procedure TfrmBrokerExample.edtServerChange(Sender: TObject);
363begin
364 RPCBroker1.Server := edtServer.Text; //use specified server name/addr
365 RPCBroker1.ListenerPort := StrToInt(edtPort.Text); //use specified port
366end;
367
368
369
370procedure TfrmBrokerExample.Timer1Timer(Sender: TObject);
371begin
372 if RPCBroker1.Connected then begin
373 btnConnect.Caption := '&Disconnect';
374 btnConnect.Default := False;
375 mnuOptions.Enabled := False;
376 cbxBackwardCompatible.Enabled := False;
377 Label3.Caption := 'Connected';
378 Label3.Font.Color := clLime; // clGreen; // went to lime for higher contrast at some of the High contrast desktops
379 end
380 else begin
381 btnConnect.Caption := '&Connect';
382 btnConnect.Default := True;
383 mnuOptions.Enabled := True;
384 if not actOldConnectionOnly.Checked then
385 cbxBackwardCompatible.Enabled := True;
386 Label3.Caption := 'Disconnected';
387 Label3.Font.Color := clRed; // Stayed with Red, generated a high contrast across all of the various combinations
388 // Attempted to use clHighlight, but it did not show up like a highlight.
389 end;
390end;
391
392procedure TfrmBrokerExample.timerHaltTimer(Sender: TObject);
393begin
394 Halt;
395end;
396
397procedure TfrmBrokerExample.AboutExampleClick(Sender: TObject);
398begin
399 ShowAboutBox;
400end;
401
402// 080620 - added code below other the commented secion on coinitialize to
403// identify and use port and server specification on the command line.
404procedure TfrmBrokerExample.FormCreate(Sender: TObject);
405var
406 i: Integer;
407 text: String;
408begin
409 CoInitialize(nil); // needed for CCOW
410 for i := 0 to ParamCount do
411 begin
412 text := ParamStr(i);
413 if (Pos('P=',UpperCase(ParamStr(i))) = 1) then
414 begin
415 edtPort.Text := Copy(ParamStr(i),3,Length(ParamStr(i)));
416 end
417 else if (Pos('S=',UpperCase(ParamStr(i))) = 1) then
418 begin
419 edtServer.Text := Copy(ParamStr(i),3,Length(ParamStr(i)));
420 end;
421 end;
422 self.ShowHint := True;
423 Application.ShowHint := True;
424end;
425
426procedure TfrmBrokerExample.rgArrayTypeClick(Sender: TObject);
427begin
428 if rgArrayType.ItemIndex = 0 then
429 spnNumbers.Value := 500
430 else
431 spnNumbers.Value := 5000;
432end;
433
434procedure TfrmBrokerExample.actBackwardCompatibleExecute(Sender: TObject);
435begin
436 if actBackwardCompatible.Checked then
437 actBackwardCompatible.Checked := False
438 else
439 actBackwardCompatible.Checked := True;
440end;
441
442procedure TfrmBrokerExample.actDebugModeExecute(Sender: TObject);
443begin
444 if actDebugMode.Checked then
445 actDebugMode.Checked := False
446 else
447 actDebugMode.Checked := True;
448end;
449
450procedure TfrmBrokerExample.actUserContextExecute(Sender: TObject);
451begin
452 if actuserContext.Checked then
453 actUserContext.Checked := False
454 else
455 actUserContext.Checked := True;
456end;
457
458procedure TfrmBrokerExample.actOldConnectionOnlyExecute(Sender: TObject);
459begin
460 if actOldConnectionOnly.Checked then
461 begin
462 actOldConnectionOnly.Checked := False;
463 actBackwardCompatible.Enabled := True;
464 end
465 else
466 begin
467 actOldConnectionOnly.Checked := True;
468 actBackwardCompatible.Enabled := False;
469 end;
470end;
471
472procedure TfrmBrokerExample.actUseSSHAttachmateExecute(Sender: TObject);
473begin
474 if not actUseSSHAttachmate.Checked then
475 begin
476 RPCBroker1.UseSecureConnection := secureAttachmate;
477 actUseSSHAttachmate.Checked := true;
478 actUseSSHPlink.Checked := false;
479 RPCBroker1.SSHport := '';
480 RPCBroker1.SSHUser := '';
481 RPCBroker1.SSHpw := '';
482 end
483 else
484 begin
485 RPCBroker1.UseSecureConnection := secureNone;
486 actUseSSHAttachmate.Checked := false;
487 end
488end;
489
490procedure TfrmBrokerExample.actUseSSHPlinkExecute(Sender: TObject);
491begin
492 if not actUseSSHPlink.Checked then
493 begin
494 RPCBroker1.UseSecureConnection := securePlink;
495 actUseSSHPlink.Checked := true;
496 actUseSSHAttachmate.Checked := false;
497 RPCBroker1.SSHport := '';
498 RPCBroker1.SSHUser := '';
499 RPCBroker1.SSHpw := '';
500 end
501 else
502 begin
503 RPCBroker1.UseSecureConnection := secureNone;
504 actUseSSHPlink.Checked := false;
505 end
506end;
507
508procedure TfrmBrokerExample.OnCCOWCommit(Sender: TObject);
509begin
510{ // uses CCOWRPCBroker
511 if RpcBroker1.WasUserDefined and RpcBroker1.IsUserCleared then
512 Halt;
513}
514end;
515
516procedure TfrmBrokerExample.HandlePendingEvent(Sender: TObject; const
517 aContextItemCollection: IDispatch);
518var
519 data : IContextItemCollection;
520begin
521 data := IContextItemCollection(aContextItemCollection) ;
522 if RPCBroker1.IsUserContextPending(data) then
523 begin
524 frmOkToTerminate := TfrmOkToTerminate.Create(Self);
525 try
526 if not (frmOkToTerminate.ShowModal = mrOK) then
527 ContextorControl1.SetSurveyResponse('No Way')
528 else
529 timerHalt.Enabled := True;
530 finally
531 frmOkToTerminate.Free;
532 end;
533 end;
534end;
535
536
537end.
538
539
Note: See TracBrowser for help on using the repository browser.