1 /****^  ***********************************************************
   2         *                                                         *
   3         * Copyright, (C) Honeywell Information Systems Inc., 1984 *
   4         *                                                         *
   5         *********************************************************** */
   6 
   7 
   8 /****^  HISTORY COMMENTS:
   9   1) change(86-04-15,Pierret), approve(86-04-15,MCR7279),
  10      audit(86-07-30,Gilcrease), install(86-08-01,MR12.0-1113):
  11      DM error 29: Changed to not look at all tm_tdt entries unless absolutely
  12      necessary so that non-priviledged uses can use transaction status.
  13   2) change(86-04-15,Pierret), approve(86-04-15,MCR7279),
  14      audit(86-07-30,Gilcrease), install(86-08-01,MR12.0-1113):
  15      DM error 30: Changed to reset handler_invoked_sw to off after the
  16      return from transaction_manager_$handle_conditions in the processing
  17      of the SUSPEND_ACTION.
  18   3) change(86-04-15,Pierret), approve(86-04-15,MCR7279),
  19      audit(86-07-30,Gilcrease), install(86-08-01,MR12.0-1113):
  20      DM error 31:  Changed loop which calls PRINT_ENTRY to use tix_index
  21      instead of tix_count, thereby printing all entries instead of the last
  22      one repeatedly.
  23   4) change(86-09-30,Blair), approve(86-10-22,MCR7567), audit(86-11-06,Dupuis),
  24      install(86-11-10,MR12.0-1207):
  25      Reset the handler_invoked_sw after signalling the condition so that we can
  26      detect when a condition occurs more than once.  TR 19757.
  27                                                    END HISTORY COMMENTS */
  28 
  29 
  30 /* format: style4,ifthenstmt,^indproc,^indcomtxt */
  31 /* --------------- */
  32 
  33 transaction: txn: proc;
  34 
  35 /* DESCRIPTION:
  36 
  37    Command interface to the Data Management System.
  38 */
  39 
  40 /* HISTORY:
  41 
  42 Written by Steve Herbst, 02/20/84.
  43 Modified:
  44 03/08/84 by Steve Herbst: Fixed general usage message.
  45 03/21/84 by Steve Herbst: Fixed bug in "txn execute" condition handling.
  46 03/21/84 by Steve Herbst: Changed "txn abandon" and "txn abort" to resume
  47           suspended txn.
  48 11/08/84 by Steve Herbst: Changed in response to audit comments.
  49 04/02/84 by Lee A. Newcomb: Fixed dcl of tm_$get_state_description to be
  50           char(*) as in called entry instead of char (64); called was reading
  51           stack garbage when trying to decode descriptor.
  52 04/03/84 by Lee A. Newcomb: Fixed status' using the wrong buffer when
  53           outputing a txn's state.
  54 04/19/84 by Lindsey L. Spratt: Corrected the calling sequence of the
  55           transaction_manager_$rollback_txn entry to include the checkpoint id.
  56 04/23/84 by Lindsey L. Spratt: Fixed to only handle the
  57           dm_error_$system_not_initialized sub_error_ in the sub_error_
  58           handler.
  59 04/26/84 by Lindsey L. Spratt: Changed to always abort on the cleanup
  60           condition, and to do a non-local goto RETURN when aborting or
  61           abandoning any condition other than a cleanup.
  62 04/27/84 by Lindsey L. Spratt: Made all settings of severities use declared
  63           constants.  Fixed to always set the severity in the execute
  64           operation, regardless of the path of execution, if txn is invoked
  65           as an active function.
  66 05/10/84 by S. Herbst: Fixed to get BJ path from oid if possible, without
  67           (as for from_uid) requiring special gate access.
  68 05/16/84 by S. Herbst: Fixed "txn execute" to prompt for command_line if
  69           given neither a command_line nor -command_level.
  70 05/21/84 by S. Herbst: Fixed "txn begin" error msg for bad control arg.
  71 11/08/84 by Steve Herbst: Changed in response to audit comments.
  72 11/27/84 by Steve Herbst: Changed further in response to audit comments.
  73 01/02/85 by Steve Herbst: Fixed "txn execute" to set transaction_severity_
  74           external variable for use by severity command.
  75 01/22/85 by Steve Herbst: Fixed CURRENT_ID proc to set af value to "false"
  76           rather than issue an error.
  77 01/29/85 by Steve Herbst: Fixed CURRENT_ID to return txn_id even if txn is
  78           in an error state; changed to accept txn_id's as decimal integers.
  79 02/20/85 by Steve Herbst: Fixed to handle dm_not_available_.
  80 */
  81 %page;
  82 /* DECLARATIONS */
  83 
  84 /* Constants */
  85 
  86 dcl  KEY_NAMES (8) char (32) int static options (constant)
  87           init ("abandon", "abort", "begin", "commit", "execute", "kill", "rollback", "status");
  88 dcl  (
  89      EXISTING_TXN_NOT_ALLOWED init (1),
  90      EXISTING_TXN_ALLOWED init (2),
  91      EXISTING_TXN_REQUIRED init (3)
  92      ) fixed bin int static options (constant);
  93 dcl  (
  94      ABANDON_ACTION init (1),
  95      ABORT_ACTION init (2),
  96      NO_ACTION init (3),
  97      RETRY_ACTION init (4),
  98      SUSPEND_ACTION init (5)
  99      ) fixed bin int static options (constant);
 100 
 101 dcl  (
 102      NO_ERROR_SEVERITY init (0),
 103      RETRY_SEVERITY init (1),
 104      ABORT_OR_ABANDON_SEVERITY init (2),
 105      FAILED_ABORT_OR_ABANDON_SEVERITY init (3),
 106      FATAL_SEVERITY init (4)
 107      ) fixed bin (35) internal static options (constant);
 108 
 109 dcl  (
 110      ENTRY_ITEM init (1),
 111      TXN_ITEM init (2)
 112      ) fixed bin int static options (constant);
 113 dcl  INITIAL_CHECKPOINT init (0) fixed bin internal static options (constant);
 114 dcl  PRINT_ALL_INFO bit (36) int static options (constant) init ((36)"1"b);
 115 dcl  RELATIVE_TIME_OPTION bit (2) int static options (constant) init ("11"b);
 116 dcl  (
 117      TEN_SECONDS init (10),
 118      USEC_PER_SECOND init (1000000),
 119      LONG_TIME_USEC init (1000000000000)
 120      ) fixed bin (71) int static options (constant);
 121 
 122 /* Based */
 123 
 124 dcl  1 handler_node aligned based,
 125        2 next_ptr ptr,
 126        2 condition_name char (32),
 127        2 action fixed bin,
 128        2 retry_limit fixed bin;
 129 
 130 dcl  1 tm_info (tdt_max_count) aligned like txn_info based (tm_info_ptr);
 131 
 132 dcl  tix (tix_bound) fixed bin based (tix_ptr);
 133 
 134 dcl  area area based (area_ptr);
 135 
 136 dcl  arg char (arg_len) based (arg_ptr);
 137 dcl  key char (key_len) based (key_ptr);
 138 dcl  return_arg char (return_len) varying based (return_ptr);
 139 
 140 /* Automatic */
 141 
 142 dcl  1 print_switches aligned,
 143        2 (bj_path, dtm, errors, owner, pid, rollback_count, state, switches, tid, tix) bit (1) unaligned,
 144        2 pad bit (26) unaligned;
 145 
 146 dcl  1 select_switches aligned,
 147        2 (abandoned, all, dead, tid, tix) bit (1) unaligned,
 148        2 pad bit (31) unaligned;
 149 
 150 dcl  1 cond_info aligned like condition_info;
 151 
 152 dcl  (key_buffer, my_name, on_action_name) char (32);
 153 dcl  (begun_time_str, ctl_args_str, requested_time_str) char (32);
 154 
 155 dcl  (af_sw, cl_sw, had_to_wait_sw, handler_invoked_sw, multiple_info_sw, on_action_specified_sw) bit (1);
 156 dcl  (print_no_txn_warning_sw, printed_something_sw, succeeded_sw, total_sw) bit (1);
 157 dcl  (txn_exists_sw, txn_existed_sw, wait_sw) bit (1);
 158 dcl  bj_opening_id bit (36);
 159 dcl  txn_id bit (36) aligned;
 160 
 161 dcl  (alp, area_ptr, arg_ptr, first_handler_ptr, key_ptr, return_ptr, tix_ptr, tm_info_ptr) ptr;
 162 
 163 dcl  (arg_count, arg_index, command_line_start, existing_txn_policy) fixed bin;
 164 dcl  (fixed_txn_id, key_index, tix_index, tdt_index, txn_index) fixed bin;
 165 dcl  (retry_count, retry_limit, tdt_max_count, tix_bound, tix_count, wait_seconds) fixed bin;
 166 dcl  (abandoned_count, dead_count, error_count, txn_count, used_count) fixed bin;
 167 dcl  (arg_len, key_len, return_len) fixed bin (21);
 168 dcl  code fixed bin (35);
 169 dcl  (start_usec, wait_usec) fixed bin (71);
 170 
 171 dcl  (complain, complain_suppress_name) entry variable options (variable);
 172 
 173 /* External */
 174 
 175 dcl  dm_error_$system_not_initialized fixed bin (35) ext;
 176 dcl  dm_error_$transaction_suspended fixed bin (35) ext;
 177 dcl  error_table_$badopt fixed bin (35) ext;
 178 dcl  error_table_$noarg fixed bin (35) ext;
 179 dcl  error_table_$not_act_fnc fixed bin (35) ext;
 180 dcl  error_table_$too_many_args fixed bin (35) ext;
 181 dcl  transaction_severity_ fixed bin ext;
 182 
 183 /* Entries */
 184 
 185 dcl  (
 186      active_fnc_err_,
 187      active_fnc_err_$suppress_name
 188      ) entry options (variable);
 189 dcl  before_journal_manager_$get_bj_path_from_oid entry (bit (36) aligned, char (*), char (*), fixed bin (35));
 190 dcl  before_journal_manager_$get_bj_path_from_uid entry (bit (36) aligned, char (*), char (*), fixed bin (35));
 191 dcl  (
 192      com_err_,
 193      com_err_$suppress_name
 194      ) entry options (variable);
 195 dcl  command_query_ entry options (variable);
 196 dcl  continue_to_signal_ entry (fixed bin (35));
 197 dcl  convert_status_code_ entry (fixed bin (35), char (8), char (100));
 198 dcl  cu_$af_return_arg entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
 199 dcl  cu_$arg_list_ptr entry (ptr);
 200 dcl  cu_$arg_ptr entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
 201 dcl  cu_$arg_ptr_rel entry (fixed bin, ptr, fixed bin (21), fixed bin (35), ptr);
 202 dcl  cu_$cp entry (ptr, fixed bin (21), fixed bin (35));
 203 dcl  cv_dec_check_ entry (char (*), fixed bin (35)) returns (fixed bin (35));
 204 dcl  date_time_ entry (fixed bin (71), char (*));
 205 dcl  find_condition_info_ entry (ptr, ptr, fixed bin (35));
 206 dcl  get_process_id_ entry returns (bit (36));
 207 dcl  get_system_free_area_ entry returns (ptr);
 208 dcl  hcs_$validate_processid entry (bit (36) aligned, fixed bin (35));
 209 dcl  (
 210      ioa_,
 211      ioa_$rsnnl
 212      ) entry options (variable);
 213 dcl  pathname_ entry (char (*), char (*)) returns (char (168));
 214 dcl  timer_manager_$sleep entry (fixed bin (71), bit (2));
 215 dcl  transaction_manager_$abandon_txn entry (bit (36) aligned, fixed bin (35));
 216 dcl  transaction_manager_$abort_txn entry (bit (36) aligned, fixed bin (35));
 217 dcl  transaction_manager_$begin_txn entry (fixed bin, bit (36), bit (36) aligned, fixed bin (35));
 218 dcl  transaction_manager_$commit_txn entry (bit (36) aligned, fixed bin (35));
 219 dcl  transaction_manager_$get_current_txn_id entry (bit (36) aligned, fixed bin (35));
 220 dcl  transaction_manager_$get_state_description entry (fixed bin) returns (char (*));
 221 dcl  transaction_manager_$get_tdt_size entry (fixed bin);
 222 dcl  transaction_manager_$get_txn_index entry (bit (36) aligned, fixed bin (35)) returns (fixed bin);
 223 dcl  transaction_manager_$get_txn_info_index entry (fixed bin, ptr, fixed bin (35));
 224 dcl  transaction_manager_$handle_conditions entry ();
 225 dcl  transaction_manager_$kill_txn entry (bit (36) aligned, fixed bin (35));
 226 dcl  transaction_manager_$resume_txn entry (fixed bin (35));
 227 dcl  transaction_manager_$rollback_txn entry (bit (36) aligned, fixed bin, fixed bin (35));
 228 
 229 /* Builtins */
 230 
 231 dcl  (addr, addrel, character, clock, fixed, hbound, index, length, ltrim, null, rtrim, substr, unspec, verify) builtin;
 232 
 233 /* Conditions */
 234 
 235 dcl  (any_other, cleanup, dm_not_available_, sub_error_) condition;
 236 %page;
 237           call cu_$af_return_arg (arg_count, return_ptr, return_len, code);
 238           if code = 0 then do;
 239                af_sw = "1"b;
 240                complain = active_fnc_err_;
 241                complain_suppress_name = active_fnc_err_$suppress_name;
 242           end;
 243           else if code = error_table_$not_act_fnc then do;
 244                af_sw = "0"b;
 245                complain = com_err_;
 246                complain_suppress_name = com_err_$suppress_name;
 247           end;
 248           else do;
 249                call com_err_ (code, "transaction");
 250                call ERROR_RETURN ();
 251           end;
 252 
 253           if arg_count = 0 then do;
 254                my_name = "txn key";
 255                call complain_suppress_name (error_table_$noarg, "transaction", "^a", USAGE_STRING ("{other_args}"));
 256                call ERROR_RETURN ();
 257           end;
 258 
 259           call cu_$arg_ptr (1, arg_ptr, arg_len, code);
 260           if code ^= 0 then do;
 261                call complain (code, "transaction", "Argument 1.");
 262                call ERROR_RETURN ();
 263           end;
 264 
 265           if arg = "e" | arg = "st" then do;
 266                key_ptr = addr (key_buffer);
 267                key_len = length (key_buffer);
 268                if arg = "e"
 269                then key = "execute";
 270                else key = "status";
 271           end;
 272           else do;
 273                key_ptr = arg_ptr;
 274                key_len = arg_len;
 275           end;
 276 
 277           do key_index = hbound (KEY_NAMES, 1) by -1 to 1 while (KEY_NAMES (key_index) ^= key);
 278           end;
 279           if key_index = 0 then do;
 280                call complain (0, "transaction", "Invalid key argument ^a", arg);
 281                call ERROR_RETURN ();
 282           end;
 283 
 284           my_name = "txn " || rtrim (KEY_NAMES (key_index));
 285 
 286           on dm_not_available_ begin;
 287                call complain (dm_error_$system_not_initialized, my_name);
 288                call ERROR_RETURN ();
 289           end;
 290 
 291           go to KEY (key_index);
 292 RETURN:
 293           return;
 294 %page;
 295 /* "txn abandon" */
 296 KEY (1):
 297           if arg_count > 1 then do;
 298                call complain_suppress_name (error_table_$too_many_args, my_name, USAGE_STRING (""));
 299                call ERROR_RETURN ();
 300           end;
 301 
 302           on sub_error_ begin;
 303                code = SUB_ERROR_CODE ();
 304                if code ^= 0 then go to ABANDON_ATTEMPTED;
 305           end;
 306 
 307           call transaction_manager_$abandon_txn (CURRENT_ID (), code);
 308 ABANDON_ATTEMPTED:
 309           if code ^= 0 then do;
 310                if af_sw
 311                then return_arg = "false";
 312                else call complain (code, my_name);
 313           end;
 314           else do;
 315                if af_sw then return_arg = "true";
 316           end;
 317 
 318           return;
 319 %page;
 320 /* txn abort */
 321 KEY (2):
 322           if arg_count > 1 then do;
 323                call complain_suppress_name (error_table_$too_many_args, my_name, USAGE_STRING (""));
 324                call ERROR_RETURN ();
 325           end;
 326 
 327           on sub_error_ begin;
 328                code = SUB_ERROR_CODE ();
 329                if code ^= 0 then go to ABORT_ATTEMPTED;
 330           end;
 331 
 332           call transaction_manager_$abort_txn (CURRENT_ID (), code);
 333 ABORT_ATTEMPTED:
 334           if code ^= 0 then do;
 335                if af_sw
 336                then return_arg = "false";
 337                else call complain (code, my_name);
 338           end;
 339           else do;
 340                if af_sw then return_arg = "true";
 341           end;
 342 
 343           return;
 344 %page;
 345 /* txn begin */
 346 KEY (3):
 347           wait_sw = "0"b;
 348           wait_usec = LONG_TIME_USEC;
 349 
 350           do arg_index = 2 to arg_count;
 351 
 352                call cu_$arg_ptr (arg_index, arg_ptr, arg_len, code);
 353 
 354                if index (arg, "-") ^= 1 then do;
 355                     call complain_suppress_name (error_table_$too_many_args, my_name, USAGE_STRING ("{-control_args}"));
 356                     call ERROR_RETURN ();
 357                end;
 358 
 359                else if arg = "-no_wait" | arg = "-nwt" then wait_sw = "0"b;
 360 
 361                else if arg = "-wait" | arg = "-wt" then do;
 362                     arg_index = arg_index + 1;
 363                     if arg_index > arg_count then do;
 364                          call complain (0, my_name, "No value specified for -wait");
 365                          call ERROR_RETURN ();
 366                     end;
 367                     call cu_$arg_ptr (arg_index, arg_ptr, arg_len, code);
 368                     wait_seconds = cv_dec_check_ (arg, code);
 369                     if code ^= 0 then do;
 370                          call complain (code, my_name, "Invalid -wait number of seconds ^a", arg);
 371                          call ERROR_RETURN ();
 372                     end;
 373                     wait_sw = "1"b;
 374                     wait_usec = (wait_seconds + TEN_SECONDS) * USEC_PER_SECOND;
 375                                                             /* extra 10 because that's how often we try */
 376                end;
 377 
 378                else if arg = "-wait_indefinitely" | arg = "-wti" then do;
 379                     wait_sw = "1"b;
 380                     wait_usec = LONG_TIME_USEC;
 381                end;
 382 
 383                else do;
 384                     call complain (error_table_$badopt, my_name, "^a", arg);
 385                     call ERROR_RETURN ();
 386                end;
 387           end;
 388 
 389           on sub_error_ begin;
 390                code = SUB_ERROR_CODE ();
 391                if code ^= 0 then go to BEGIN_ATTEMPTED;
 392           end;
 393 
 394           bj_opening_id = "0"b;                             /* use default BJ */
 395 
 396           start_usec = clock ();
 397           had_to_wait_sw = "0"b;
 398 
 399           do while (^had_to_wait_sw | clock () - start_usec < wait_usec);
 400 
 401                call transaction_manager_$begin_txn (TM_NORMAL_MODE, bj_opening_id, txn_id, code);
 402 BEGIN_ATTEMPTED:
 403                if code = 0 then do;
 404                     if had_to_wait_sw then do;
 405                          call date_time_ (start_usec, requested_time_str);
 406                          call date_time_ (clock (), begun_time_str);
 407                          call ioa_ ("Transaction requested at ^a begun ^a", requested_time_str, begun_time_str);
 408                     end;
 409                     if af_sw then return_arg = "true";
 410                     return;
 411                end;
 412                else if ^wait_sw | code ^= dm_error_$system_not_initialized then do;
 413                     if af_sw then return_arg = "false";
 414                     else call complain (code, my_name);
 415                     call ERROR_RETURN ();
 416                end;
 417 
 418 /* Wait 10 seconds */
 419 
 420                call timer_manager_$sleep (TEN_SECONDS, RELATIVE_TIME_OPTION);
 421                had_to_wait_sw = "1"b;
 422           end;
 423 
 424           if af_sw then return_arg = "false";
 425           else call complain (0, my_name, "Data Management not available within ^a seconds.", wait_seconds);
 426 
 427           call ERROR_RETURN ();
 428 %page;
 429 /* txn commit */
 430 KEY (4):
 431           if arg_count > 1 then do;
 432                call complain_suppress_name (error_table_$too_many_args, my_name, USAGE_STRING (""));
 433                call ERROR_RETURN ();
 434           end;
 435 
 436           on sub_error_ begin;
 437                code = SUB_ERROR_CODE ();
 438                if code ^= 0 then go to COMMIT_ATTEMPTED;
 439           end;
 440 
 441           call transaction_manager_$commit_txn (CURRENT_ID (), code);
 442 COMMIT_ATTEMPTED:
 443           if code ^= 0 then do;
 444                if af_sw then return_arg = "false";
 445                else call complain (code, my_name);
 446           end;
 447           else if af_sw then return_arg = "true";
 448 
 449           return;
 450 %page;
 451 /* txn execute */
 452 KEY (5):
 453           cl_sw, on_action_specified_sw, wait_sw = "0"b;
 454           existing_txn_policy = EXISTING_TXN_NOT_ALLOWED;
 455           wait_usec = LONG_TIME_USEC;
 456           retry_count = 0;
 457           transaction_severity_ = FATAL_SEVERITY;
 458 
 459 /* Test for existing transaction */
 460 
 461           call transaction_manager_$get_current_txn_id (txn_id, code);
 462           txn_existed_sw = (code = 0);
 463 
 464           area_ptr = get_system_free_area_ ();
 465           first_handler_ptr = null;
 466           if ^txn_existed_sw then do;                       /* set up default handlers */
 467                call SAVE_HANDLER ("cleanup", ABORT_ACTION, 0);
 468                call SAVE_HANDLER ("any_other", SUSPEND_ACTION, 0);
 469           end;
 470 
 471           call cu_$arg_list_ptr (alp);
 472 
 473           command_line_start = 0;
 474           do arg_index = 2 to arg_count while (command_line_start = 0);
 475 
 476                call cu_$arg_ptr (arg_index, arg_ptr, arg_len, code);
 477 
 478                if index (arg, "-") ^= 1 then command_line_start = arg_index;
 479 
 480                else if arg = "-abandon_on" then do;
 481                     call GET_CONDITION_LIST ("-abandon_on", arg_index, ABANDON_ACTION, 0);
 482                     if ^on_action_specified_sw then do;
 483                          on_action_specified_sw = "1"b;
 484                          on_action_name = "-abandon_on";
 485                     end;
 486                end;
 487 
 488                else if arg = "-abort_on" then do;
 489                     call GET_CONDITION_LIST ("-abort_on", arg_index, ABORT_ACTION, 0);
 490                     if ^on_action_specified_sw then do;
 491                          on_action_specified_sw = "1"b;
 492                          on_action_name = "-abort_on";
 493                     end;
 494                end;
 495 
 496                else if arg = "-command_level" | arg = "-cl" then cl_sw = "1"b;
 497 
 498                else if arg = "-existing_transaction_allowed" | arg = "-eta"
 499                then existing_txn_policy = EXISTING_TXN_ALLOWED;
 500 
 501                else if arg = "-existing_transaction_required" | arg = "-etr"
 502                then existing_txn_policy = EXISTING_TXN_REQUIRED;
 503 
 504                else if arg = "-no_action_on" then do;
 505                     call GET_CONDITION_LIST ("-no_action_on", arg_index, NO_ACTION, 0);
 506                     if ^on_action_specified_sw then do;
 507                          on_action_specified_sw = "1"b;
 508                          on_action_name = "-no_action_on";
 509                     end;
 510                end;
 511 
 512                else if arg = "-no_existing_transaction_allowed" | arg = "-neta"
 513                then existing_txn_policy = EXISTING_TXN_NOT_ALLOWED;
 514 
 515                else if arg = "-no_wait" | arg = "-nwt" then wait_sw = "0"b;
 516 
 517                else if arg = "-retry_on" then do;
 518                     arg_index = arg_index + 1;
 519                     call cu_$arg_ptr (arg_index, arg_ptr, arg_len, code);
 520                     if arg_index > arg_count then do;
 521                          call complain (0, my_name, "No number or condition list specified for -retry_on");
 522                          call ERROR_RETURN ();
 523                     end;
 524                     retry_limit = cv_dec_check_ (arg, code);
 525                     if code ^= 0 then do;
 526                          call complain (code, my_name, "Invalid count ^a for -retry_on", arg);
 527                          call ERROR_RETURN ();
 528                     end;
 529                     call GET_CONDITION_LIST ("-retry_on", arg_index, RETRY_ACTION, retry_limit);
 530                     if ^on_action_specified_sw then do;
 531                          on_action_specified_sw = "1"b;
 532                          on_action_name = "-retry_on";
 533                     end;
 534                end;
 535 
 536                else if arg = "-suspend_on" then do;
 537                     call GET_CONDITION_LIST ("-suspend_on", arg_index, SUSPEND_ACTION, 0);
 538                     if ^on_action_specified_sw then do;
 539                          on_action_specified_sw = "1"b;
 540                          on_action_name = "-suspend_on";
 541                     end;
 542                end;
 543 
 544                else if arg = "-wait" | arg = "-wt" then do;
 545                     arg_index = arg_index + 1;
 546                     if arg_index > arg_count then do;
 547                          call complain (0, my_name, "No value specified for -wait");
 548                          call ERROR_RETURN ();
 549                     end;
 550                     call cu_$arg_ptr (arg_index, arg_ptr, arg_len, code);
 551                     wait_seconds = cv_dec_check_ (arg, code);
 552                     if code ^= 0 then do;
 553                          call complain (code, my_name, "^a", arg);
 554                          call ERROR_RETURN ();
 555                     end;
 556                     wait_sw = "1"b;
 557                     wait_usec = (wait_seconds + TEN_SECONDS) * USEC_PER_SECOND;
 558                                                             /* extra 10 because that's how often we try */
 559                end;
 560 
 561                else if arg = "-wait_indefinitely" | arg = "-wti" then do;
 562                     wait_sw = "1"b;
 563                     wait_usec = LONG_TIME_USEC;
 564                end;
 565 
 566                else do;
 567                     call complain (error_table_$badopt, my_name, "^a", arg);
 568                     call ERROR_RETURN ();
 569                end;
 570           end;
 571 
 572           if command_line_start > 0 & cl_sw then do;
 573                call complain (0, my_name, "Command line is incompatible with -command_level.");
 574                call ERROR_RETURN ();
 575           end;
 576 
 577           if on_action_specified_sw & existing_txn_policy ^= EXISTING_TXN_NOT_ALLOWED then do;
 578                call complain (0, my_name, "-existing_transaction_^[allowed^;required^] is incompatible with ^a",
 579                     existing_txn_policy = EXISTING_TXN_ALLOWED, on_action_name);
 580                call ERROR_RETURN ();
 581           end;
 582 
 583           if txn_existed_sw & existing_txn_policy = EXISTING_TXN_NOT_ALLOWED then do;
 584                call complain (0, my_name, "Current transaction already in effect, id = ^w", txn_id);
 585                call ERROR_RETURN ();
 586           end;
 587           if ^txn_existed_sw & existing_txn_policy = EXISTING_TXN_REQUIRED then do;
 588                call complain (0, my_name, "No current transaction, -existing_transaction_required.");
 589                call ERROR_RETURN ();
 590           end;
 591 
 592 /* Try to begin a transaction if necessary */
 593 
 594           on sub_error_ begin;
 595                code = SUB_ERROR_CODE ();
 596                if code = dm_error_$system_not_initialized
 597                then go to EXECUTE_BEGIN_ATTEMPTED;
 598                else call continue_to_signal_ (0);
 599           end;
 600 
 601           if ^txn_existed_sw then
 602                on cleanup begin;
 603                     call ABORT_OR_ABANDON (txn_id, succeeded_sw);
 604                end;
 605 
 606           bj_opening_id = "0"b;
 607 
 608           start_usec = clock ();
 609           had_to_wait_sw = "0"b;
 610 
 611           do while (^had_to_wait_sw | clock () - start_usec < wait_usec);
 612 
 613                if txn_existed_sw then code = 0;
 614                else call transaction_manager_$begin_txn (TM_NORMAL_MODE, bj_opening_id, txn_id, code);
 615 EXECUTE_BEGIN_ATTEMPTED:
 616                if code = 0 then do;
 617                     if had_to_wait_sw then do;
 618                          call date_time_ (start_usec, requested_time_str);
 619                          call date_time_ (clock (), begun_time_str);
 620                          call ioa_ ("Transaction requested at ^a begun ^a", requested_time_str, begun_time_str);
 621                     end;
 622 RETRY:
 623                     call EXECUTE_COMMAND_LINE ();
 624 
 625                     if ^txn_existed_sw then do;
 626                          call transaction_manager_$commit_txn (txn_id, code);
 627                          if code ^= 0 then do;
 628                               call ABORT_OR_ABANDON (txn_id, succeeded_sw);
 629                               if succeeded_sw then transaction_severity_ = ABORT_OR_ABANDON_SEVERITY;
 630                               else transaction_severity_ = FAILED_ABORT_OR_ABANDON_SEVERITY;
 631                               if af_sw then return_arg = AF_SEVERITY_VALUE (transaction_severity_);
 632                               else call complain (code, my_name, "Unable to commit transaction.");
 633                               call ERROR_RETURN ();
 634                          end;
 635                     end;
 636                     if retry_count > 0 then do;
 637                          transaction_severity_ = RETRY_SEVERITY;
 638                          if ^af_sw then call complain (0, my_name,
 639                                    "^d retries were required to successfully execute the command line.", retry_count);
 640                     end;
 641                     else transaction_severity_ = NO_ERROR_SEVERITY;
 642                     if af_sw then return_arg = AF_SEVERITY_VALUE (transaction_severity_);
 643                     return;
 644                end;
 645                else if ^wait_sw | code ^= dm_error_$system_not_initialized then do;
 646                     transaction_severity_ = FATAL_SEVERITY;
 647                     if af_sw then return_arg = AF_SEVERITY_VALUE (transaction_severity_);
 648                     else call complain (code, my_name, "Could not begin transaction.");
 649                     call ERROR_RETURN ();
 650                end;
 651 
 652 /* Wait 10 seconds */
 653 
 654                call timer_manager_$sleep (TEN_SECONDS, RELATIVE_TIME_OPTION);
 655                had_to_wait_sw = "1"b;
 656           end;
 657 
 658           transaction_severity_ = FATAL_SEVERITY;
 659           if af_sw then return_arg = AF_SEVERITY_VALUE (transaction_severity_);
 660           else call complain (0, my_name, "Data Management not available within ^d seconds.", wait_seconds);
 661 
 662           return;
 663 %page;
 664 /* txn kill */
 665 KEY (6):
 666           if arg_count > 2 then do;
 667 KILL_USAGE:
 668                call complain_suppress_name (error_table_$too_many_args, my_name, USAGE_STRING ("{transaction_id}"));
 669                call ERROR_RETURN ();
 670           end;
 671 
 672           if arg_count = 2 then do;
 673                call cu_$arg_ptr (2, arg_ptr, arg_len, code);
 674                if index (arg, "-") = 1 then go to KILL_USAGE;
 675                fixed_txn_id = cv_dec_check_ (arg, code);
 676                if code ^= 0 then do;
 677                     call complain (code, my_name, "Invalid transaction id ^a", arg);
 678                     call ERROR_RETURN ();
 679                end;
 680                unspec (txn_id) = unspec (fixed_txn_id);
 681           end;
 682           else txn_id = CURRENT_ID ();
 683 
 684           on sub_error_ begin;
 685                code = SUB_ERROR_CODE ();
 686                if code ^= 0 then go to KILL_ATTEMPTED;
 687           end;
 688 
 689           call transaction_manager_$kill_txn (txn_id, code);
 690 KILL_ATTEMPTED:
 691           if code ^= 0 then do;
 692                if af_sw then return_arg = "false";
 693                else call complain (code, my_name);
 694           end;
 695           else do;
 696                if af_sw then return_arg = "true";
 697           end;
 698 
 699           return;
 700 %page;
 701 /* txn rollback */
 702 KEY (7):
 703           if arg_count > 1 then do;
 704                call complain_suppress_name (error_table_$too_many_args, my_name, USAGE_STRING (""));
 705                call ERROR_RETURN ();
 706           end;
 707 
 708           on sub_error_ begin;
 709                code = SUB_ERROR_CODE ();
 710                if code ^= 0 then go to ROLLBACK_ATTEMPTED;
 711           end;
 712 
 713           call transaction_manager_$rollback_txn (CURRENT_ID (), INITIAL_CHECKPOINT, code);
 714 ROLLBACK_ATTEMPTED:
 715           if code ^= 0 then do;
 716                if af_sw then return_arg = "false";
 717                else call complain (code, my_name);
 718           end;
 719           else do;
 720                if af_sw then return_arg = "true";
 721           end;
 722 
 723           return;
 724 %page;
 725 /* txn status */
 726 KEY (8):
 727           area_ptr = get_system_free_area_ ();
 728           tix_ptr, tm_info_ptr, txn_info_ptr = null;
 729 
 730           on cleanup call CLEAN_UP_STATUS ();
 731 
 732           tix_bound = arg_count - 1;
 733           allocate tix in (area) set (tix_ptr);
 734           tix_count = 0;
 735 
 736           unspec (print_switches), unspec (select_switches) = "0"b;
 737           multiple_info_sw, total_sw = "0"b;
 738 
 739           do arg_index = 2 to arg_count;
 740 
 741                call cu_$arg_ptr (arg_index, arg_ptr, arg_len, code);
 742 
 743                if index (arg, "-") ^= 1 then do;
 744                     if af_sw then ctl_args_str = "-control_arg";
 745                     else ctl_args_str = "-control_args";
 746                     call complain_suppress_name (error_table_$too_many_args, my_name, USAGE_STRING (ctl_args_str));
 747                     go to STATUS_RETURN;
 748                end;
 749 
 750 /* Control args for selecting transactions */
 751 
 752                if arg = "-abandoned" then
 753                     if af_sw then go to BAD_STATUS_AF_ARG;
 754                     else select_switches.abandoned = "1"b;
 755                else if arg = "-all" | arg = "-a" then
 756                     if af_sw then go to BAD_STATUS_AF_ARG;
 757                     else select_switches.all, total_sw = "1"b;
 758                else if arg = "-dead" then
 759                     if af_sw then go to BAD_STATUS_AF_ARG;
 760                     else select_switches.dead, select_switches.all = "1"b;
 761                else if arg = "-total" | arg = "-tt" then
 762                     if af_sw then go to BAD_STATUS_AF_ARG;
 763                     else total_sw = "1"b;
 764 
 765                else if arg = "-transaction_id" | arg = "-tid" | arg = "-id" then do;
 766                     if arg_index = arg_count then print_switches.tid = "1"b;
 767                     else do;
 768                          call cu_$arg_ptr (arg_index + 1, arg_ptr, arg_len, code);
 769                          if index (arg, "-") = 1 then print_switches.tid = "1"b;
 770                          else do;                           /* -tid N */
 771                               arg_index = arg_index + 1;
 772                               fixed_txn_id = cv_dec_check_ (arg, code);
 773                               if code ^= 0 then do;
 774                                    call complain (code, my_name, "Invalid transaction id ^a", arg);
 775                                    go to STATUS_RETURN;
 776                               end;
 777                               unspec (txn_id) = unspec (fixed_txn_id);
 778                               txn_index = transaction_manager_$get_txn_index (txn_id, code);
 779                               if code ^= 0 then call complain (code, my_name, "transaction id = ^a", arg);
 780                               else do;
 781                                    select_switches.tid = "1"b;
 782                                    tix_count = tix_count + 1;
 783                                    tix (tix_count) = txn_index;
 784                               end;
 785                          end;
 786                     end;
 787                end;
 788 
 789                else if arg = "-transaction_index" | arg = "-tix" | arg = "-index" then do;
 790                     if arg_index = arg_count then print_switches.tix = "1"b;
 791                     else do;
 792                          call cu_$arg_ptr (arg_index + 1, arg_ptr, arg_len, code);
 793                          if index (arg, "-") = 1
 794                          then print_switches.tix = "1"b;
 795                          else do;
 796                               arg_index = arg_index + 1;
 797                               txn_index = cv_dec_check_ (arg, code);
 798                               if code ^= 0 then do;
 799                                    call complain (code, my_name, "Invalid transaction index ^a", arg);
 800                                    go to STATUS_RETURN;
 801                               end;
 802                               select_switches.tix = "1"b;
 803                               tix_count = tix_count + 1;
 804                               tix (tix_count) = txn_index;
 805                          end;
 806                     end;
 807                end;
 808 
 809 /* Control args for selecting fields to print */
 810 
 811                else if arg = "-before_journal_path" | arg = "-bj_path" then call REQUEST_INFO (print_switches.bj_path);
 812                else if arg = "-begun" | arg = "-date_time_begun" | arg = "-dtbg" then
 813                     call REQUEST_INFO (print_switches.dtm);
 814                else if arg = "-error_info" | arg = "-error" then call REQUEST_INFO (print_switches.errors);
 815                else if arg = "-owner" then call REQUEST_INFO (print_switches.owner);
 816                else if arg = "-process_id" | arg = "-pid" then call REQUEST_INFO (print_switches.pid);
 817                else if arg = "-rollback_count" | arg = "-rbc" then call REQUEST_INFO (print_switches.rollback_count);
 818                else if arg = "-state" then call REQUEST_INFO (print_switches.state);
 819                else if arg = "-switches" | arg = "-switch" | arg = "-sw" then call REQUEST_INFO (print_switches.switches);
 820 
 821                else do;
 822 BAD_STATUS_AF_ARG:
 823                     call complain (error_table_$badopt, my_name, "^a", arg);
 824                     go to STATUS_RETURN;
 825                end;
 826           end;
 827 
 828           if af_sw & tix_count > 1 then do;
 829                call complain (0, my_name, "Can return info for only one transaction.");
 830                go to STATUS_RETURN;
 831           end;
 832 
 833           on sub_error_ begin;                              /* eg., DM initialization error */
 834                code = SUB_ERROR_CODE ();
 835                if code ^= 0 then do;
 836                     call complain (code, my_name);
 837                     go to RETURN;
 838                end;
 839           end;
 840 
 841           if tix_count = 0 & ^select_switches.all & ^total_sw then do;
 842                tix_count = tix_count + 1;
 843                txn_id = CURRENT_ID ();
 844                tix (tix_count) = transaction_manager_$get_txn_index (txn_id, code);
 845                if code ^= 0 then do;
 846                     call complain (code, my_name, "transaction id = ^o", fixed (txn_id));
 847                     go to STATUS_RETURN;
 848                end;
 849           end;
 850 
 851           if unspec (print_switches) = "0"b
 852           then if af_sw then do;
 853                     call complain_suppress_name (error_table_$noarg, my_name, "Usage:  [txn status -control_arg]");
 854                     go to STATUS_RETURN;
 855                end;
 856                else do;
 857                     unspec (print_switches) = unspec (PRINT_ALL_INFO);
 858                     multiple_info_sw = "1"b;
 859                end;
 860 
 861           if select_switches.all | total_sw then
 862 EXAMINE_WHOLE_TDT: do;
 863 
 864                call transaction_manager_$get_tdt_size (tdt_max_count);
 865                if tdt_max_count = 0 then do;
 866                     if af_sw then call complain (0, my_name, "No transactions defined.");
 867                                                             /* should never happen */
 868                     else call ioa_ ("No transactions defined.");
 869                     go to STATUS_RETURN;
 870                end;
 871 
 872                allocate tm_info in (area) set (tm_info_ptr);
 873                allocate txn_info in (area) set (txn_info_ptr);
 874                txn_info.version = TXN_INFO_VERSION_5;
 875 
 876                do tdt_index = 1 to tdt_max_count;
 877                     call transaction_manager_$get_txn_info_index (tdt_index, txn_info_ptr, code);
 878                     if code ^= 0 then do;
 879                          call complain (code, my_name, "TDT entry #^d", tdt_index);
 880                          go to STATUS_RETURN;
 881                     end;
 882 
 883                     tm_info (tdt_index) = txn_info;
 884                end;
 885 
 886 /* Print totals if requested */
 887 
 888                if total_sw then do;
 889 
 890                     abandoned_count, dead_count, error_count, txn_count, used_count = 0;
 891                     do tdt_index = 1 to tdt_max_count;
 892                          if tm_info.owner_process_id (tdt_index) ^= "0"b then used_count = used_count + 1;
 893                          if DEAD_PROCESS (tm_info.owner_process_id (tdt_index)) then dead_count = dead_count + 1;
 894                          if tm_info.abandoned_sw (tdt_index) then abandoned_count = abandoned_count + 1;
 895                          if tm_info.txn_id (tdt_index) ^= "0"b then txn_count = txn_count + 1;
 896                          if tm_info.error_sw (tdt_index) then error_count = error_count + 1;
 897                     end;
 898 
 899                     call ioa_ ("TDT size: ^d entries", tdt_max_count);
 900                     call ioa_ ("In use: ^d", used_count);
 901                     call ioa_ ("Dead processes: ^d", dead_count);
 902                     call ioa_ ("Abandoned entries: ^d", abandoned_count);
 903                     call ioa_ ("Transactions: ^d", txn_count);
 904                     call ioa_ ("Error transactions: ^d", error_count);
 905                     call ioa_ ("");
 906                end;
 907 
 908 /* Print or return individual transaction information */
 909 
 910                printed_something_sw = "0"b;
 911                if af_sw then return_arg = """""";           /* default value is "" (eg., no txn) */
 912 
 913                if select_switches.all
 914                then do tdt_index = 1 to tdt_max_count;
 915 
 916                     if tm_info.owner_process_id (tdt_index) ^= "0"b then do;
 917                          txn_info = tm_info (tdt_index);
 918                          call PRINT_ENTRY ();
 919                     end;
 920                end;
 921 
 922                else do tix_index = 1 to tix_count;
 923                     txn_info = tm_info (tix (tix_index));
 924                     call PRINT_ENTRY ();
 925                end;
 926 
 927                if ^printed_something_sw & ^af_sw &
 928                     (select_switches.abandoned | select_switches.dead | select_switches.tid | select_switches.tix) then
 929                     call complain (0, my_name, "No entries with specified attributes.");
 930           end EXAMINE_WHOLE_TDT;
 931 
 932           else EXAMINE_SPECIFIED_ENTRIES: do;
 933                allocate txn_info in (area) set (txn_info_ptr);
 934                txn_info.version = TXN_INFO_VERSION_5;
 935 
 936                do tix_index = 1 to tix_count;
 937                     call transaction_manager_$get_txn_info_index (tix (tix_index), txn_info_ptr, code);
 938                     if code = 0 then call PRINT_ENTRY ();
 939                     else call complain (code, my_name, "TDT entry #^d.", tix (tix_index));
 940                end;
 941           end EXAMINE_SPECIFIED_ENTRIES;
 942 STATUS_RETURN:
 943           call CLEAN_UP_STATUS ();
 944 
 945           return;
 946 %page;
 947 ABORT_OR_ABANDON: proc (P_txn_id, P_succeeded_sw);
 948 
 949 dcl  P_txn_id bit (36) aligned;
 950 dcl  P_succeeded_sw bit (1);
 951 dcl  code fixed bin (35);
 952 
 953           call transaction_manager_$abort_txn (P_txn_id, code);
 954           if code ^= 0 then do;
 955                call transaction_manager_$abandon_txn (P_txn_id, code);
 956                if code ^= 0 then do;
 957                     P_succeeded_sw = "0"b;
 958                     call ERROR_RETURN ();
 959                end;
 960           end;
 961           P_succeeded_sw = "1"b;
 962           return;
 963 
 964      end ABORT_OR_ABANDON;
 965 %page;
 966 AF_SEVERITY_VALUE: proc (P_severity) returns (char (*));
 967 
 968 dcl  P_severity fixed bin;
 969 
 970           if P_severity < 2 then return ("true");
 971           else return ("false");
 972 
 973      end AF_SEVERITY_VALUE;
 974 %page;
 975 CLEAN_UP_STATUS: proc;
 976 
 977           if tix_ptr ^= null then free tix in (area);
 978           if tm_info_ptr ^= null then free tm_info in (area);
 979           if txn_info_ptr ^= null then free txn_info in (area);
 980 
 981      end CLEAN_UP_STATUS;
 982 %page;
 983 CODE_DESCRIPTION: proc (P_code) returns (char (100));
 984 
 985 dcl  P_code fixed bin (35);
 986 dcl  message char (100);
 987 dcl  dm_error_$ external bit (36) aligned;
 988 dcl  better_message char (100);
 989 dcl  better_code fixed bin (35);
 990 dcl  pp_as_word bit (36) aligned;
 991 dcl  segno builtin;
 992 
 993 %include packed_pointer;
 994 
 995           call convert_status_code_ (P_code, "", message);
 996           if substr (message, 1, 4) = "Code" then do;       /* Perhaps dm_error_ in another process */
 997                pp_as_word = unspec (P_code);
 998                packed_pointer_ptr = addr (pp_as_word);
 999                packed_pointer.segno = segno (addr (dm_error_$));
