1
2
3
4
5
6
7
8
9
10
11
12
13
14
15 transaction_call:
16 trc:
17 procedure;
18
19
20
21 declare arg_count fixed binary;
22 declare arg_length fixed binary (21);
23 declare arg_list_ptr pointer;
24 declare arg_ptr pointer;
25 declare argument_no fixed binary;
26 declare argx fixed binary;
27 declare code fixed binary (35);
28 declare operation char (32);
29 declare tcf_io_switch char (32);
30 declare tcf_iocb_ptr pointer;
31 declare transaction_no fixed binary (35);
32
33
34
35 declare arg_string char (arg_length) based (arg_ptr);
36
37
38
39 declare addr builtin;
40 declare index builtin;
41 declare length builtin;
42 declare null builtin;
43 declare rtrim builtin;
44 declare string builtin;
45
46
47
48 declare program_interrupt condition;
49 declare transaction_failure condition;
50 ^L
51
52
53 declare command char (16) internal static options (constant) initial ("transaction_call");
54
55
56
57 declare error_table_$asynch_change
58 fixed binary (35) external static;
59 declare error_table_$badopt fixed binary (35) external static;
60
61
62
63 declare com_err_ entry options (variable);
64 declare com_err_$suppress_name entry options (variable);
65 declare cu_$arg_count entry (fixed binary);
66 declare cu_$arg_list_ptr entry (pointer);
67 declare cu_$arg_ptr entry (fixed binary, pointer, fixed binary (21), fixed binary (35));
68 declare cu_$arg_ptr_rel entry (fixed binary, pointer, fixed binary (21), fixed binary (35), pointer);
69 declare cv_dec_check_ entry (char (*), fixed binary (35)) returns (fixed binary (35));
70 declare ioa_ entry options (variable);
71 declare iox_$look_iocb entry (char (*), pointer, fixed binary (35));
72 declare transaction_call_$assign
73 entry (pointer, fixed binary (35), fixed binary (35));
74 declare transaction_call_$change_current_transaction_no
75 entry (pointer, fixed binary (35), fixed binary (35));
76 declare transaction_call_$commit
77 entry (pointer, fixed binary (35), fixed binary (35));
78 declare transaction_call_$number
79 entry (pointer, fixed binary (35), fixed binary (35));
80 declare transaction_call_$rollback
81 entry (pointer, fixed binary (35), fixed binary (35));
82 declare transaction_call_$status
83 entry (pointer, fixed binary (35), bit (36) aligned, pointer, fixed binary,
84 fixed binary (35));
85 declare transaction_call_$transact
86 entry (pointer, char (*), fixed binary (35), fixed binary (35));
87 ^L
88 %include transaction_call;
89 ^L
90
91
92 call cu_$arg_list_ptr (arg_list_ptr);
93
94 call cu_$arg_count (arg_count);
95 if arg_count < 2
96 then do;
97 call com_err_$suppress_name (0, command, "Usage: ^a operation tcf_io_switch {args}", command);
98 return;
99 end;
100
101 do argx = 1 to 2;
102 call cu_$arg_ptr (argx, arg_ptr, arg_length, code);
103 if code ^= 0
104 then do;
105 call com_err_ (code, command, "Argument ^d.", argx);
106 return;
107 end;
108
109 if index (arg_string, "-") = 1
110 then do;
111 call com_err_ (error_table_$badopt, command, "^a", arg_string);
112 return;
113 end;
114
115 else if argx = 1
116 then operation = arg_string;
117 else tcf_io_switch = arg_string;
118 end;
119
120 call iox_$look_iocb (tcf_io_switch, tcf_iocb_ptr, code);
121 if code ^= 0
122 then do;
123 call com_err_ (code, command, "^a", tcf_io_switch);
124 return;
125 end;
126
127 if operation = "assign" | operation = "a"
128 then call assign;
129
130 else if operation = "change_current_transaction_no" | operation = "cctn"
131 then call change_current_transaction_no;
132
133 else if operation = "commit" | operation = "c"
134 then call commit;
135
136 else if operation = "number" | operation = "n"
137 then call number;
138
139 else if operation = "rollback" | operation = "r"
140 then call rollback;
141
142 else if operation = "status" | operation = "s"
143 then call status;
144
145 else if operation = "transact" | operation = "t"
146 then call transact;
147
148 else do;
149 call com_err_ (0, command, "Specified operation is not implemented by this command. ^a", operation);
150 return;
151 end;
152
153 return;
154 ^L
155
156
157 assign:
158 procedure;
159
160 if arg_count ^= 2
161 then do;
162 call com_err_$suppress_name (0, command, "Usage: ^a assign tcf_io_switch", command);
163 return;
164 end;
165
166 call transaction_call_$assign (tcf_iocb_ptr, transaction_no, code);
167 if code ^= 0
168 then do;
169 call com_err_ (code, command, "Assigning a transaction number.");
170 return;
171 end;
172
173 call ioa_ ("Transaction ^d.", transaction_no);
174 end assign;
175 ^L
176
177
178 change_current_transaction_no:
179 procedure;
180
181 argument_no = 0;
182 do argx = 3 to arg_count;
183 call cu_$arg_ptr (argx, arg_ptr, arg_length, code);
184 if code ^= 0
185 then do;
186 call com_err_ (code, command, "Argument ^d.", argx);
187 return;
188 end;
189
190 if index (arg_string, "-") = 1
191 then do;
192 call com_err_ (error_table_$badopt, command, "^a", arg_string);
193 return;
194 end;
195
196 else do;
197 argument_no = argument_no + 1;
198
199 if argument_no = 1
200 then do;
201 transaction_no = cv_dec_check_ (arg_string, code);
202 if code ^= 0
203 then do;
204 call com_err_ (0, command, "Transaction number expected. ^a", arg_string);
205 return;
206 end;
207 end;
208 end;
209 end;
210
211 if argument_no ^= 1
212 then do;
213 call com_err_$suppress_name (0, command,
214 "Usage: ^a change_current_transaction_no tcf_io_switch transaction_no", command);
215 return;
216 end;
217
218 call transaction_call_$change_current_transaction_no (tcf_iocb_ptr, transaction_no, code);
219 if code ^= 0
220 then do;
221 call com_err_ (code, command, "Changing the current transaction number.");
222 return;
223 end;
224 end change_current_transaction_no;
225 ^L
226
227
228 commit:
229 procedure;
230
231 if arg_count ^= 2
232 then do;
233 call com_err_$suppress_name (0, command, "Usage: ^a commit tcf_io_switch", command);
234 return;
235 end;
236
237 call transaction_call_$commit (tcf_iocb_ptr, transaction_no, code);
238 if code ^= 0
239 then do;
240 call com_err_ (code, command, "Committing transaction ^d.", transaction_no);
241 return;
242 end;
243
244 if transaction_no ^= 0
245 then call ioa_ ("Transaction ^d committed.", transaction_no);
246 end commit;
247
248
249
250 number:
251 procedure;
252
253 if arg_count ^= 2
254 then do;
255 call com_err_$suppress_name (0, command, "Usage: ^a number tcf_io_switch", command);
256 return;
257 end;
258
259 call transaction_call_$number (tcf_iocb_ptr, transaction_no, code);
260 if code ^= 0
261 then do;
262 call com_err_ (code, command, "Getting current transaction number.");
263 return;
264 end;
265
266 call ioa_ ("The current transaction number is ^d.", transaction_no);
267 end number;
268 ^L
269
270
271 rollback:
272 procedure;
273
274 if arg_count ^= 2
275 then do;
276 call com_err_$suppress_name (0, command, "Usage: ^a rollback tcf_io_switch", command);
277 return;
278 end;
279
280 call transaction_call_$rollback (tcf_iocb_ptr, transaction_no, code);
281 if code ^= 0
282 then do;
283 call com_err_ (code, command, "Rolling back transaction ^d.", transaction_no);
284 return;
285 end;
286
287 if transaction_no ^= 0
288 then call ioa_ ("Transaction ^d rolled back.", transaction_no);
289 end rollback;
290 ^L
291
292
293 status:
294 procedure;
295
296 declare 1 status_s aligned like trc_status;
297 declare 1 sw unaligned,
298 2 brief bit (1),
299 2 verify_refs bit (1),
300 2 list bit (1);
301 declare transaction_status fixed binary;
302
303 string (sw) = ""b;
304 transaction_no = 0;
305
306 argument_no = 0;
307 do argx = 3 to arg_count;
308 call cu_$arg_ptr (argx, arg_ptr, arg_length, code);
309 if code ^= 0
310 then do;
311 call com_err_ (code, command, "Argument ^d.", argx);
312 return;
313 end;
314
315 if arg_string = "-brief" | arg_string = "-bf"
316 then sw.brief = "1"b;
317
318 else if arg_string = "-verify" | arg_string = "-vf"
319 then sw.verify_refs = "1"b;
320
321 else if arg_string = "-list" | arg_string = "-ls"
322 then sw.list = "1"b;
323
324 else if index (arg_string, "-") = 1
325 then do;
326 call com_err_ (error_table_$badopt, command, "^a", arg_string);
327 return;
328 end;
329
330 else do;
331 argument_no = argument_no + 1;
332
333 if argument_no = 1
334 then do;
335 transaction_no = cv_dec_check_ (arg_string, code);
336 if code ^= 0
337 then do;
338 call com_err_ (0, command, "Transaction number expected. ^a", arg_string);
339 return;
340 end;
341 end;
342 end;
343 end;
344
345 if argument_no > 1
346 then do;
347 call com_err_$suppress_name (0, command,
348 "Usage: ^a status tcf_io_switch {transaction_no} {-control_args}", command);
349 return;
350 end;
351
352 trc_flags = ""b;
353 trc_flag_s.verify_refs = sw.verify_refs;
354 trc_flag_s.list = sw.list;
355
356 status_s.version = trc_status_version_1;
357
358 if sw.brief
359 then trc_status_ptr = null;
360 else trc_status_ptr = addr (status_s);
361
362 if sw.list
363 then call ioa_ ("^/Reference list^[ until first asychronous change^]:", sw.verify_refs);
364
365 call transaction_call_$status (tcf_iocb_ptr, transaction_no, trc_flags, trc_status_ptr, transaction_status, code);
366 if code ^= 0 & code ^= error_table_$asynch_change
367 then do;
368 call com_err_ (code, command, "Getting the status of ^[the current transaction^s^;transaction ^d^].",
369 transaction_no = 0, transaction_no);
370 return;
371 end;
372
373 if transaction_no ^= 0 | ^sw.brief
374 then call ioa_ ("^/transaction:^2-^[^d^s^;^s^d^]", sw.brief, transaction_no, status_s.transaction_no);
375
376 call ioa_ ("status:^3-^[^[incomplete^;committed^;rolled back^;undefined^]^s^;^s^d^]",
377 trc_INCOMPLETE <= transaction_status & transaction_status <= trc_UNDEFINED, transaction_status + 1,
378 transaction_status);
379
380 if transaction_status ^= trc_UNDEFINED & ^sw.brief
381 then call ioa_ ("passive references:^2-^d^/non-passive references:^-^d", status_s.passive_refs,
382 status_s.non_passive_refs);
383
384 if code ^= 0
385 then call com_err_ (code, command);
386 end status;
387 ^L
388
389
390 transact:
391 procedure;
392
393 declare command_line_length fixed binary (21);
394 declare first_command_line_arg fixed binary;
395 declare retry_limit fixed binary;
396 declare 1 sw unaligned,
397 2 signal bit (1),
398 2 no_signal bit (1);
399
400 string (sw) = ""b;
401 retry_limit = 0;
402
403 first_command_line_arg = 0;
404 argx = 3;
405 do while (argx <= arg_count);
406 call cu_$arg_ptr (argx, arg_ptr, arg_length, code);
407 if code ^= 0
408 then do;
409 call com_err_ (code, command, "Argument ^d.", argx);
410 return;
411 end;
412
413 if first_command_line_arg > 0
414 then command_line_length = command_line_length + length (arg_string) + 1;
415
416 else if arg_string = "-retry"
417 then do;
418 argx = argx + 1;
419 if argx > arg_count
420 then do;
421 call com_err_ (0, command, "Missing retry limit after -retry.");
422 return;
423 end;
424
425 call cu_$arg_ptr (argx, arg_ptr, arg_length, code);
426 if code ^= 0
427 then do;
428 call com_err_ (code, command, "Argument ^d.", argx);
429 return;
430 end;
431
432 retry_limit = cv_dec_check_ (arg_string, code);
433 if code ^= 0
434 then do;
435 call com_err_ (0, command, "Retry limit expected. ^a", arg_string);
436 return;
437 end;
438 end;
439
440 else if arg_string = "-signal"
441 then sw.signal = "1"b;
442
443 else if arg_string = "-no_signal"
444 then sw.no_signal = "1"b;
445
446 else if index (arg_string, "-") = 1
447 then do;
448 call com_err_ (error_table_$badopt, command, "^a", arg_string);
449 return;
450 end;
451
452 else do;
453 first_command_line_arg = argx;
454 command_line_length = length (arg_string);
455 end;
456
457 argx = argx + 1;
458 end;
459
460 if first_command_line_arg = 0
461 then do;
462 call com_err_$suppress_name (0, command, "Usage: ^a transact tcf_io_switch {-control_args} command_line",
463 command);
464 return;
465 end;
466
467 if sw.signal & sw.no_signal
468 then do;
469 call com_err_ (0, command, "The -signal and -no_signal control arguments are incompatible.");
470 return;
471 end;
472
473 sw.signal = ^sw.no_signal;
474 ^L
475 begin;
476 declare command_line char (command_line_length);
477 declare one_more_time bit (1);
478 declare try fixed binary;
479
480 do argx = first_command_line_arg to arg_count;
481 call cu_$arg_ptr_rel (argx, arg_ptr, arg_length, code, arg_list_ptr);
482 if code ^= 0
483 then do;
484 call com_err_ (code, command, "Argument ^d.", argx);
485 return;
486 end;
487
488 if argx = first_command_line_arg
489 then command_line = arg_string;
490 else command_line = rtrim (command_line) || " " || arg_string;
491 end;
492
493 if sw.signal
494 then on program_interrupt
495 goto execute_command_line;
496
497 try = 0;
498
499 execute_command_line:
500 one_more_time = "1"b;
501 do while (try <= retry_limit & code = error_table_$asynch_change | one_more_time);
502 one_more_time = "0"b;
503 try = try + 1;
504
505 call transaction_call_$transact (tcf_iocb_ptr, command_line, transaction_no, code);
506 end;
507
508 if code = 0
509 then call ioa_ ("The transaction committed on try ^d with transaction number ^d.", try, transaction_no);
510
511 else if code = error_table_$asynch_change
512 then if sw.signal
513 then signal transaction_failure;
514 else call com_err_ (code, command, "On try ^d.", try);
515
516 else call com_err_ (code, command, "On transaction ^d.", transaction_no);
517 end;
518 end transact;
519
520 end transaction_call;