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

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

Committing the files for first time to this new branch
File size: 15.9 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;
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 RPCBroker1: TRPCBroker;
149 mnuOptUseSSHAttachmate: TMenuItem;
150 mnuOptUseSSHPlink: TMenuItem;
151 actUseSSHAttachmate: TAction;
152 actUseSSHPlink: TAction;
153 procedure AboutExampleClick(Sender: TObject);
154 procedure btnEchoStringClick(Sender: TObject);
155 procedure btnConnectClick(Sender: TObject);
156 procedure btnPassByRefClick(Sender: TObject);
157 procedure btnGetListClick(Sender: TObject);
158 procedure btnSortNumClick(Sender: TObject);
159 procedure btnWPTextClick(Sender: TObject);
160 procedure Timer1Timer(Sender: TObject);
161 procedure btnGetServerInfoClick(Sender: TObject);
162 procedure edtServerChange(Sender: TObject);
163 procedure FormCreate(Sender: TObject);
164 procedure rgArrayTypeClick(Sender: TObject);
165 procedure actBackwardCompatibleExecute(Sender: TObject);
166 procedure actDebugModeExecute(Sender: TObject);
167 procedure actUserContextExecute(Sender: TObject);
168 procedure actOldConnectionOnlyExecute(Sender: TObject);
169 procedure actUseSSHAttachmateExecute(Sender: TObject);
170 procedure actUseSSHPlinkExecute(Sender: TObject);
171 protected
172 // MAKE IT SO CAN CHECK ON CHANGE IN SERVER/PORT
173 lastServer: String;
174 lastPort: Integer;
175 public
176 procedure OnCCOWCommit(Sender: TObject); // CCOW related
177end;
178
179
180
181var
182 frmBrokerExample: TfrmBrokerExample;
183 ContextorControl1: TContextorControl; // CCOW related
184
185
186implementation
187
188{$R *.DFM}
189
190procedure TfrmBrokerExample.btnEchoStringClick(Sender: TObject);
191begin
192 RPCBroker1.RemoteProcedure := 'XWB EXAMPLE ECHO STRING';
193 RPCBroker1.Param[0].Value := edtStrOrig.Text;
194 RPCBroker1.Param[0].PType := literal;
195 RPCBroker1.Call; //execute RPC
196 edtStrRtrn.Text := RPCBroker1.Results[0]; //for single value use Results[0]
197end;
198
199
200
201procedure TfrmBrokerExample.btnPassByRefClick(Sender: TObject);
202begin
203 RPCBroker1.RemoteProcedure := 'XWB GET VARIABLE VALUE';
204 RPCBroker1.Param[0].Value := edtReference.Text;
205 RPCBroker1.Param[0].PType := reference;
206 edtValue.Text := RPCBroker1.strCall; //execute RPC and show result in one call
207end;
208
209
210
211procedure TfrmBrokerExample.btnGetListClick(Sender: TObject);
212begin
213 RPCBroker1.RemoteProcedure := 'XWB EXAMPLE GET LIST';
214 if RadioButton1.Checked then begin
215 RPCBroker1.Param[0].Value := 'LINES';
216 RPCBroker1.Param[0].PType := literal;
217 RPCBroker1.Param[1].Value := IntToStr(spnLines.Value);
218 RPCBroker1.Param[1].PType := literal;
219 end
220 else begin
221 RPCBroker1.Param[0].Value := 'KILOBYTES';
222 RPCBroker1.Param[0].PType := literal;
223 RPCBroker1.Param[1].Value := IntToStr(spnKbytes.Value);
224 RPCBroker1.Param[1].PType := literal
225 end;
226 RPCBroker1.Call; //execute RPC
227 lstData.Items := RPCBroker1.Results; //show results of the call
228end;
229
230
231
232procedure TfrmBrokerExample.btnWPTextClick(Sender: TObject);
233begin
234 RPCBroker1.RemoteProcedure := 'XWB EXAMPLE WPTEXT';
235 RPCBroker1.lstCall(mmoText.Lines); //execute RPC and show results in one call
236end;
237
238
239
240procedure TfrmBrokerExample.btnSortNumClick(Sender: TObject);
241var
242 I, SaveRPCTimeLimit, DefaultRange: integer;
243begin
244 lblStatus.Visible := True; //turn on status label
245 lblStatus.Caption := 'building'; //tell user what's happenning
246 Application.ProcessMessages; //give Windows chance to paint
247 with RPCBroker1 do
248 begin
249 if rgArrayType.ItemIndex = 0 then
250 begin
251 RemoteProcedure := 'XWB EXAMPLE SORT NUMBERS';
252 DefaultRange := 10000;
253 end
254 else
255 begin
256 RemoteProcedure := 'XWB EXAMPLE GLOBAL SORT';
257 DefaultRange := 100000;
258 end;
259
260 if rgrDirection.ItemIndex = 0 then Param[0].Value := 'LO'
261 else Param[0].Value := 'HI';
262 Param[0].PType := literal;
263 with Param[1] do begin
264 if rgArrayType.ItemIndex = 0 then
265 PType := list //tells Broker to pass Mult
266 else
267 PType := global;
268 for I := 0 to spnNumbers.Value - 1 do //build Mult one by one
269 Mult['"A'+IntToStr(I)+'"'] := IntToStr(Random(DefaultRange)+1); //subscript and value are strings!
270 end;
271 lblStatus.Caption := 'RPC running';
272 Application.ProcessMessages; //give Windows chance to paint
273 SaveRPCTimeLimit := RPCTimeLimit;
274 RPCTimeLimit := spnNumbers.Value div 10; //adjust in case a lot of numbers
275 Call; //execute RPC
276 lstSorted.Items := Results; //show results of the call
277 RPCTimeLimit := SaveRPCTimeLimit; //restore original value
278 end;
279 lblStatus.Visible := False; //turn off status label
280end;
281
282
283
284procedure TfrmBrokerExample.btnConnectClick(Sender: TObject);
285begin
286 if btnConnect.Caption = '&Connect' then
287 begin //connect
288 RpcBroker1.IsBackwardCompatibleConnection := actBackwardCompatible.Checked;
289 RpcBroker1.OldConnectionOnly := actOldConnectionOnly.Checked;
290 RpcBroker1.DebugMode := actDebugMode.Checked;
291 if RpcBroker1.IsBackwardCompatibleConnection or RpcBroker1.OldConnectionOnly then
292 begin
293 rgArrayType.ItemIndex := 0;
294 rgArrayType.Enabled := False;
295 end
296 else
297 begin
298 rgArrayType.Enabled := True;
299 end;
300
301 // *********************** CCOW User Context ****************************
302 if actUserContext.Checked then
303 begin
304 if (RPCBroker1.Contextor = nil) then
305 begin
306 if ContextorControl1 = nil then
307 begin
308 ContextorControl1 := TContextorControl.Create(Self);
309 ContextorControl1.OnCommitted := OnCCOWCommit;
310 try
311 ContextorControl1.Run('CCOWTerm#', '', TRUE, '*');
312 except
313 ShowMessage('Problem with Contextor.Run');
314 ContextorControl1.Free;
315 ContextorControl1 := nil;
316 end;
317 end;
318 end;
319 RPCBroker1.Contextor := ContextorControl1;
320 end
321 else
322 RPCBroker1.Contextor := nil;
323
324 // *********************** End CCOW User Context *************************
325
326 RPCBroker1.ClearParameters := True; //try False, see what happens
327 try
328 RPCBroker1.Connected := True;
329 //establish connection
330 if not RPCBroker1.CreateContext('XWB BROKER EXAMPLE') then
331 ShowMessage('Context could not be created!');
332 except
333 on e: Exception do
334 ShowMessage('Error: ' + e.Message);
335 end;
336 end
337 else //disconnect
338 RPCBroker1.Connected := False;
339end;
340
341
342
343procedure TfrmBrokerExample.btnGetServerInfoClick(Sender: TObject);
344var
345 strServer, strPort: string;
346begin
347 if GetServerInfo(strServer, strPort)<> mrCancel then
348 begin {getsvrinfo}
349 edtServer.Text := strServer; //use chosen server
350 edtPort.Text := strPort; //use chosen port
351 end;
352end;
353
354
355
356procedure TfrmBrokerExample.edtServerChange(Sender: TObject);
357begin
358 RPCBroker1.Server := edtServer.Text; //use specified server name/addr
359 RPCBroker1.ListenerPort := StrToInt(edtPort.Text); //use specified port
360end;
361
362
363
364procedure TfrmBrokerExample.Timer1Timer(Sender: TObject);
365begin
366 if RPCBroker1.Connected then begin
367 btnConnect.Caption := '&Disconnect';
368 btnConnect.Default := False;
369 mnuOptions.Enabled := False;
370 cbxBackwardCompatible.Enabled := False;
371 Label3.Caption := 'Connected';
372 Label3.Font.Color := clLime; // clGreen; // went to lime for higher contrast at some of the High contrast desktops
373 end
374 else begin
375 btnConnect.Caption := '&Connect';
376 btnConnect.Default := True;
377 mnuOptions.Enabled := True;
378 if not actOldConnectionOnly.Checked then
379 cbxBackwardCompatible.Enabled := True;
380 Label3.Caption := 'Disconnected';
381 Label3.Font.Color := clRed; // Stayed with Red, generated a high contrast across all of the various combinations
382 // Attempted to use clHighlight, but it did not show up like a highlight.
383 end;
384end;
385
386
387
388procedure TfrmBrokerExample.AboutExampleClick(Sender: TObject);
389begin
390 ShowAboutBox;
391end;
392
393// 080620 - added code below other the commented secion on coinitialize to
394// identify and use port and server specification on the command line.
395procedure TfrmBrokerExample.FormCreate(Sender: TObject);
396var
397 i: Integer;
398 text: String;
399begin
400{
401 CoInitialize(nil); // needed for CCOW
402}
403 for i := 0 to ParamCount do
404 begin
405 text := ParamStr(i);
406 if (Pos('P=',UpperCase(ParamStr(i))) = 1) then
407 begin
408 edtPort.Text := Copy(ParamStr(i),3,Length(ParamStr(i)));
409 end
410 else if (Pos('S=',UpperCase(ParamStr(i))) = 1) then
411 begin
412 edtServer.Text := Copy(ParamStr(i),3,Length(ParamStr(i)));
413 end;
414 end;
415 self.ShowHint := True;
416 Application.ShowHint := True;
417end;
418
419procedure TfrmBrokerExample.rgArrayTypeClick(Sender: TObject);
420begin
421 if rgArrayType.ItemIndex = 0 then
422 spnNumbers.Value := 500
423 else
424 spnNumbers.Value := 5000;
425end;
426
427procedure TfrmBrokerExample.actBackwardCompatibleExecute(Sender: TObject);
428begin
429 if actBackwardCompatible.Checked then
430 actBackwardCompatible.Checked := False
431 else
432 actBackwardCompatible.Checked := True;
433end;
434
435procedure TfrmBrokerExample.actDebugModeExecute(Sender: TObject);
436begin
437 if actDebugMode.Checked then
438 actDebugMode.Checked := False
439 else
440 actDebugMode.Checked := True;
441end;
442
443procedure TfrmBrokerExample.actUserContextExecute(Sender: TObject);
444begin
445 if actuserContext.Checked then
446 actUserContext.Checked := False
447 else
448 actUserContext.Checked := True;
449end;
450
451procedure TfrmBrokerExample.actOldConnectionOnlyExecute(Sender: TObject);
452begin
453 if actOldConnectionOnly.Checked then
454 begin
455 actOldConnectionOnly.Checked := False;
456 actBackwardCompatible.Enabled := True;
457 end
458 else
459 begin
460 actOldConnectionOnly.Checked := True;
461 actBackwardCompatible.Enabled := False;
462 end;
463end;
464
465procedure TfrmBrokerExample.actUseSSHAttachmateExecute(Sender: TObject);
466begin
467 if not actUseSSHAttachmate.Checked then
468 begin
469 RPCBroker1.UseSecureConnection := secureAttachmate;
470 actUseSSHAttachmate.Checked := true;
471 actUseSSHPlink.Checked := false;
472 RPCBroker1.SSHport := '';
473 RPCBroker1.SSHUser := '';
474 RPCBroker1.SSHpw := '';
475 end
476 else
477 begin
478 RPCBroker1.UseSecureConnection := secureNone;
479 actUseSSHAttachmate.Checked := false;
480 end
481end;
482
483procedure TfrmBrokerExample.actUseSSHPlinkExecute(Sender: TObject);
484begin
485 if not actUseSSHPlink.Checked then
486 begin
487 RPCBroker1.UseSecureConnection := securePlink;
488 actUseSSHPlink.Checked := true;
489 actUseSSHAttachmate.Checked := false;
490 RPCBroker1.SSHport := '';
491 RPCBroker1.SSHUser := '';
492 RPCBroker1.SSHpw := '';
493 end
494 else
495 begin
496 RPCBroker1.UseSecureConnection := secureNone;
497 actUseSSHPlink.Checked := false;
498 end
499end;
500
501procedure TfrmBrokerExample.OnCCOWCommit(Sender: TObject);
502begin
503{ // uses CCOWRPCBroker
504 if RpcBroker1.WasUserDefined and RpcBroker1.IsUserCleared then
505 Halt;
506}
507end;
508
509end.
510
511
Note: See TracBrowser for help on using the repository browser.