source: cprs/branches/GUI-config/BDK32/Samples/RPCBroker/BrokerEx/fBrokerExampleCCOW.pas@ 796

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

New WorldVistA Config Utility
File size: 13.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**************************************************}
51unit fBrokerExampleCCOW;
52
53interface
54
55uses
56 SysUtils,Forms, StdCtrls,Graphics, Dialogs, WinTypes,
57 Controls, Classes, ExtCtrls, TRPCB, XWBut1, MFunStr, Menus, WinProcs,
58 RpcConf1, Spin, ComCtrls, fVistAAbout, Buttons,
59 ActiveX, ActnList, CCOWRPCBroker, OleCtrls, VERGENCECONTEXTORLib_TLB;
60
61type
62 TfrmBrokerExampleCCOW = class(TForm)
63 GroupBox2: TGroupBox;
64 Label2: TLabel;
65 Label3: TLabel;
66 MainMenu1: TMainMenu;
67 mnuHelp: TMenuItem;
68 AboutExample: TMenuItem;
69 btnConnect: TButton;
70 edtPort: TEdit;
71 edtServer: TEdit;
72 PageControl1: TPageControl;
73 TabSheet1: TTabSheet;
74 TabSheet2: TTabSheet;
75 TabSheet3: TTabSheet;
76 TabSheet4: TTabSheet;
77 TabSheet5: TTabSheet;
78 lblSend: TLabel;
79 edtStrOrig: TEdit;
80 lblReturn: TLabel;
81 edtStrRtrn: TEdit;
82 btnEchoString: TButton;
83 lblList: TLabel;
84 Label1: TLabel;
85 edtReference: TEdit;
86 Label4: TLabel;
87 edtValue: TEdit;
88 btnPassByRef: TButton;
89 lstData: TListBox;
90 Label5: TLabel;
91 btnGetList: TButton;
92 btnWPText: TButton;
93 Label6: TLabel;
94 lstSorted: TListBox;
95 btnSortNum: TButton;
96 spnNumbers: TSpinEdit;
97 Label7: TLabel;
98 rgrDirection: TRadioGroup;
99 RadioButton1: TRadioButton;
100 RadioButton2: TRadioButton;
101 spnLines: TSpinEdit;
102 spnKbytes: TSpinEdit;
103 Timer1: TTimer;
104 mmoText: TMemo;
105 lblStatus: TLabel;
106 BitBtn1: TBitBtn;
107 btnGetServerInfo: TBitBtn;
108 Memo1: TMemo;
109 Memo2: TMemo;
110 Memo3: TMemo;
111 Memo4: TMemo;
112 Memo5: TMemo;
113 rgArrayType: TRadioGroup;
114 cbxBackwardCompatible: TCheckBox;
115 mnuOptions: TMenuItem;
116 mnuOptBackwardCompatible: TMenuItem;
117 mnuOptDebugMode: TMenuItem;
118 mnuOptUserContext: TMenuItem;
119 mnuOptOldConnectionOnly: TMenuItem;
120 ActionList1: TActionList;
121 actBackwardCompatible: TAction;
122 actOldConnectionOnly: TAction;
123 actDebugMode: TAction;
124 actUserContext: TAction;
125 RPCBroker1: TCCOWRPCBroker;
126 procedure AboutExampleClick(Sender: TObject);
127 procedure btnEchoStringClick(Sender: TObject);
128 procedure btnConnectClick(Sender: TObject);
129 procedure btnPassByRefClick(Sender: TObject);
130 procedure btnGetListClick(Sender: TObject);
131 procedure btnSortNumClick(Sender: TObject);
132 procedure btnWPTextClick(Sender: TObject);
133 procedure Timer1Timer(Sender: TObject);
134 procedure btnGetServerInfoClick(Sender: TObject);
135 procedure edtServerChange(Sender: TObject);
136 procedure FormCreate(Sender: TObject);
137 procedure rgArrayTypeClick(Sender: TObject);
138 procedure actBackwardCompatibleExecute(Sender: TObject);
139 procedure actDebugModeExecute(Sender: TObject);
140 procedure actUserContextExecute(Sender: TObject);
141 procedure actOldConnectionOnlyExecute(Sender: TObject);
142 public
143 procedure OnCCOWCommit(Sender: TObject); // CCOW related
144 procedure HandlePendingEvent(Sender: TObject; const aContextItemCollection:
145 IDispatch);
146end;
147
148
149
150var
151 frmBrokerExampleCCOW: TfrmBrokerExampleCCOW;
152 ContextorControl1: TContextorControl; // CCOW related
153
154
155implementation
156
157uses fOkToTerminate;
158
159{$R *.DFM}
160
161procedure TfrmBrokerExampleCCOW.btnEchoStringClick(Sender: TObject);
162begin
163 RPCBroker1.RemoteProcedure := 'XWB EXAMPLE ECHO STRING';
164 RPCBroker1.Param[0].Value := edtStrOrig.Text;
165 RPCBroker1.Param[0].PType := literal;
166 RPCBroker1.Call; //execute RPC
167 edtStrRtrn.Text := RPCBroker1.Results[0]; //for single value use Results[0]
168end;
169
170
171
172procedure TfrmBrokerExampleCCOW.btnPassByRefClick(Sender: TObject);
173begin
174 RPCBroker1.RemoteProcedure := 'XWB GET VARIABLE VALUE';
175 RPCBroker1.Param[0].Value := edtReference.Text;
176 RPCBroker1.Param[0].PType := reference;
177 edtValue.Text := RPCBroker1.strCall; //execute RPC and show result in one call
178end;
179
180
181
182procedure TfrmBrokerExampleCCOW.btnGetListClick(Sender: TObject);
183begin
184 RPCBroker1.RemoteProcedure := 'XWB EXAMPLE GET LIST';
185 if RadioButton1.Checked then begin
186 RPCBroker1.Param[0].Value := 'LINES';
187 RPCBroker1.Param[0].PType := literal;
188 RPCBroker1.Param[1].Value := IntToStr(spnLines.Value);
189 RPCBroker1.Param[1].PType := literal;
190 end
191 else begin
192 RPCBroker1.Param[0].Value := 'KILOBYTES';
193 RPCBroker1.Param[0].PType := literal;
194 RPCBroker1.Param[1].Value := IntToStr(spnKbytes.Value);
195 RPCBroker1.Param[1].PType := literal
196 end;
197 RPCBroker1.Call; //execute RPC
198 lstData.Items := RPCBroker1.Results; //show results of the call
199end;
200
201
202
203procedure TfrmBrokerExampleCCOW.btnWPTextClick(Sender: TObject);
204begin
205 RPCBroker1.RemoteProcedure := 'XWB EXAMPLE WPTEXT';
206 RPCBroker1.lstCall(mmoText.Lines); //execute RPC and show results in one call
207end;
208
209
210
211procedure TfrmBrokerExampleCCOW.btnSortNumClick(Sender: TObject);
212var
213 I, SaveRPCTimeLimit, DefaultRange: integer;
214begin
215 lblStatus.Visible := True; //turn on status label
216 lblStatus.Caption := 'building'; //tell user what's happenning
217 Application.ProcessMessages; //give Windows chance to paint
218 with RPCBroker1 do
219 begin
220 if rgArrayType.ItemIndex = 0 then
221 begin
222 RemoteProcedure := 'XWB EXAMPLE SORT NUMBERS';
223 DefaultRange := 10000;
224 end
225 else
226 begin
227 RemoteProcedure := 'XWB EXAMPLE GLOBAL SORT';
228 DefaultRange := 100000;
229 end;
230
231 if rgrDirection.ItemIndex = 0 then Param[0].Value := 'LO'
232 else Param[0].Value := 'HI';
233 Param[0].PType := literal;
234 with Param[1] do begin
235 if rgArrayType.ItemIndex = 0 then
236 PType := list //tells Broker to pass Mult
237 else
238 PType := global;
239 for I := 0 to spnNumbers.Value - 1 do //build Mult one by one
240 Mult['"A'+IntToStr(I)+'"'] := IntToStr(Random(DefaultRange)+1); //subscript and value are strings!
241 end;
242 lblStatus.Caption := 'RPC running';
243 Application.ProcessMessages; //give Windows chance to paint
244 SaveRPCTimeLimit := RPCTimeLimit;
245 RPCTimeLimit := spnNumbers.Value div 10; //adjust in case a lot of numbers
246 Call; //execute RPC
247 lstSorted.Items := Results; //show results of the call
248 RPCTimeLimit := SaveRPCTimeLimit; //restore original value
249 end;
250 lblStatus.Visible := False; //turn off status label
251end;
252
253
254
255procedure TfrmBrokerExampleCCOW.btnConnectClick(Sender: TObject);
256begin
257 if btnConnect.Caption = '&Connect' then
258 begin //connect
259 RpcBroker1.IsBackwardCompatibleConnection := actBackwardCompatible.Checked;
260 RpcBroker1.OldConnectionOnly := actOldConnectionOnly.Checked;
261 RpcBroker1.DebugMode := actDebugMode.Checked;
262 if RpcBroker1.IsBackwardCompatibleConnection or RpcBroker1.OldConnectionOnly then
263 begin
264 rgArrayType.ItemIndex := 0;
265 rgArrayType.Enabled := False;
266 end
267 else
268 begin
269 rgArrayType.Enabled := True;
270 end;
271
272 // *********************** CCOW User Context ****************************
273 if actUserContext.Checked then
274 begin
275 if (RPCBroker1.Contextor = nil) then
276 begin
277 if ContextorControl1 = nil then
278 begin
279 ContextorControl1 := TContextorControl.Create(Self);
280 ContextorControl1.OnCommitted := OnCCOWCommit;
281 ContextorControl1.OnPending := HandlePendingEvent;
282 try
283 ContextorControl1.Run('CCOWTerm#', '', TRUE, '*');
284 except
285 ShowMessage('Problem with Contextor.Run');
286 ContextorControl1.Free;
287 ContextorControl1 := nil;
288 end;
289 end;
290 end;
291 RPCBroker1.Contextor := ContextorControl1;
292 end
293 else
294 RPCBroker1.Contextor := nil;
295
296 // *********************** End CCOW User Context *************************
297
298
299 RPCBroker1.ClearParameters := True; //try False, see what happens
300 try
301 RPCBroker1.Connected := True;
302 //establish connection
303 if not RPCBroker1.CreateContext('XWB BROKER EXAMPLE') then
304 ShowMessage('Context could not be created!');
305 except
306 on e: Exception do
307 ShowMessage('Error: ' + e.Message);
308 end;
309 end
310 else //disconnect
311 RPCBroker1.Connected := False;
312end;
313
314
315
316procedure TfrmBrokerExampleCCOW.btnGetServerInfoClick(Sender: TObject);
317var
318 strServer, strPort: string;
319begin
320 if GetServerInfo(strServer, strPort)<> mrCancel then
321 begin {getsvrinfo}
322 edtServer.Text := strServer; //use chosen server
323 edtPort.Text := strPort; //use chosen port
324 end;
325end;
326
327
328
329procedure TfrmBrokerExampleCCOW.edtServerChange(Sender: TObject);
330begin
331 RPCBroker1.Server := edtServer.Text; //use specified server name/addr
332 RPCBroker1.ListenerPort := StrToInt(edtPort.Text); //use specified port
333end;
334
335
336
337procedure TfrmBrokerExampleCCOW.Timer1Timer(Sender: TObject);
338begin
339 if RPCBroker1.Connected then begin
340 btnConnect.Caption := '&Disconnect';
341 btnConnect.Default := False;
342 mnuOptions.Enabled := False;
343 cbxBackwardCompatible.Enabled := False;
344 Label3.Caption := 'Connected';
345 Label3.Font.Color := clLime; // clGreen; // went to lime for higher contrast at some of the High contrast desktops
346 end
347 else begin
348 btnConnect.Caption := '&Connect';
349 btnConnect.Default := True;
350 mnuOptions.Enabled := True;
351 if not actOldConnectionOnly.Checked then
352 cbxBackwardCompatible.Enabled := True;
353 Label3.Caption := 'Disconnected';
354 Label3.Font.Color := clRed; // Stayed with Red, generated a high contrast across all of the various combinations
355 // Attempted to use clHighlight, but it did not show up like a highlight.
356 end;
357end;
358
359
360
361procedure TfrmBrokerExampleCCOW.AboutExampleClick(Sender: TObject);
362begin
363 ShowAboutBox;
364end;
365
366
367procedure TfrmBrokerExampleCCOW.FormCreate(Sender: TObject);
368begin
369 CoInitialize(nil); // needed for CCOW
370end;
371
372procedure TfrmBrokerExampleCCOW.rgArrayTypeClick(Sender: TObject);
373begin
374 if rgArrayType.ItemIndex = 0 then
375 spnNumbers.Value := 500
376 else
377 spnNumbers.Value := 5000;
378end;
379
380procedure TfrmBrokerExampleCCOW.actBackwardCompatibleExecute(Sender: TObject);
381begin
382 if actBackwardCompatible.Checked then
383 actBackwardCompatible.Checked := False
384 else
385 actBackwardCompatible.Checked := True;
386end;
387
388procedure TfrmBrokerExampleCCOW.actDebugModeExecute(Sender: TObject);
389begin
390 if actDebugMode.Checked then
391 actDebugMode.Checked := False
392 else
393 actDebugMode.Checked := True;
394end;
395
396procedure TfrmBrokerExampleCCOW.actUserContextExecute(Sender: TObject);
397begin
398 if actuserContext.Checked then
399 actUserContext.Checked := False
400 else
401 actUserContext.Checked := True;
402end;
403
404procedure TfrmBrokerExampleCCOW.actOldConnectionOnlyExecute(Sender: TObject);
405begin
406 if actOldConnectionOnly.Checked then
407 begin
408 actOldConnectionOnly.Checked := False;
409 actBackwardCompatible.Enabled := True;
410 end
411 else
412 begin
413 actOldConnectionOnly.Checked := True;
414 actBackwardCompatible.Enabled := False;
415 end;
416end;
417
418procedure TfrmBrokerExampleCCOW.OnCCOWCommit(Sender: TObject);
419begin
420 if RpcBroker1.WasUserDefined and RpcBroker1.IsUserCleared then
421 Halt;
422end;
423
424procedure TfrmBrokerExampleCCOW.HandlePendingEvent(Sender: TObject; const
425 aContextItemCollection: IDispatch);
426var
427 data : IContextItemCollection;
428begin
429 data := IContextItemCollection(aContextItemCollection) ;
430 if RPCBroker1.IsUserContextPending(data) then
431 begin
432 frmOkToTerminate := TfrmOkToTerminate.Create(Self);
433 try
434 if not (frmOkToTerminate.ShowModal = mrOK) then
435 ContextorControl1.SetSurveyResponse('No Way');
436 finally
437 frmOkToTerminate.Free;
438 end;
439 end;
440end;
441
442end.
443
444
Note: See TracBrowser for help on using the repository browser.