1
2
3
4
5
6
7
8
9
10
11 bft:
12 background_file_transfer:
13 proc options (main);
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43 dcl key_procedure entry variable;
44 dcl reason char (256) var;
45 dcl code fixed bin (35);
46
47
48 dcl display_sw bit (1);
49 dcl unload_sw bit (1);
50 dcl store_sw bit (1);
51 dcl recover_sw bit (1);
52 dcl load_sw bit (1);
53 dcl fetch_sw bit (1);
54 dcl cancel_sw bit (1);
55 dcl priority fixed bin;
56 dcl long_sw bit (1);
57 dcl main_arg_ptr ptr;
58 dcl arg_pos fixed bin;
59 dcl arg_count fixed bin;
60 dcl arg_len fixed bin (21);
61 dcl arg_ptr ptr;
62 dcl arg char (arg_len) based (arg_ptr);
63 dcl 01 modes like bft_queue_flags auto aligned;
64
65
66
67
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
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
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
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
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
109
110
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
120
121
122
123
124
125 priority = 3;
126 unspec (modes) = ""b;
127 long_sw = "0"b;
128
129
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
140
141
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
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
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
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
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
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
221
222
223 arg_pos = 0;
224 call get_arg ("0"b, (0));
225 call key_procedure ();
226
227 return;
228
229
230
231
232
233
234
235
236
237
238
239
240 bft_cancel:
241 proc ();
242
243
244
245
246
247
248
249
250
251
252
253
254
255 dcl request_type char (32) var;
256 dcl code fixed bin (35);
257 dcl passed fixed bin;
258
259
260
261
262 passed = 0;
263
264
265
266
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
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
297
298 if code ^= 0 then do;
299 call com_err_ (code, NAME, "Cancelling ^a.", arg);
300 goto CANCEL_RETURN;
301 end;
302
303
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
317
318
319
320 bft_display:
321 proc ();
322
323
324
325
326
327
328
329
330
331
332
333
334
335 dcl running_count fixed bin;
336 dcl code fixed bin (35);
337 dcl running bit (1);
338 dcl i fixed bin;
339 dcl empty_sw bit (1);
340 dcl slot fixed bin (35);
341 dcl count fixed bin (21);
342
343
344
345
346 empty_sw = "1"b;
347
348
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
357
358 running = "0"b;
359 running_count = 1;
360 do i = BFT_MIN_PRIORITY to BFT_MAX_PRIORITY;
361
362
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
372
373 if count > 0 then do;
374 empty_sw = "1"b;
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
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
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
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
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;
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
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
470
471
472
473 bft_fetch:
474 proc ();
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489 dcl code fixed bin (35);
490 dcl passed fixed bin;
491 dcl temp_file char (168);
492 dcl mu_path char (168);
493 dcl pc_path char (66);
494
495
496
497
498 passed = 0;
499
500
501
502
503
504 do while (arg_pos < arg_count);
505
506
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
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
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
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
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
564
565
566
567 bft_load:
568 proc ();
569
570
571
572
573
574
575
576
577
578
579
580
581
582 dcl code fixed bin (35);
583
584
585
586
587
588
589
590
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
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
611
612
613
614 bft_recover:
615 proc ();
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630 dcl code fixed bin (35);
631
632
633
634
635
636
637
638
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
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
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
667
668
669
670 bft_store:
671 proc ();
672
673
674
675
676
677
678
679
680
681
682
683
684
685 dcl code fixed bin (35);
686 dcl passed fixed bin;
687 dcl pc_path char (66);
688 dcl mu_path char (168);
689
690
691
692
693 passed = 0;
694
695
696
697
698
699 do while (arg_pos < arg_count);
700
701
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
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
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
747
748
749
750 bft_unload:
751 proc ();
752
753
754
755
756
757
758
759
760
761
762
763
764
765 dcl code fixed bin (35);
766
767
768
769
770
771
772
773
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
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
794
795
796
797 get_arg:
798 proc (p_special, p_code);
799
800
801
802
803
804
805
806
807
808
809
810
811
812 dcl p_special bit(1) parameter;
813 dcl p_code fixed bin (35) parameter;
814
815
816
817
818
819
820
821
822 p_code = 0;
823
824
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"
840 | arg = "-id"
841 then do;
842 if p_special then
843 return;
844 else
845 arg_pos = arg_pos + 1;
846 end;
847 else if arg = "-queue" | arg = "-q"
848 | arg = "-file_type" | arg = "-ft"
849 then
850 arg_pos = arg_pos + 1;
851 else
852 ;
853 end;
854 else
855 return;
856 end;
857
858 end get_arg;
859
860
861
862
863
864 parse_control_args:
865 proc (p_code, p_reason);
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890 dcl p_reason char (*) var parameter;
891 dcl p_code fixed bin (35) parameter;
892
893
894 dcl temp_queue fixed bin;
895
896
897
898
899 p_code = 0;
900 p_reason = "";
901
902
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
1020
1021
1022 %include bft_queue;
1023 %include bft_values;
1024
1025 end bft;