1 /****^  ***********************************************************
   2         *                                                         *
   3         * Copyright, (C) Honeywell Bull Inc., 1987                *
   4         *                                                         *
   5         * Copyright, (C) Honeywell Information Systems Inc., 1987 *
   6         *                                                         *
   7         *********************************************************** */
   8 
   9 /* format: style4,indattr,ifthen,^indcomtxt,thendo,^indproc,^indblkcom,^indprocbody,initcol1,declareind8,dclind4,struclvlind3,comcol55 */
  10 
  11 bft:
  12 background_file_transfer:
  13      proc options (main);
  14 
  15 /* PROGRAM FUNCTION
  16 
  17 This is the routine that accepts command line arguments and then calls the
  18 appropriate entrypoint in bft_.  This procedure checks the number of arguments
  19 to the command and then if that is satisfactory then calls the appropriate
  20 subroutine to check the arguments themselves.  This is done by checking the
  21 first argument.  If it is valid, then a subroutine to handle that particular
  22 command is called.
  23 */
  24 
  25 /* NOTES
  26 */
  27 
  28 /****^  HISTORY COMMENTS:
  29   1) change(86-06-06,Eichele), approve(87-07-15,MCR7580),
  30      audit(87-07-30,RBarstad), install(87-08-07,MR12.1-1075):
  31      Created.
  32   2) change(87-10-23,Flegel), approve(87-10-23,MCR7787),
  33      audit(88-01-27,RWaters), install(88-02-24,MR12.2-1028):
  34      Added multiple entry queues, control args, and queue display.
  35   3) change(87-12-12,Flegel), approve(87-12-12,MCR7819),
  36      audit(88-01-27,RWaters), install(88-02-24,MR12.2-1028):
  37      Added control arguments for a wider scope of request capabilities.
  38                                                    END HISTORY COMMENTS */
  39 
  40 /* PARAMETERS */
  41 
  42 /* MISC VARIABLES */
  43 dcl key_procedure          entry variable;            /* Actual request handler */
  44 dcl reason                 char (256) var;            /* Error reason */
  45 dcl code                   fixed bin (35);
  46 
  47 /* GLOBAL */
  48 dcl display_sw             bit (1);                   /* List request */
  49 dcl unload_sw              bit (1);                   /* unload request */
  50 dcl store_sw               bit (1);                   /* store request */
  51 dcl recover_sw             bit (1);                   /* recover request */
  52 dcl load_sw                bit (1);                   /* load request */
  53 dcl fetch_sw               bit (1);                   /* fetch request */
  54 dcl cancel_sw              bit (1);                   /* cancel request */
  55 dcl priority               fixed bin;                 /* Queue number */
  56 dcl long_sw                bit (1);                   /* If queue display is long */
  57 dcl main_arg_ptr           ptr;                       /* Command arguments */
  58 dcl arg_pos                fixed bin;                 /* Argument being looked at */
  59 dcl arg_count              fixed bin;                 /* Number of arguments */
  60 dcl arg_len                fixed bin (21);            /* Argument length */
  61 dcl arg_ptr                ptr;                       /* Argument */
  62 dcl arg                    char (arg_len) based (arg_ptr);
  63 dcl 01 modes               like bft_queue_flags auto aligned; /* Transfer modes */
  64 
  65 /* STRUCTURES */
  66 
  67 /* SYSTEM CALLS */
  68 dcl cu_$arg_list_ptr        entry (ptr);
  69 dcl ioa_                   entry () options (variable);
  70 dcl absolute_pathname_     entry (char (*), char (*), fixed bin (35));
  71 dcl cu_$arg_ptr_rel        entry (fixed bin, ptr, fixed bin (21), fixed bin (35), ptr);
  72 dcl cu_$arg_count          entry (fixed bin, fixed bin (35));
  73 dcl com_err_               entry () options (variable);
  74 
  75 /* SYSTEM CALL SUPPORT */
  76 dcl error_table_$nodescr    fixed bin(35) ext static;
  77 dcl error_table_$inconsistent fixed bin (35) ext static;
  78 dcl error_table_$noarg     fixed bin (35) ext static;
  79 dcl error_table_$bad_arg   fixed bin (35) ext static;
  80 dcl error_table_$wrong_no_of_args fixed bin (35) ext static;
  81 
  82 /* EXTERNAL CALLS */
  83 dcl bft_$cancel            entry (fixed bin, char (*), fixed bin (35));
  84 dcl bft_queue_$display_element entry (ptr, bit (1), fixed bin, bit (1), bit (1));
  85 dcl bft_queue_$initiate    entry (ptr, fixed bin (35));
  86 dcl bft_$fetch             entry (char (*) var, char (*) var, bit (36) aligned, fixed bin, fixed bin (35));
  87 dcl bft_$load              entry (fixed bin (35));
  88 dcl bft_$recover_fetch     entry (fixed bin (35));
  89 dcl bft_$recover_store     entry (fixed bin (35));
  90 dcl bft_$store             entry (char (*) var, char (*) var, bit (36) aligned, fixed bin, fixed bin (35));
  91 dcl bft_$unload            entry (fixed bin (35));
  92 
  93 /* EXTERNAL CALL SUPPORT */
  94 dcl bft_error_table_$invalid_file_type  fixed bin(35) ext static;
  95 dcl bft_error_table_$invalid_keyword fixed bin (35) ext static;
  96 dcl bft_error_table_$invalid_priority fixed bin (35) ext static;
  97 dcl bft_error_table_$bft_not_loaded fixed bin (35) ext static;
  98 dcl ws_error_$invalid_capability_name fixed bin (35) ext static;
  99 
 100 /* BUILTINS */
 101 dcl null                   builtin;
 102 dcl unspec                 builtin;
 103 dcl substr                 builtin;
 104 dcl rank                   builtin;
 105 dcl addr                   builtin;
 106 dcl rtrim                  builtin;
 107 
 108 /* CONDITIONS */
 109 
 110 /* CONSTANTS */
 111 dcl NAME                   char (3) int static options (constant) init ("bft");
 112 dcl USAGE_CANCEL           char (128) var int static options (constant) init ("^3tUsage:  bft cancel request_identifier {request_identifier ...}");
 113 dcl USAGE_UNLOAD           char (128) var int static options (constant) init ("^3tUsage:  bft unload");
 114 dcl USAGE_RECOVER          char (128) var int static options (constant) init ("^3tUsage:  bft recover");
 115 dcl USAGE_LOAD             char (128) var int static options (constant) init ("^3tUsage:  bft load");
 116 dcl USAGE_BFT              char (128) var int static options (constant) init ("^3tUsage:  bft KEY {name1 {name2...name1N name2N}} {-control_args}");
 117 dcl USAGE_KEYS             char (128) var int static options (constant) init ("^6t(s)tore, (f)etch, (c)ancel, (ls) list, (l)oad, (u)nload, (r)ecover");
 118 
 119 /*^L*/
 120 
 121 /* INITIALIZATION */
 122 
 123 /* Set default transfer modes */
 124 
 125      priority = 3;                                    /* Queue 3 */
 126      unspec (modes) = ""b;                            /* "0" are default values */
 127      long_sw = "0"b;                                  /* Long queue display */
 128 
 129 /* Set request type switches */
 130 
 131      cancel_sw = "0"b;
 132      fetch_sw = "0"b;
 133      load_sw = "0"b;
 134      recover_sw = "0"b;
 135      store_sw = "0"b;
 136      unload_sw = "0"b;
 137      display_sw = "0"b;
 138 
 139 /* MAIN */
 140 
 141 /* Get MAIN's arg_ptr */
 142 
 143      call cu_$arg_list_ptr (main_arg_ptr);
 144      if main_arg_ptr = null then do;
 145           call com_err_ (error_table_$nodescr, NAME,
 146                "Getting argument pointer.");
 147           return;
 148      end;
 149 
 150 /* How many args are there ? */
 151 
 152      call cu_$arg_count (arg_count, code);
 153      if code ^= 0 then do;
 154           call com_err_ (code, NAME, "Getting argument count.");
 155           return;
 156      end;
 157 
 158 /* None, then this is a request for usage */
 159 
 160      if arg_count <= 0 then do;
 161           call com_err_ (error_table_$wrong_no_of_args, NAME);
 162           call ioa_ (USAGE_BFT);
 163           return;
 164      end;
 165 
 166 /* Extract the keyword */
 167 
 168      arg_pos = 0;
 169      call get_arg ("0"b, code);
 170      if code ^= 0 then do;
 171           call com_err_ (code, NAME);
 172           call ioa_ (USAGE_BFT);
 173           return;
 174      end;
 175 
 176 /* This argument MUST be a keyword, otherwise - what are we to do? */
 177 
 178      if (arg = "cancel" | arg = "c") then do;
 179           key_procedure = bft_cancel;
 180           cancel_sw = "1"b;
 181      end;
 182      else if (arg = "fetch" | arg = "f") then do;
 183           key_procedure = bft_fetch;
 184           fetch_sw = "1"b;
 185      end;
 186      else if (arg = "load" | arg = "l" | arg = "ld") then do;
 187           key_procedure = bft_load;
 188           load_sw = "1"b;
 189      end;
 190      else if (arg = "list" | arg = "ls") then do;
 191           key_procedure = bft_display;
 192           display_sw = "1"b;
 193      end;
 194      else if (arg = "recover" | arg = "r") then do;
 195           key_procedure = bft_recover;
 196           recover_sw = "1"b;
 197      end;
 198      else if (arg = "store" | arg = "s") then do;
 199           key_procedure = bft_store;
 200           store_sw = "1"b;
 201      end;
 202      else if (arg = "unload" | arg = "u" | arg = "uld") then do;
 203           key_procedure = bft_unload;
 204           unload_sw = "1"b;
 205      end;
 206      else do;
 207           call com_err_ (bft_error_table_$invalid_keyword, NAME, arg);
 208           call ioa_ (USAGE_KEYS);
 209           return;
 210      end;
 211 
 212 /* Parse through control arguments */
 213 
 214      call parse_control_args (code, reason);
 215      if code ^= 0 then do;
 216           call com_err_ (code, NAME, reason);
 217           return;
 218      end;
 219 
 220 /* We made it to here, so call the handler, skip the first "real" argument
 221    as it is the keyword */
 222 
 223      arg_pos = 0;
 224      call get_arg ("0"b, (0));
 225      call key_procedure ();
 226 
 227      return;
 228 
 229 /*^L*/
 230 
 231 /* INTERNAL ENTRIES */
 232 
 233 /*^L*/
 234 
 235 /* INTERNAL PROCEDURES */
 236 
 237 
 238 /* *** Procedure: cancel - Internal proc for bft  *** */
 239 
 240 bft_cancel:
 241      proc ();
 242 
 243 
 244 /* PROCEDURE FUNCTION
 245 
 246 Cancel an element from the queue, ONLY if it is not currenlty in transfer.
 247 */
 248 
 249 /* NOTES
 250 */
 251 
 252 /* PARAMETERS */
 253 
 254 /* MISC VARIABLES */
 255 dcl request_type           char (32) var;             /* Cancellation request type */
 256 dcl code                   fixed bin (35);            /* Error code */
 257 dcl passed                 fixed bin;                 /* Number of requests cancelled */
 258 
 259 /* STRUCTURES */
 260 
 261 /* INITIALIZATION */
 262      passed = 0;
 263 
 264 /* MAIN */
 265 
 266 /* Parse through each arg in the command line */
 267 
 268      do while (arg_pos < arg_count);
 269           call get_arg ("1"b, code);
 270           if code ^= 0 then do;
 271                if passed = 0 then
 272                     call com_err_ (code, NAME, arg);
 273                else
 274                     call com_err_ (code, NAME);
 275                goto CANCEL_RETURN;
 276           end;
 277 
 278 /* Determine which entry type we have, and cancel accordingly */
 279 
 280           if substr (arg, 1, 1) ^= "-" then
 281                call bft_$cancel (BFT_PATH_ID, arg, code);
 282           else do;
 283                request_type = arg;
 284                call get_arg ("0"b, code);
 285                if code ^= 0 then do;
 286                     call com_err_ (code, NAME);
 287                     return;
 288                end;
 289 
 290                if request_type = "-id" then
 291                     call bft_$cancel (BFT_TIME_ID, arg, code);
 292                else if request_type = "-entry" | request_type = "-et" then
 293                     call bft_$cancel (BFT_ENTRY_ID, arg, code);
 294           end;
 295 
 296 /* Is there an error ? */
 297 
 298           if code ^= 0 then do;
 299                call com_err_ (code, NAME, "Cancelling ^a.", arg);
 300                goto CANCEL_RETURN;
 301           end;
 302 
 303 /* Increment the cancellation count */
 304 
 305           passed = passed + 1;
 306      end;
 307 
 308 CANCEL_RETURN:
 309 
 310      if passed > 0 then
 311           call ioa_ ("^a: ^d request^[s^] submitted for cancellation.",
 312                NAME, passed, (passed > 1));
 313 
 314      end bft_cancel;
 315 
 316 /*^L*/
 317 
 318 /* *** Procedure: bft_display - Internal proc for bft  *** */
 319 
 320 bft_display:
 321      proc ();
 322 
 323 
 324 /* PROCEDURE FUNCTION
 325 
 326 Display the current entries in the queues.
 327 */
 328 
 329 /* NOTES
 330 */
 331 
 332 /* PARAMETERS */
 333 
 334 /* MISC VARIABLES */
 335 dcl running_count          fixed bin;
 336 dcl code                   fixed bin (35);
 337 dcl running                bit (1);                   /* Running element displayed */
 338 dcl i                      fixed bin;
 339 dcl empty_sw               bit (1);                   /* Queues are empty? */
 340 dcl slot                   fixed bin (35);            /* Queue traversal index */
 341 dcl count                  fixed bin (21);            /* Elements in queue */
 342 
 343 /* STRUCTURES */
 344 
 345 /* INITIALIZATION */
 346      empty_sw = "1"b;
 347 
 348 /* MAIN */
 349 
 350      call bft_queue_$initiate (queue_ptr, code);
 351      if code ^= 0 then do;
 352           call com_err_ (code, NAME, "Initiating queue.");
 353           return;
 354      end;
 355 
 356 /* Display the store queue */
 357 
 358      running = "0"b;
 359      running_count = 1;
 360      do i = BFT_MIN_PRIORITY to BFT_MAX_PRIORITY;
 361 
 362 /* Count how many requests are pending */
 363 
 364           count = 0;
 365           slot = queue.header.store_queue (i).first;
 366           do while (slot ^= 0);
 367                count = count + 1;
 368                slot = queue.array (slot).next;
 369           end;
 370 
 371 /* Tell user how many requests in store queue */
 372 
 373           if count > 0 then do;
 374                empty_sw = "1"b;                       /* To tell display_element to print a header */
 375                call ioa_ ("^/BFT Store Queue ^d:^20t^d request^[s^].^/",
 376                     i, running_count + count, (running_count + count > 1));
 377                running_count = 0;
 378 
 379 /* Display the running element */
 380 
 381                if queue.header.storing.flags.initiated & ^running then do;
 382                     call bft_queue_$display_element (addr (queue.header.storing),
 383                          long_sw, BFT_MULTICS_to_PC, "1"b, "1"b);
 384                     if long_sw then
 385                          call ioa_ ();
 386                     empty_sw = "0"b;
 387                     running = "1"b;
 388                end;
 389 
 390 /* Display the remainder of the queue */
 391 
 392                slot = queue.header.store_queue (i).first;
 393                do while (slot ^= 0);
 394                     call bft_queue_$display_element (addr (queue.array (slot)),
 395                          long_sw, BFT_MULTICS_to_PC, "0"b, empty_sw);
 396                     empty_sw = "0"b;
 397                     slot = queue.array (slot).next;
 398                     if long_sw & slot ^= 0 then
 399                          call ioa_ ();
 400                end;
 401           end;
 402      end;
 403 
 404 /* Display the running element if there are no pending elements */
 405 
 406      if queue.header.storing.flags.initiated & ^running then do;
 407           call ioa_ ("^/BFT Store Queue:^/");
 408           call bft_queue_$display_element (addr (queue.header.storing),
 409                long_sw, BFT_MULTICS_to_PC, "1"b, "1"b);
 410           empty_sw = "0"b;
 411           running = "1"b;
 412      end;
 413 
 414 /* Display the fetch queue */
 415 
 416      running = "0"b;
 417      running_count = 1;
 418      do i = BFT_MIN_PRIORITY to BFT_MAX_PRIORITY;
 419           count = 0;
 420           slot = queue.header.fetch_queue (i).first;
 421           do while (slot ^= 0);
 422                count = count + 1;
 423                slot = queue.array (slot).next;
 424           end;
 425 
 426           if count > 0 then do;
 427                empty_sw = "1"b;                       /* To tell display_element to print a header */
 428                call ioa_ ("^/BFT Fetch Queue ^d:^20t^d request^[s^].^/",
 429                     i, running_count + count, (running_count + count > 1));
 430                running_count = 0;
 431 
 432                if queue.header.fetching.flags.initiated & ^running then do;
 433                     call bft_queue_$display_element (addr (queue.header.fetching),
 434                          long_sw, BFT_PC_to_MULTICS, "1"b, "1"b);
 435                     if long_sw then
 436                          call ioa_ ();
 437                     empty_sw = "0"b;
 438                     running = "1"b;
 439                end;
 440 
 441                slot = queue.header.fetch_queue (i).first;
 442                do while (slot ^= 0);
 443                     call bft_queue_$display_element (addr (queue.array (slot)),
 444                          long_sw, BFT_PC_to_MULTICS, "0"b, empty_sw);
 445                     empty_sw = "0"b;
 446                     slot = queue.array (slot).next;
 447                     if long_sw & slot ^= 0 then
 448                          call ioa_ ();
 449                end;
 450           end;
 451      end;
 452      if queue.header.fetching.flags.initiated & ^running then do;
 453           call ioa_ ("^/BFT Fetch Queue:^/");
 454           call bft_queue_$display_element (addr (queue.header.fetching),
 455                long_sw, BFT_PC_to_MULTICS, "1"b, "1"b);
 456           empty_sw = "0"b;
 457           running = "1"b;
 458      end;
 459 
 460 /* If there were no transfers, say so */
 461 
 462      if empty_sw then
 463           call ioa_ ("There are no requests in any BFT queue.");
 464      else
 465           call ioa_ ();
 466 
 467      end bft_display;
 468 
 469 /*^L*/
 470 
 471 /* *** Procedure: bft_fetch - Internal proc for bft *** */
 472 
 473 bft_fetch:
 474      proc ();
 475 
 476 /* PROCEDURE FUNCTION
 477 
 478 This routine is called if the first argument specified a fetch.  If two
 479 filenames are given, both are accepted.  If only one is given, then the
 480 destination will default to being the same as the supplied source name.
 481 */
 482 
 483 /* NOTES
 484 */
 485 
 486 /* PARAMETERS */
 487 
 488 /* MISC VARIABLES */
 489 dcl code                   fixed bin (35);            /* Error code */
 490 dcl passed                 fixed bin;                 /* Requests submitted */
 491 dcl temp_file              char (168);
 492 dcl mu_path                char (168);
 493 dcl pc_path                char (66);
 494 
 495 /* STRUCTURES */
 496 
 497 /* INITIALIZATION */
 498      passed = 0;
 499 
 500 /* MAIN */
 501 
 502 /* Repeat until there are no more requests in the command line */
 503 
 504      do while (arg_pos < arg_count);
 505 
 506 /* Get the pc_path */
 507 
 508           call get_arg ("0"b, code);
 509           if code ^= 0 then do;
 510                if passed = 0 then
 511                     call com_err_ (code, NAME, arg);
 512 
 513                goto FETCH_RETURN;
 514           end;
 515 
 516           pc_path = arg;
 517           mu_path = "===";
 518 
 519 /* Look for the Multics path, if it is not specified, default to pc_path */
 520 
 521           call get_arg ("0"b, code);
 522           if code ^= 0 & code ^= error_table_$noarg then do;
 523                call com_err_ (code, NAME, arg);
 524                goto FETCH_RETURN;
 525           end;
 526           else if code = 0 then
 527                mu_path = arg;
 528 
 529 /* Obtain the full pathname of the specified destination */
 530 
 531           temp_file = mu_path;
 532           call absolute_pathname_ (temp_file, mu_path, code);
 533           if code ^= 0 then do;
 534                call com_err_ (code, NAME, "Expanding Multics pathname.");
 535                goto FETCH_RETURN;
 536           end;
 537 
 538 /* Call the bft_$fetch entrypoint with the valid parms */
 539 
 540           call bft_$fetch (rtrim (pc_path), rtrim (mu_path), unspec (modes),
 541                priority, code);
 542           if code ^= 0 then do;
 543                if code = ws_error_$invalid_capability_name then
 544                     code = bft_error_table_$bft_not_loaded;
 545                call com_err_ (code, NAME, "Issuing fetch request.");
 546 
 547                goto FETCH_RETURN;
 548           end;
 549 
 550 /* Increment the cancellation count */
 551 
 552           passed = passed + 1;
 553      end;
 554 
 555 FETCH_RETURN:
 556 
 557      if passed > 0 then
 558           call ioa_ ("^a: ^d request^[s^] submitted for fetching.", NAME,
 559                passed, (passed > 1));
 560 
 561      end bft_fetch;
 562 
 563 /*^L*/
 564 
 565 /* *** Procedure: bft_load - Internal proc for bft *** */
 566 
 567 bft_load:
 568      proc ();
 569 
 570 /* PROCEDURE FUNCTION
 571 
 572 This calls the proper entrypoint to get BFT loaded into the CAT.  No arguments
 573 are required.
 574 */
 575 
 576 /* NOTES
 577 */
 578 
 579 /* PARAMETERS */
 580 
 581 /* MISC VARIABLES */
 582 dcl code                   fixed bin (35);            /* Error code */
 583 
 584 /* STRUCTURES */
 585 
 586 /* INITIALIZATION */
 587 
 588 /* MAIN */
 589 
 590 /* Print a usage message if there is an invalid number  of args */
 591 
 592      if arg_count ^= 1 then do;
 593           call com_err_ (error_table_$wrong_no_of_args, NAME);
 594           call ioa_ (USAGE_LOAD);
 595           return;
 596      end;
 597 
 598 /* Make call to proper entrypoint */
 599 
 600      call bft_$load (code);
 601      if (code ^= 0) then do;
 602           if code = ws_error_$invalid_capability_name then
 603                code = bft_error_table_$bft_not_loaded;
 604           call com_err_ (code, NAME, "While attempting to load BFT.");
 605           return;
 606      end;
 607 
 608      end bft_load;
 609 
 610 /*^L*/
 611 
 612 /* *** Procedure: bft_recover - Internal proc for bft *** */
 613 
 614 bft_recover:
 615      proc ();
 616 
 617 /* PROCEDURE FUNCTION
 618 
 619 This is the routine called if the argument was fetch_recover.  The purpose of
 620 this routine is to transmit the portion of a file that was previously
 621 interrupted.
 622 */
 623 
 624 /* NOTES
 625 */
 626 
 627 /* PARAMETERS */
 628 
 629 /* MISC VARIABLES */
 630 dcl code                   fixed bin (35);            /* Error code */
 631 
 632 /* STRUCTURES */
 633 
 634 /* INITIALIZATION */
 635 
 636 /* MAIN */
 637 
 638 /* Print a usage message if there is an invalid number  of args */
 639 
 640      if arg_count ^= 1 then do;
 641           call com_err_ (error_table_$wrong_no_of_args, NAME);
 642           call ioa_ (USAGE_RECOVER);
 643           return;
 644      end;
 645 
 646 /* Recover fetch operations */
 647 
 648      call bft_$recover_fetch (code);
 649      if (code ^= 0) then do;
 650           if code = ws_error_$invalid_capability_name then
 651                code = bft_error_table_$bft_not_loaded;
 652           call com_err_ (code, NAME, "Attempting to recover fetch.");
 653      end;
 654 
 655 /* Recover store operations */
 656 
 657      call bft_$recover_store (code);
 658      if (code ^= 0) then do;
 659           if code = ws_error_$invalid_capability_name then
 660                code = bft_error_table_$bft_not_loaded;
 661           call com_err_ (code, NAME, "Attempting to recover store.");
 662      end;
 663 
 664      end bft_recover;
 665 
 666 /*^L*/
 667 
 668 /* *** Procedure: bft_store - Internal proc for bft *** */
 669 
 670 bft_store:
 671      proc ();
 672 
 673 /* PROCEDURE FUNCTION
 674 
 675 This routine is identical in function to the bft_fetch, except for the fact
 676 that it calls bft_$store.
 677 */
 678 
 679 /* NOTES
 680 */
 681 
 682 /* PARAMETERS */
 683 
 684 /* MISC VARIABLES */
 685 dcl code                   fixed bin (35);            /* Error code */
 686 dcl passed                 fixed bin;                 /* Previous request submitted */
 687 dcl pc_path                char (66);
 688 dcl mu_path                char (168);
 689 
 690 /* STRUCTURES */
 691 
 692 /* INITIALIZATION */
 693      passed = 0;
 694 
 695 /* MAIN */
 696 
 697 /* Repeat until there are no more requests in the command line */
 698 
 699      do while (arg_pos < arg_count);
 700 
 701 /* Get the mu_path */
 702 
 703           call get_arg ("0"b, code);
 704           if code ^= 0 then do;
 705                if passed = 0 then
 706                     call com_err_ (code, NAME, arg);
 707 
 708                goto STORE_RETURN;
 709           end;
 710 
 711           mu_path = arg;
 712           pc_path = "===";
 713 
 714 /* Look for the PC path, if not specified then assume mu_patjh */
 715 
 716           call get_arg ("0"b, code);
 717           if code ^= 0 & code ^= error_table_$noarg then do;
 718                call com_err_ (code, NAME, arg);
 719                goto STORE_RETURN;
 720           end;
 721           else if code = 0 then
 722                pc_path = arg;
 723 
 724 /* Call the bft_$store entrypoint with the valid parms */
 725 
 726           call bft_$store (rtrim (mu_path), rtrim (pc_path), unspec (modes),
 727                priority, code);
 728           if code ^= 0 then do;
 729                if code = ws_error_$invalid_capability_name then
 730                     code = bft_error_table_$bft_not_loaded;
 731                call com_err_ (code, NAME, "Issuing store request.");
 732                goto STORE_RETURN;
 733           end;
 734 
 735           passed = passed + 1;
 736      end;
 737 
 738 STORE_RETURN:
 739 
 740      if passed > 0 then
 741           call ioa_ ("^a: ^d request^[s^] submitted for storing.", NAME,
 742                passed, (passed > 1));
 743 
 744      end bft_store;
 745 
 746 /*^L*/
 747 
 748 /* *** Procedure: bft_unload - Internal proc for bft *** */
 749 
 750 bft_unload:
 751      proc ();
 752 
 753 /* PROCEDURE FUNCTION
 754 
 755 If the first argument was unload then this is the routine that is called.  This
 756 calls the necessary enttrypoint to have BFT deleted from the CAT.
 757 */
 758 
 759 /* NOTES
 760 */
 761 
 762 /* PARAMETERS */
 763 
 764 /* MISC VARIABLES */
 765 dcl code                   fixed bin (35);            /* Error code */
 766 
 767 /* STRUCTURES */
 768 
 769 /* INITIALIZATION */
 770 
 771 /* MAIN */
 772 
 773 /* Print a usage message if there is an invalid number  of args */
 774 
 775      if arg_count ^= 1 then do;
 776           call com_err_ (error_table_$wrong_no_of_args, NAME);
 777           call ioa_ (USAGE_UNLOAD);
 778           return;
 779      end;
 780 
 781 /* Call the proper entrypoint with the valid parameters */
 782 
 783      call bft_$unload (code);
 784      if (code ^= 0) then do;
 785           if code = ws_error_$invalid_capability_name then
 786                code = bft_error_table_$bft_not_loaded;
 787           call com_err_ (code, NAME, "While attempting to unload BFT.");
 788           return;
 789      end;
 790 
 791      end bft_unload;
 792 
 793 /*^L*/
 794 
 795 /* *** Procedure: get_arg - Internal proc for bft  *** */
 796 
 797 get_arg:
 798      proc (p_special, p_code);
 799 
 800 
 801 /* PROCEDURE FUNCTION
 802 
 803 Extract the next real argument from the argument list.
 804 If the p_special parameter is True, then accept the "-control_arg STR" as a
 805 "non-control" argument.
 806 */
 807 
 808 /* NOTES
 809 */
 810 
 811 /* PARAMETERS */
 812 dcl p_special              bit(1) parameter;          /* Accept "-ca STR " */
 813 dcl p_code                 fixed bin (35) parameter;  /* Error code */
 814 
 815 /* MISC VARIABLES */
 816 
 817 /* STRUCTURES */
 818 
 819 /* INITIALIZATION */
 820 
 821 /* MAIN */
 822      p_code = 0;
 823 
 824 /* Skip all control_args until a NON-control_arg is found */
 825 
 826      do while ("1"b);
 827           arg_pos = arg_pos + 1;
 828 
 829           if arg_pos > arg_count then do;
 830                p_code = error_table_$noarg;
 831                return;
 832           end;
 833 
 834           call cu_$arg_ptr_rel (arg_pos, arg_ptr, arg_len, p_code, main_arg_ptr);
 835           if p_code ^= 0 then
 836                return;
 837 
 838           if substr (arg, 1, 1) = "-" then do;
 839                if arg = "-entry" | arg = "-et"        /* These are special */
 840                     | arg = "-id"
 841                then do;
 842                     if p_special then                 /* Caller wants this */
 843                          return;
 844                     else                              /* Skip the param */
 845                          arg_pos = arg_pos + 1;
 846                end;
 847                else if arg = "-queue" | arg = "-q"    /* Skip the param */
 848                     | arg = "-file_type" | arg = "-ft"
 849                then
 850                     arg_pos = arg_pos + 1;
 851                else                                   /* No params */
 852                     ;
 853           end;
 854           else
 855                return;
 856      end;
 857 
 858      end get_arg;
 859 
 860 /*^L*/
 861 
 862 /* *** Procedure: parse_control_args - Internal proc for bft  *** */
 863 
 864 parse_control_args:
 865      proc (p_code, p_reason);
 866 
 867 
 868 /* PROCEDURE FUNCTION
 869 
 870 Skip through the command line arguments and extract control arguments.
 871 
 872 Control arguments extracted are:
 873 
 874           -brief,             -bf
 875           -notify,            -nt
 876           -no_notify,         -nnt
 877           -file_type TYPE,    -ft TYPE
 878           -queue N,           -q N
 879 
 880 Control arguments "skipped" (as they are really a "single" argument):
 881 
 882           -entry NAME,        -et NAME
 883           -id ID
 884 */
 885 
 886 /* NOTES
 887 */
 888 
 889 /* PARAMETERS */
 890 dcl p_reason               char (*) var parameter;    /* Error reason */
 891 dcl p_code                 fixed bin (35) parameter;  /* Error code */
 892 
 893 /* MISC VARIABLES */
 894 dcl temp_queue             fixed bin;                 /* local queue value */
 895 
 896 /* STRUCTURES */
 897 
 898 /* INITIALIZATION */
 899      p_code = 0;
 900      p_reason = "";
 901 
 902 /* MAIN */
 903 
 904      do arg_pos = 1 to arg_count;
 905           call cu_$arg_ptr_rel (arg_pos, arg_ptr, arg_len, p_code, main_arg_ptr);
 906           if p_code ^= 0 then
 907                return;
 908 
 909           if arg = "-file_type" | arg = "-ft" then do;
 910                if ^(store_sw | fetch_sw) then do;
 911                     p_code = error_table_$inconsistent;
 912                     return;
 913                end;
 914 
 915                arg_pos = arg_pos + 1;
 916                call cu_$arg_ptr_rel (arg_pos, arg_ptr, arg_len, p_code, main_arg_ptr);
 917                if p_code ^= 0 then
 918                     return;
 919 
 920                if arg = "binary" then
 921                     modes.binary_sw = "1"b;
 922                else if arg = "ascii" then
 923                     modes.binary_sw = "0"b;
 924                else do;
 925                     p_reason = arg;
 926                     p_code = bft_error_table_$invalid_file_type;
 927                     return;
 928                end;
 929           end;
 930 
 931           else if arg = "-long" | arg = "-lg" then do;
 932                if ^display_sw then do;
 933                     p_code = error_table_$inconsistent;
 934                     return;
 935                end;
 936 
 937                long_sw = "1"b;
 938           end;
 939 
 940           else if arg = "-brief" | arg = "-bf" then do;
 941                if ^display_sw then do;
 942                     p_code = error_table_$inconsistent;
 943                     return;
 944                end;
 945 
 946                long_sw = "0"b;
 947           end;
 948 
 949           else if arg = "-id" then do;
 950                if ^cancel_sw then do;
 951                     p_code = error_table_$inconsistent;
 952                     return;
 953                end;
 954           end;
 955 
 956           else if arg = "-entry" | arg = "-et" then do;
 957                if  ^cancel_sw then do;
 958                     p_code = error_table_$inconsistent;
 959                     return;
 960                end;
 961           end;
 962 
 963           else if arg = "-notify" | arg = "-nt" then do;
 964                if ^(fetch_sw | store_sw) then do;
 965                     p_code = error_table_$inconsistent;
 966                     return;
 967                end;
 968 
 969                modes.notify_sw = "1"b;
 970           end;
 971 
 972           else if arg = "-no_notify" | arg = "-nnt" then do;
 973                if ^(fetch_sw | store_sw) then do;
 974                     p_code = error_table_$inconsistent;
 975                     return;
 976                end;
 977 
 978                modes.notify_sw = "0"b;
 979           end;
 980 
 981           else if arg = "-queue" | arg = "-q" then do;
 982                if ^(store_sw | fetch_sw) then do;
 983                     p_code = error_table_$inconsistent;
 984                     return;
 985                end;
 986 
 987                arg_pos = arg_pos + 1;
 988                call cu_$arg_ptr_rel (arg_pos, arg_ptr, arg_len, p_code, main_arg_ptr);
 989                if p_code ^= 0 then
 990                     return;
 991 
 992                if arg_len ^= 1 then do;
 993                     p_reason = arg;
 994                     p_code = bft_error_table_$invalid_priority;
 995                     return;
 996                end;
 997 
 998                temp_queue = rank (substr (arg, 1, 1)) - rank ("0");
 999                if temp_queue < BFT_MIN_PRIORITY
1000                     | temp_queue > BFT_MAX_PRIORITY
1001                then do;
1002                     p_reason = arg;
1003                     p_code = bft_error_table_$invalid_priority;
1004                     return;
1005                end;
1006 
1007                priority = temp_queue;
1008           end;
1009 
1010           else if substr (arg, 1, 1) = "-" then do;
1011                p_code = error_table_$bad_arg;
1012                reason = arg;
1013                return;
1014           end;
1015      end;
1016 
1017      end parse_control_args;
1018 
1019 /*^L*/
1020 
1021 /* INCLUDE FILES */
1022 %include bft_queue;
1023 %include bft_values;
1024 
1025      end bft;