1 /* ***********************************************************
  2    *                                                         *
  3    * Copyright, (C) Honeywell Information Systems Inc., 1982 *
  4    *                                                         *
  5    * Copyright (c) 1972 by Massachusetts Institute of        *
  6    * Technology and Honeywell Information Systems, Inc.      *
  7    *                                                         *
  8    *********************************************************** */
  9 
 10 
 11 /* Command Interface to transaction_call_.
 12 
 13    Rewritten 8-Mar-79 by M. N. Davidoff.
 14 */
 15 transaction_call:
 16 trc:
 17      procedure;
 18 
 19 /* auotmatic */
 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 /* based */
 34 
 35           declare arg_string             char (arg_length) based (arg_ptr);
 36 
 37 /* builtin */
 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 /* condition */
 47 
 48           declare program_interrupt      condition;
 49           declare transaction_failure    condition;
 50 ^L
 51 /* internal static */
 52 
 53           declare command                char (16) internal static options (constant) initial ("transaction_call");
 54 
 55 /* external static */
 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 /* entry */
 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 /* program */
 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 /* Get a new transaction number. */
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 /* Change to another transaction. */
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 /* Commit a transaction. */
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 /* Get the current transaction number. */
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 /* Rollback a transaction. */
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 /* Get a transaction's status. */
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 /* Execute a command line as a transaction. */
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;