1000                unspec (better_code) = pp_as_word;
1001                call convert_status_code_ (better_code, "", better_message);
1002                if substr (better_message, 1, 4) ^= "Code" then message = better_message;
1003           end;
1004           return (message);
1005 
1006      end CODE_DESCRIPTION;
1007 %page;
1008 CONDITION_HANDLER: proc (P_txn_id, P_retry_count, P_retry_label);
1009 
1010 dcl  P_txn_id bit (36) aligned;
1011 dcl  P_retry_count fixed bin;
1012 dcl  P_retry_label label variable;
1013 dcl  p ptr;
1014 dcl  condition_name char (32);
1015 
1016           if handler_invoked_sw then do;
1017                call continue_to_signal_ (0);
1018                handler_invoked_sw = "0"b;
1019                return;
1020           end;
1021           handler_invoked_sw = "1"b;
1022 
1023           if first_handler_ptr = null then return;          /* no handler for any condition */
1024 
1025           call find_condition_info_ (null, addr (cond_info), code);
1026           if code ^= 0 then condition_name = "any_other";   /* can't get name, trigger the any_other handler */
1027           else condition_name = cond_info.condition_name;
1028 
1029 /* Try the specific condition name */
1030 
1031           do p = first_handler_ptr repeat (p -> handler_node.next_ptr) while (p ^= null);
1032                if p -> handler_node.condition_name = condition_name then do;
1033                     call do_action (p, P_txn_id, P_retry_count, P_retry_label);
1034                     return;
1035                end;
1036           end;
1037 
1038 /* That having failed, look for an any_other handler */
1039 
1040           do p = first_handler_ptr repeat (p -> handler_node.next_ptr) while (p ^= null);
1041                if p -> handler_node.condition_name = "any_other" then do;
1042                     call do_action (p, P_txn_id, P_retry_count, P_retry_label);
1043                     return;
1044                end;
1045           end;
1046 
1047           handler_invoked_sw = "0"b;
1048 
1049           return;
1050 
1051 
1052 do_action: proc (P_ptr, P_txn_id, P_retry_count, P_retry_label);
1053 
1054 dcl  P_ptr ptr;
1055 dcl  P_txn_id bit (36) aligned;
1056 dcl  (P_retry_count, action) fixed bin;
1057 dcl  code fixed bin (35);
1058 dcl  P_retry_label label variable;
1059 
1060           action = P_ptr -> handler_node.action;
1061           if action = ABANDON_ACTION then do;
1062                call transaction_manager_$abandon_txn (P_txn_id, code);
1063                if code ^= 0 then transaction_severity_ = FAILED_ABORT_OR_ABANDON_SEVERITY;
1064                else transaction_severity_ = ABORT_OR_ABANDON_SEVERITY;
1065                if af_sw then return_arg = AF_SEVERITY_VALUE (transaction_severity_);
1066                else call complain (0, my_name,
1067                          "Abandoning the command line and its transaction because the ^a condition was signaled.",
1068                          P_ptr -> handler_node.condition_name);
1069                goto RETURN;
1070           end;
1071           else if action = ABORT_ACTION then do;
1072                call transaction_manager_$abort_txn (P_txn_id, code);
1073                if code ^= 0 then transaction_severity_ = FAILED_ABORT_OR_ABANDON_SEVERITY;
1074                else transaction_severity_ = ABORT_OR_ABANDON_SEVERITY;
1075                if af_sw then return_arg = AF_SEVERITY_VALUE (transaction_severity_);
1076                else call complain (0, my_name,
1077                          "Aborting the command line and its transaction because the ^a condition was signaled.",
1078                          P_ptr -> handler_node.condition_name);
1079                goto RETURN;
1080           end;
1081           else if action = NO_ACTION then ;
1082           else if action = RETRY_ACTION then do;
1083                P_retry_count = P_retry_count + 1;
1084                if P_retry_count > p -> handler_node.retry_limit then return;
1085                else go to P_retry_label;
1086           end;
1087           else if action = SUSPEND_ACTION then do;
1088                call transaction_manager_$handle_conditions ();
1089                handler_invoked_sw = "0"b;
1090           end;
1091 
1092      end do_action;
1093 
1094      end CONDITION_HANDLER;
1095 %page;
1096 CURRENT_ID: proc returns (bit (36) aligned);
1097 
1098 dcl  txn_id bit (36) aligned;
1099 dcl  tried_resume_sw bit (1);
1100 dcl  code fixed bin (35);
1101 
1102           tried_resume_sw = "0"b;
1103 GET_ID:
1104           call transaction_manager_$get_current_txn_id (txn_id, code);
1105           if code ^= 0 then do;
1106                if code = dm_error_$transaction_suspended & ^tried_resume_sw then
1107                     if my_name = "txn status" then return (txn_id);
1108                     else if my_name = "txn abandon" | my_name = "txn abort" then do;
1109                          tried_resume_sw = "1"b;
1110                          code = 0;
1111                          call transaction_manager_$resume_txn (code);
1112                          if code ^= 0 then do;
1113                               if af_sw then return_arg = "false";
1114                               else call complain (code, my_name, "Could not resume transaction.");
1115                               go to RETURN;
1116                          end;
1117                          else go to GET_ID;
1118                     end;
1119                if txn_id = "0"b then do;
1120                     if af_sw then return_arg = "false";
1121                     else call complain (code, my_name);
1122                     go to RETURN;
1123                end;
1124           end;
1125           return (txn_id);
1126 
1127      end CURRENT_ID;
1128 %page;
1129 DEAD_PROCESS: proc (P_process_id) returns (bit (1));
1130 
1131 dcl  P_process_id bit (36) aligned;
1132 dcl  code fixed bin (35);
1133 
1134           if P_process_id = "0"b then return ("0"b);
1135 
1136           call hcs_$validate_processid (P_process_id, code);
1137           return (code ^= 0);
1138 
1139      end DEAD_PROCESS;
1140 %page;
1141 ERROR_RETURN: proc;
1142 
1143           go to RETURN;
1144 
1145      end ERROR_RETURN;
1146 %page;
1147 EXECUTE_COMMAND_LINE: proc;
1148 
1149 dcl  line_len fixed bin (21);
1150 dcl  arg_index fixed bin;
1151 
1152           if command_line_start > 0 then do;
1153                line_len = -1;
1154                do arg_index
1155                     = command_line_start to arg_count;
1156                     call cu_$arg_ptr_rel (arg_index, arg_ptr, arg_len, 0, alp);
1157                     line_len = line_len + arg_len + 1;
1158                end;
1159                begin;
1160 dcl  line char (line_len);
1161 
1162                     line = "";
1163                     line_len = -1;
1164                     do arg_index = command_line_start to arg_count;
1165                          call cu_$arg_ptr_rel (arg_index, arg_ptr, arg_len, 0, alp);
1166                          substr (line, line_len + 2, arg_len) = arg;
1167                          line_len = line_len + arg_len + 1;
1168                     end;
1169 
1170                     handler_invoked_sw = "0"b;
1171                     on any_other begin;
1172                          call CONDITION_HANDLER (txn_id, retry_count, RETRY);
1173                     end;
1174 
1175                     call cu_$cp (addr (line), line_len, code);
1176                     if code ^= 0 then transaction_severity_ = ABORT_OR_ABANDON_SEVERITY; /* Is this right? */
1177                end;
1178           end;
1179 
1180           else do;
1181                begin;
1182 dcl  var_line char (3000) varying;
1183 dcl  1 qi aligned like query_info;
1184 
1185                     unspec (qi) = "0"b;
1186                     qi.version = query_info_version_5;
1187                     qi.question_iocbp, qi.answer_iocbp, qi.explanation_ptr = null;
1188                     qi.suppress_name_sw = "1"b;
1189 
1190                     call command_query_ (addr (qi), var_line, "transaction execute", "Command line:");
1191 
1192                     handler_invoked_sw = "0"b;
1193                     on any_other begin;
1194                          call CONDITION_HANDLER (txn_id, retry_count, RETRY);
1195                     end;
1196 
1197                     call cu_$cp (addrel (addr (var_line), 1), length (var_line), code);
1198                     if code ^= 0 then transaction_severity_ = ABORT_OR_ABANDON_SEVERITY;
1199                end;
1200           end;
1201 
1202      end EXECUTE_COMMAND_LINE;
1203 %page;
1204 GET_CONDITION_LIST: proc (P_name, P_index, P_action, P_retry_limit);
1205 
1206 dcl  P_name char (*);
1207 dcl  (P_index, P_action, P_retry_limit, comma_pos, list_pos) fixed bin;
1208 dcl  condition_name char (32);
1209 dcl  COMMA char (1) int static options (constant) init (",");
1210 
1211           P_index = P_index + 1;
1212           if P_index > arg_count then do;
1213                call complain (0, my_name, "No condition list specified for ^a", P_name);
1214                go to RETURN;
1215           end;
1216           call cu_$arg_ptr_rel (P_index, arg_ptr, arg_len, code, alp);
1217 
1218           list_pos = 1;
1219           do while (list_pos <= arg_len);
1220 
1221                comma_pos = verify (substr (arg, list_pos), COMMA);
1222                if comma_pos = 0 then return;
1223 
1224                list_pos = list_pos + comma_pos - 1;
1225                comma_pos = index (substr (arg, list_pos), COMMA);
1226                if comma_pos = 0 then do;
1227                     condition_name = substr (arg, list_pos);
1228                     list_pos = arg_len + 1;
1229                end;
1230                else do;
1231                     condition_name = substr (arg, list_pos, comma_pos - 1);
1232                     list_pos = list_pos + comma_pos;
1233                end;
1234 
1235                call SAVE_HANDLER (condition_name, P_action, P_retry_limit);
1236           end;
1237 
1238           return;
1239 
1240      end GET_CONDITION_LIST;
1241 %page;
1242 PRINT_ENTRY: proc ();
1243 
1244 dcl  (buffer, dn) char (168);
1245 dcl  state_description_buffer char (68);
1246 dcl  (en, time_string) char (32);
1247 
1248           if txn_info.owner_process_id = "0"b then do;
1249                if af_sw & print_switches.pid then return_arg = "0";
1250                return;
1251           end;
1252 
1253           if select_switches.abandoned & ^txn_info.abandoned_sw then do;
1254                if ^select_switches.dead | ^DEAD_PROCESS (txn_info.owner_process_id) then return;
1255           end;
1256           else if select_switches.dead & ^DEAD_PROCESS (txn_info.owner_process_id) then return;
1257 
1258           printed_something_sw = "1"b;
1259 
1260           txn_exists_sw = (txn_info.txn_id ^= "0"b);
1261           print_no_txn_warning_sw = "0"b;
1262 
1263           if print_switches.tix then call PRINT_ITEM ("Transaction index", character (txn_info.txn_index), ENTRY_ITEM);
1264           if print_switches.tid then
1265                call PRINT_ITEM ("Transaction id", character (fixed (txn_info.txn_id)), TXN_ITEM);
1266           if print_switches.pid then do;
1267                call ioa_$rsnnl ("^w^[ (dead)^]", buffer, length (buffer), txn_info.owner_process_id,
1268                     DEAD_PROCESS (txn_info.owner_process_id) & ^af_sw);
1269                call PRINT_ITEM ("Process id", buffer, ENTRY_ITEM);
1270           end;
1271           if print_switches.owner then call PRINT_ITEM ("Owner", (txn_info.owner_name), ENTRY_ITEM);
1272           if print_switches.dtm then do;
1273                if txn_info.date_time_created = 0
1274                then time_string = "(undefined)";
1275                else call date_time_ (txn_info.date_time_created, time_string);
1276                call PRINT_ITEM ("Begun at", time_string, TXN_ITEM);
1277           end;
1278           if print_switches.state then do;
1279                state_description_buffer = transaction_manager_$get_state_description (txn_info.state);
1280                call PRINT_ITEM ("State", state_description_buffer, TXN_ITEM);
1281           end;
1282           if print_switches.errors then
1283                if ^txn_info.error_sw then call PRINT_ITEM ("Error", "none", TXN_ITEM);
1284                else call PRINT_ITEM ("Error", CODE_DESCRIPTION (txn_info.error_code), TXN_ITEM);
1285           if print_switches.rollback_count then
1286                call PRINT_ITEM ("Rollback count", character (txn_info.rollback_count), TXN_ITEM);
1287           if print_switches.bj_path then do;
1288                if txn_info.bj_uid = "0"b then
1289                     if af_sw then return_arg = "";
1290                     else call ioa_ ("No before journal.");
1291                else do;
1292                     if txn_info.owner_process_id = get_process_id_ () then
1293                          call before_journal_manager_$get_bj_path_from_oid (txn_info.bj_oid, dn, en, code);
1294                     else call before_journal_manager_$get_bj_path_from_uid (txn_info.bj_uid, dn, en, code);
1295                     if code ^= 0 then
1296                          call complain (code, my_name, "Before journal uid = ^w", txn_info.bj_uid);
1297                     else call PRINT_ITEM ("Before journal path", pathname_ (dn, en), TXN_ITEM);
1298                end;
1299           end;
1300           if print_switches.switches then do;
1301                if unspec (txn_info.flags) = "0"b then buffer = "none";
1302                else do;
1303                     buffer = "";
1304                     if txn_info.abandoned_sw then buffer = "ABANDONED";
1305                     if txn_info.kill_sw then call append ("KILL");
1306                     if txn_info.suspended_sw then call append ("SUSPENDED");
1307                     if txn_info.dead_process_sw then call append ("DEAD_PROCESS");
1308                end;
1309                call PRINT_ITEM ("Switches", buffer, TXN_ITEM);
1310           end;
1311 
1312           if print_no_txn_warning_sw then call ioa_ ("No transaction.");
1313 
1314           if multiple_info_sw & ^af_sw then call ioa_ (""); /* separate blocks of info */
1315 
1316 append: proc (P_str);
1317 
1318 dcl  P_str char (*);
1319 
1320           if buffer ^= "" then buffer = rtrim (buffer) || ",";
1321           buffer = rtrim (buffer) || P_str;
1322 
1323      end append;
1324 
1325      end PRINT_ENTRY;
1326 %page;
1327 PRINT_ITEM: proc (P_name, P_value, P_item_type);
1328 
1329 dcl  (P_name, P_value) char (*);
1330 dcl  P_item_type fixed bin;
1331 
1332           if af_sw then do;
1333                if txn_exists_sw | P_item_type = ENTRY_ITEM then return_arg = ltrim (rtrim (P_value));
1334           end;
1335 
1336           else if ^txn_exists_sw & P_item_type = TXN_ITEM then print_no_txn_warning_sw = "1"b;
1337 
1338           else if multiple_info_sw then call ioa_ ("^a: ^a", P_name, ltrim (rtrim (P_value)));
1339           else call ioa_ ("^a", ltrim (rtrim (P_value)));
1340 
1341      end PRINT_ITEM;
1342 %page;
1343 REQUEST_INFO: proc (P_sw);
1344 
1345 dcl  P_sw bit (1) unaligned;
1346 
1347           P_sw = "0"b;                                      /* to test if others on */
1348           if unspec (print_switches) ^= "0"b then do;
1349                if af_sw then do;
1350                     call complain (0, my_name, "Can only return one item of information.");
1351                     go to RETURN;
1352                end;
1353                multiple_info_sw = "1"b;
1354           end;
1355 
1356           P_sw = "1"b;
1357 
1358           return;
1359 
1360      end REQUEST_INFO;
1361 %page;
1362 SAVE_HANDLER: proc (P_condition_name, P_action, P_retry_limit);
1363 
1364 dcl  P_condition_name char (*);
1365 dcl  (P_action, P_retry_limit) fixed bin;
1366 dcl  (p, last_p) ptr;
1367 
1368           if first_handler_ptr = null then do;
1369                allocate handler_node in (area) set (p);
1370                first_handler_ptr = p;
1371 FILL_NEW_NODE:
1372                p -> handler_node.next_ptr = null;
1373                p -> handler_node.condition_name = P_condition_name;
1374 FILL_NODE:
1375                p -> handler_node.action = P_action;
1376                p -> handler_node.retry_limit = P_retry_limit;
1377                return;
1378           end;
1379           do p = first_handler_ptr repeat (p -> handler_node.next_ptr) while (p ^= null);
1380                if p -> handler_node.condition_name = P_condition_name then go to FILL_NODE;
1381                last_p = p;
1382           end;
1383           allocate handler_node in (area) set (p);
1384           last_p -> handler_node.next_ptr = p;
1385           go to FILL_NEW_NODE;
1386 
1387      end SAVE_HANDLER;
1388 %page;
1389 SUB_ERROR_CODE: proc returns (fixed bin (35));
1390 
1391           call find_condition_info_ (null, addr (cond_info), code);
1392           if code ^= 0 then return (dm_error_$system_not_initialized);
1393 
1394           if cond_info.info_ptr -> sub_error_info.default_restart then do;
1395                                                             /* a warning */
1396                call continue_to_signal_ (0);
1397                return (0);
1398           end;
1399 
1400           else return (cond_info.info_ptr -> sub_error_info.retval);
1401 
1402      end SUB_ERROR_CODE;
1403 %page;
1404 USAGE_STRING: proc (P_str) returns (char (128));
1405 
1406 dcl  P_str char (*);
1407 dcl  buffer char (128) varying;
1408 
1409           buffer = "Usage:  " || rtrim (my_name);
1410           if P_str ^= "" then buffer = buffer || " " || P_str;
1411           if af_sw
1412           then return ("[" || buffer || "]");
1413           else return (buffer);
1414 
1415      end USAGE_STRING;
1416 %page;
1417 %include condition_info;
1418 %page;
1419 %include condition_info_header;
1420 %page;
1421 %include dm_tm_modes;
1422 %page;
1423 %include dm_tm_txn_info;
1424 %page;
1425 %include query_info;
1426 %page;
1427 %include sub_error_info;
1428 
1429 
1430      end transaction;