1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34 dfm_: proc ();
35
36 return;
37
38
39
40
41
42 dcl N fixed bin;
43 dcl X fixed bin;
44 dcl al fixed bin (21);
45 dcl all_diskettes bit (1);
46 dcl alp ptr;
47 dcl ap ptr;
48 dcl c_att_desc char (181);
49 dcl code fixed bin (35);
50 dcl decks_tb_deleted (10) char (24) varying;
51 dcl deck_tb_patched char (24) varying;
52 dcl deckfile_path char (168);
53 dcl diskettes_tb_read (hbound (valid_diskettes, 1)) char (8) varying;
54 dcl diskette_type char (4);
55 dcl dkf_dir (3) char (168);
56 dcl dkf_entry (3) char (32);
57 dcl dkf_path (3) char (168);
58 dcl dkf_path_idx fixed bin;
59 dcl dl_patch bit (1);
60 dcl dwg_num_tab char (2);
61 dcl eof bit (1);
62 dcl err bit (1);
63 dcl lsf_dir char (168);
64 dcl lsf_entry char (32);
65 dcl i fixed bin;
66 dcl j fixed bin;
67 dcl list_all_keys bit (1);
68 dcl mca bit (1);
69 dcl mca_err bit (72);
70 dcl mca_id char (4);
71 dcl ml fixed bin (21);
72 dcl n_diskettes_tb_read fixed bin;
73 dcl nargs fixed bin;
74 dcl npatches fixed bin;
75 dcl ndecks_tb_deleted fixed bin;
76 dcl of_dir char (168);
77 dcl of_entry char (32);
78 dcl of_path char (168);
79 dcl output_mode_specified bit (1);
80 dcl patch_length fixed bin;
81 dcl patch_ptr ptr;
82 dcl patch_word char (84) varying;
83 dcl pname char (72) varying;
84 dcl prod_num_tab char (2);
85 dcl query_info_ptr ptr;
86 dcl query_message char (256);
87 dcl rl fixed bin (21);
88 dcl sci_ptr ptr;
89 dcl tdec fixed bin (35);
90 dcl term bit (1);
91 dcl user_entry char (8) varying;
92 dcl user_reply char (256) varying;
93 dcl vfile_open_mode fixed bin;
94 dcl xofn char (2);
95 dcl yes_sw bit (1);
96
97
98
99
100 dcl add_pic pic "999999" based;
101 dcl arg char (al) based (ap);
102 dcl bin_arg fixed bin (35) based (ap);
103 dcl bit_arg bit (al) based (ap);
104 dcl 1 df_keys based (dfm_data.dfkp) aligned,
105 2 n_entries fixed bin,
106 2 key (1 refer (df_keys.n_entries)) char (24);
107
108 dcl free_area area based (get_system_free_area_ ());
109
110 dcl ptr_arg ptr based (ap);
111
112
113
114
115 dcl addr builtin;
116 dcl before builtin;
117 dcl bin builtin;
118 dcl char builtin;
119 dcl clock builtin;
120 dcl convert builtin;
121 dcl index builtin;
122 dcl hbound builtin;
123 dcl lbound builtin;
124 dcl length builtin;
125 dcl ltrim builtin;
126 dcl null builtin;
127 dcl rtrim builtin;
128 dcl search builtin;
129 dcl string builtin;
130 dcl substr builtin;
131 dcl translate builtin;
132 dcl unspec builtin;
133
134
135
136
137 dcl cleanup condition;
138
139
140
141
142 dcl deckfile char (16) int static options (constant) init (">tandd_deck_file");
143 dcl false bit (1) int static options (constant) init ("0"b);
144 dcl minargs fixed bin int static options (constant) init (3);
145 dcl nl_sw bit (1) aligned int static options (constant) init ("0"b);
146 dcl pad_sw bit (1) aligned int static options (constant) init ("0"b);
147 dcl print bit (1) int static options (constant) init ("0"b);
148 dcl system_dir char (21) int static options (constant) init
149 (">system_library_tandd");
150 dcl true bit (1) int static options (constant) init ("1"b);
151 dcl wrapup bit (1) int static options (constant) init ("1"b);
152
153
154
155
156 dcl command_query_ entry () options (variable);
157 dcl command_query_$yes_no entry () options (variable);
158 dcl cu_$arg_count entry (fixed bin, fixed bin (35));
159 dcl cu_$arg_list_ptr entry (ptr);
160 dcl cu_$arg_ptr entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
161 dcl cv_dec_check_ entry (char (*), fixed bin (35)) returns (fixed bin (35));
162 dcl date_time_ entry (fixed bin (52), char (*));
163 dcl date_time_$format entry (char (*), fixed bin (71), char (*), char (*)) returns (char (250) var);
164 dcl dfm_util_$ck_applic entry (ptr) returns (bit (1));
165 dcl dfm_util_$copy_eof entry (ptr);
166 dcl dfm_util_$delete_deck entry (ptr, char (24) var, fixed bin (35));
167 dcl dfm_util_$detach_file entry (ptr, ptr);
168 dcl dfm_util_$find_dkend entry (ptr, char (24) var, ptr, fixed bin, fixed bin (35));
169 dcl dfm_util_$find_file entry (ptr, char (*), char (*));
170 dcl dfm_util_$find_key entry (ptr, ptr, char (24) var, ptr, fixed bin (35));
171 dcl dfm_util_$get_cata entry (ptr, ptr, char (24) var, ptr, ptr, fixed bin (35));
172 dcl dfm_util_$insert_deck entry (ptr, ptr, ptr, fixed bin (21), char (24) varying);
173 dcl dfm_util_$make_key entry (ptr);
174 dcl dfm_util_$mca_attach entry (ptr, char (4));
175 dcl dfm_util_$mca_detach entry (ptr);
176 dcl dfm_util_$merge_files entry (ptr, ptr, ptr);
177 dcl dfm_util_$mount_diskette entry (ptr, char (8) var, ptr) returns (bit (1));
178 dcl dfm_util_$open_file entry (ptr, char (64), char (181), fixed bin (17), ptr);
179 dcl dfm_util_$print_list entry (ptr, ptr, char (24) varying);
180 dcl dfm_util_$read_deck entry (ptr, bit (1), bit (1));
181 dcl dfm_util_$read_diskette entry (ptr, char (*), ptr, fixed bin (21), bit (72), fixed bin (35));
182 dcl dfm_util_$update_list entry (ptr, fixed bin (2));
183 dcl dfm_util_$valid_diskette entry (ptr, char (8) varying) returns (bit (1));
184 dcl expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35));
185 dcl get_system_free_area_ entry () returns (ptr);
186 dcl get_wdir_ entry returns (char (168));
187 dcl hcs_$chname_file entry (char (*), char (*), char (*), char (*), fixed bin (35));
188 dcl ioa_$general_rs entry (ptr, fixed bin, fixed bin, char (*), fixed bin (21), bit (1) aligned, bit (1) aligned);
189 dcl ioa_$rsnnl entry () options (variable);
190 dcl mca_$read_data entry (fixed bin, ptr, fixed bin (21), fixed bin (21), bit (72), fixed bin (35));
191 dcl ssu_$arg_count entry (ptr, fixed bin);
192 dcl ssu_$arg_ptr entry (ptr, fixed bin, ptr, fixed bin (21));
193 dcl ssu_$abort_line entry () options (variable);
194 dcl ssu_$abort_subsystem entry () options (variable);
195 dcl ssu_$get_info_ptr entry (ptr) returns (ptr);
196 dcl ssu_$get_temp_segment entry (ptr, char (*), ptr);
197 dcl ssu_$get_subsystem_and_request_name entry (ptr) returns (char (72) var);
198 dcl ssu_$print_message entry () options (variable);
199 dcl ssu_$release_temp_segment entry (ptr, ptr);
200 dcl sub_err_ entry () options (variable);
201
202
203
204
205 dcl error_table_$bad_arg fixed bin (35) ext static;
206 dcl error_table_$noarg fixed bin (35) ext static;
207 dcl error_table_$segnamedup fixed bin (35) ext static;
208 dcl error_table_$too_many_names fixed bin (35) ext static;
209 dcl iox_$user_output ext ptr;
210
211
212
213 dcl P_dfm_infop ptr parameter;
214 dcl P_sci_ptr ptr parameter;
215
216
217 %page;
218
219
220
221 clean_up: entry (P_sci_ptr, P_dfm_infop);
222
223 call setup_part1;
224 call wrap_up;
225
226 return;
227
228
229
230 %page;
231
232
233
234
235
236
237
238 complain: entry options (variable);
239
240
241 dcl ecode fixed bin (35);
242 dcl message char (256);
243 dcl ABORT bit (1);
244
245
246 message = "";
247 ml = 0;
248
249 call cu_$arg_count (nargs, code);
250 if nargs < minargs then
251 call sub_err_ (code, "dfm_$complain", ACTION_CANT_RESTART, null, 0, "");
252
253 do i = 1 to minargs;
254 call cu_$arg_ptr (i, ap, al, code);
255 if code ^= 0 then
256 call sub_err_ (code, "dfm_$complain", ACTION_CANT_RESTART,
257 null, 0, "encountered while attempting to get ^[dfm_datap^;abort^;code^] arg.", i);
258
259 else if i = 1 then dfm_datap = ptr_arg;
260 else if i = 2 then ABORT = bit_arg;
261 else if i = 3 then ecode = bin_arg;
262 end;
263
264 sci_ptr = dfm_data.sci_ptr;
265
266 if nargs > minargs then do;
267 call cu_$arg_list_ptr (alp);
268 call ioa_$general_rs (alp, 4, 5, message, ml, pad_sw, nl_sw);
269 end;
270
271
272 if ABORT then do;
273 dfm_infop = dfm_data.infop;
274 call wrap_up;
275
276 call ssu_$abort_line (sci_ptr, ecode, "^a", substr (message, 1, ml));
277 end;
278 else call ssu_$print_message (sci_ptr, ecode, "^a", substr (message, 1, ml));
279 return;
280
281
282 %page;
283
284
285
286 delete_deck: entry (P_sci_ptr, P_dfm_infop);
287
288
289 call setup_part1;
290 call setup_part2;
291 dd = true;
292 ndecks_tb_deleted = 0;
293
294 on cleanup call wrap_up;
295
296 call ssu_$arg_count (sci_ptr, nargs);
297
298 if nargs > 0 then do i = 1 to nargs;
299 call ssu_$arg_ptr (sci_ptr, i, ap, al);
300
301 if arg = "-deckfile" | arg = "-df" then do;
302 i = i + 1;
303 call ssu_$arg_ptr (sci_ptr, i, ap, al);
304 if al = 0 then
305 call complain (dfm_datap, wrapup, error_table_$bad_arg,
306 "obtaining ""-deckfile"" specification.", "");
307 else deckfile_path = arg;
308 end;
309
310 else if arg = "-brief" | arg = "-bf" then dfm_data.bf_sw = true;
311
312 else do;
313 ndecks_tb_deleted = ndecks_tb_deleted + 1;
314 if ndecks_tb_deleted > hbound (decks_tb_deleted, 1) then
315 call complain (dfm_datap, wrapup, error_table_$too_many_names,
316 "only ^d decks maybe deleted", hbound (decks_tb_deleted, 1));
317 decks_tb_deleted (ndecks_tb_deleted) = arg;
318 end;
319 end;
320
321 if ndecks_tb_deleted = 0 then do;
322 call complain (dfm_datap, print, error_table_$noarg,
323 "No key given to specify the deck to be deleted.", "");
324
325 query_message = "Enter a key or partial key for the deck to be deleted.";
326 query_info.explanation_len = length (rtrim (query_message));
327 query_info.explanation_ptr = addr (query_message);
328 call command_query_ (query_info_ptr, user_reply, pname,
329 "Enter: <key> ");
330
331 ndecks_tb_deleted = 1;
332 decks_tb_deleted (ndecks_tb_deleted) = user_reply;
333 end;
334
335 if ndecks_tb_deleted > 0 then do;
336
337 call ssu_$get_temp_segment (sci_ptr, "catalog keys", dfm_data.dfkp);
338 call ssu_$get_temp_segment (sci_ptr, "catalog list", dfm_data.lcatp);
339 dfm_data.liocb_ptr = iox_$user_output;
340 dfm_data.terminal_out = true;
341 dfm_data.deckfile_sw = true;
342
343 call get_files;
344 do i = 1 to ndecks_tb_deleted;
345 call dfm_util_$find_key (dfm_datap, dfm_data.fiocb_ptr,
346 decks_tb_deleted (i), dfm_data.dfkp, code);
347 if code ^= 0 then
348 call complain (dfm_datap, wrapup, code,
349 "attempting to find keys for ^a", decks_tb_deleted (i));
350
351 term = false;
352 if df_keys.n_entries > 1 then do j = 1 to df_keys.n_entries while (^term);
353 call command_query_$yes_no (yes_sw, 0, pname, "^d ^2s entries matched the key given",
354 "key given matched ^d entries. ^/Entry ^d is ^a - Is this the deck to be deleted?",
355 df_keys.n_entries, j, df_keys.key (j));
356 if yes_sw then do;
357 term = true;
358 j = j - 1;
359 end;
360 end;
361
362 else j = 1;
363
364 if j <= df_keys.n_entries then do;
365 decks_tb_deleted (i) = df_keys.key (j);
366 call dfm_util_$delete_deck (dfm_datap, decks_tb_deleted (i), code);
367 if code ^= 0 then
368 call complain (dfm_datap, wrapup, code,
369 "attempting to delete deck ^a", decks_tb_deleted (i));
370 dfm_data.list_key = "ls." || rtrim (decks_tb_deleted (i));
371 call dfm_util_$print_list (dfm_datap, dfm_data.fiocb_ptr, dfm_data.list_key);
372 end;
373 end;
374 end;
375
376
377 call wrap_up;
378
379 return;
380
381 %page;
382
383
384
385
386
387 list: entry (P_sci_ptr, P_dfm_infop);
388
389 call setup_part1;
390 call setup_part2;
391
392 dfm_data.list = true;
393 list_all_keys = false;
394 output_mode_specified = false;
395
396 on cleanup call wrap_up;
397
398 call ssu_$arg_count (sci_ptr, nargs);
399
400 if nargs > 0 then do i = 1 to nargs;
401 call ssu_$arg_ptr (sci_ptr, i, ap, al);
402
403 if arg = "-all" | arg = "-a" then list_all_keys = true;
404
405 else if arg = "-brief" | arg = "-bf" then
406 dfm_data.bf_sw = true;
407
408 else if arg = "-deckfile" | arg = "-df" then do;
409 i = i + 1;
410 call ssu_$arg_ptr (sci_ptr, i, ap, al);
411 if al = 0 then
412 call complain (dfm_datap, wrapup, error_table_$bad_arg,
413 "obtaining ""-deckfile"" specification.", "");
414 else deckfile_path = arg;
415 end;
416
417 else if arg = "-file_out" | arg = "-fo" then do;
418 dfm_data.terminal_out = false;
419 output_mode_specified = true;
420 end;
421
422 else if arg = "-term_out" | arg = "-to" then
423 dfm_data.terminal_out, output_mode_specified = true;
424
425 else if dfm_data.list_key = "" then dfm_data.list_key = arg;
426 else call complain (dfm_datap, wrapup, error_table_$bad_arg,
427 "More than one list key specified.", "");
428 end;
429
430 if ^list_all_keys & dfm_data.list_key = "" then do;
431 call complain (dfm_datap, print, error_table_$noarg,
432 "Insufficient number of args supplied.", "");
433
434 query_message = "Enter a key for the file to be listed or all to create a complete deckfile.list.";
435 query_info.explanation_len = length (rtrim (query_message));
436 query_info.explanation_ptr = addr (query_message);
437 call command_query_ (query_info_ptr, user_reply, pname,
438 "Enter: <the key or -all.> ");
439
440 if user_reply = "-all"
441 | user_reply = "-a" then list_all_keys = true;
442 else dfm_data.list_key = user_reply;
443 end;
444
445 if ^output_mode_specified & dfm_data.list_key ^= "" then do;
446 dfm_data.terminal_out = true;
447 dfm_data.page_no = 0;
448 end;
449
450 dfm_data.deckfile_sw = true;
451
452 call get_files;
453 call ssu_$get_temp_segment (sci_ptr, "catalog keys", dfm_data.lcatp);
454 lcata.n_entries = 0;
455 if dfm_data.terminal_out then dfm_data.liocb_ptr = iox_$user_output;
456 if list_all_keys then do i = lbound (list_types, 1) to hbound (list_types, 1);
457 dfm_data.list_key = list_types (i);
458 call dfm_util_$find_key (dfm_datap, dfm_data.fiocb_ptr, dfm_data.list_key, dfm_data.lcatp, code);
459 if code ^= 0 then dfm_data.list_key = "";
460 if dfm_data.list_key ^= "" then
461 call dfm_util_$print_list (dfm_datap, dfm_data.fiocb_ptr, dfm_data.list_key);
462 end;
463
464 else if dfm_data.list_key ^= "" then do;
465 if index (dfm_data.list_key, "ls.") ^= 1 then dfm_data.list_key = "ls." || dfm_data.list_key;
466 call dfm_util_$find_key (dfm_datap, dfm_data.fiocb_ptr, dfm_data.list_key, dfm_data.lcatp, code);
467 if code ^= 0 then
468 call complain (dfm_datap, wrapup, code,
469 "attempting to find keys for ^a", dfm_data.list_key);
470
471 if lcata.n_entries > 1 then do j = 1 to lcata.n_entries while (^term);
472 call command_query_$yes_no (yes_sw, 0, pname, "^d^2s entries matched the key given",
473 "key given matched ^d entries.^/ Entry ^d is ^a - Is this the file to be listed?",
474 lcata.n_entries, j, lcata.key (j));
475 if yes_sw then do;
476 term = true;
477 dfm_data.list_key = lcata.key (j);
478 end;
479 else dfm_data.list_key = "";
480 end;
481
482 if dfm_data.list_key = "" then
483 call complain (dfm_datap, wrapup, 0,
484 "There are no files to be listed", "");
485 else call dfm_util_$print_list (dfm_datap, dfm_data.fiocb_ptr, dfm_data.list_key);
486 end;
487
488 call wrap_up;
489
490 return;
491
492
493 %page;
494
495
496
497
498 list_diskette_types: entry (P_sci_ptr, P_dfm_infop);
499
500 dcl out_str char (hbound (valid_diskettes, 1) * 5) varying;
501
502 call setup_part1;
503
504 on cleanup call wrap_up;
505
506 out_str = "";
507 do i = 1 to hbound (valid_diskettes, 1);
508 out_str = out_str || substr (valid_diskettes (i), 1, 3) || " ";
509 end;
510 call complain (dfm_datap, print, 0, "^/^a^/", out_str);
511 dfm_data.finished = true;
512 dfm_info.flags.request_active = false;
513 return;
514
515
516 %page;
517
518
519
520 load_from_diskette: entry (P_sci_ptr, P_dfm_infop);
521
522 call setup_part1;
523 call setup_part2;
524 dfm_data.lfd = true;
525 dir_ptr = null;
526
527 on cleanup begin;
528 if dir_ptr ^= null then free directory in (free_area);
529 call wrap_up;
530 end;
531
532 all_diskettes = false;
533 mca = false;
534 call ssu_$arg_count (sci_ptr, nargs);
535 if nargs > 0 then do i = 1 to nargs;
536 call ssu_$arg_ptr (sci_ptr, i, ap, al);
537
538 if arg = "-mca" then do;
539 i = i + 1;
540 call ssu_$arg_ptr (sci_ptr, i, ap, al);
541 if al ^= 1 then
542 call complain (dfm_datap, wrapup, 0,
543 "arg following -mca arg incorrect", "");
544 else if search (arg, "abcd") = 0 then
545 call complain (dfm_datap, wrapup, 0,
546 "arg following -mca arg incorrect", "");
547 else mca = true;
548 mca_id = "mca" || arg;
549 end;
550
551 else if arg = "-brief"
552 | arg = "-bf" then dfm_data.bf_sw = true;
553
554 else if arg = "-deckfile"
555 | arg = "-df" then do;
556 i = i + 1;
557 call ssu_$arg_ptr (sci_ptr, i, ap, al);
558 if al = 0 then
559 call complain (dfm_datap, wrapup, error_table_$bad_arg,
560 "obtaining ""-deckfile"" specification.", "");
561 else deckfile_path = arg;
562 end;
563
564 else if arg = "-all" | arg = "-a" then all_diskettes = true;
565
566 else if dfm_util_$valid_diskette (dfm_datap, (arg)) then do;
567 n_diskettes_tb_read = n_diskettes_tb_read + 1;
568 diskettes_tb_read (n_diskettes_tb_read) = arg;
569 end;
570 else call complain (dfm_datap, wrapup, 0, "Invalid arg ^a", arg);
571 end;
572
573 if n_diskettes_tb_read = 0 & ^all_diskettes then do;
574 call complain (dfm_datap, print, error_table_$noarg,
575 "A diskette to be read must be specified", "");
576
577 query_message = "Enter a diskette name, or -all for all diskettes";
578 query_info.explanation_len = length (rtrim (query_message));
579 query_info.explanation_ptr = addr (query_message);
580 call command_query_ (query_info_ptr, user_reply, pname,
581 "Enter: <diskette name>");
582
583 if user_reply = "-all"
584 | user_reply = "-a" then all_diskettes = true;
585
586 else do;
587 user_entry = substr (user_reply, 1, 8);
588 if dfm_util_$valid_diskette (dfm_datap, user_entry) then do;
589 n_diskettes_tb_read = 1;
590 diskettes_tb_read (n_diskettes_tb_read) = user_entry;
591 end;
592
593 else call complain (dfm_datap, wrapup, 0,
594 "Invalid diskette name, use list_diskette_types (ldt) request to obtain valid types", "");
595 end;
596 end;
597
598
599 if ^mca then do;
600 query_message = "Enter the mca (a-d) of the mca to be used";
601 query_info.explanation_len = length (rtrim (query_message));
602 query_info.explanation_ptr = addr (query_message);
603 call command_query_ (query_info_ptr, user_reply, pname,
604 " Enter MCA to be used ");
605 if search (user_reply, "abcd") = 0 then
606 call complain (dfm_datap, wrapup, 0, "invalid mca id entered", "");
607 else mca = true;
608 mca_id = "mca" || rtrim (user_reply);
609 end;
610
611
612 if all_diskettes then do;
613 n_diskettes_tb_read = hbound (valid_diskettes, 1);
614 diskettes_tb_read = valid_diskettes;
615 end;
616
617 if n_diskettes_tb_read < 1 then
618 call complain (dfm_datap, wrapup, 0, "no diskette type entered", "");
619
620 call ssu_$get_temp_segment (sci_ptr, "catalog keys", dfm_data.lcatp);
621
622 call ssu_$get_temp_segment (sci_ptr, "diskette catalog", dfm_data.dcatp);
623
624 call ssu_$get_temp_segment (sci_ptr, "mca catalog", dfm_data.mcatp);
625
626 call ssu_$get_temp_segment (sci_ptr, "mca data read buffer", dfm_data.mca_wksp);
627
628
629
630
631
632 dfm_data.deckfile_sw = true;
633 call get_files;
634 call dfm_util_$mca_attach (dfm_datap, mca_id);
635
636 %page;
637
638
639
640
641
642 call dfm_util_$get_cata (dfm_datap, dfm_data.fiocb_ptr,
643 "cata.nio.mca", dfm_data.mcatp, dfm_data.mksp, code);
644 if code ^= 0 then
645 call complain (dfm_datap, wrapup, code, "can't get mca catalog", "");
646
647 do i = 1 to n_diskettes_tb_read;
648 unspec (dcata) = "0"b;
649
650 remount:
651 if dfm_util_$mount_diskette (dfm_datap,
652 translate (diskettes_tb_read (i), uc, lc), dfm_data.mca_wksp) then
653 call dfm_util_$read_diskette (dfm_datap, "HDR",
654 dfm_data.mca_wksp, rl, mca_err, code);
655
656 else do;
657 call complain (dfm_datap, print, code, pname,
658 "Operator unable to mount diskette ^a", diskettes_tb_read (i));
659 query_message = "Problems encountered mounting the diskette. Enter: - (a)bort, (s)kip or (r)etry? ";
660 query_info.explanation_len = length (rtrim (query_message));
661 query_info.explanation_ptr = addr (query_message);
662 call command_query_ (query_info_ptr, user_reply, pname,
663 "Enter: - (a)bort, (s)kip or (r)etry? ");
664 if user_reply = "r" | user_reply = "retry" then goto remount;
665 if user_reply = "s" | user_reply = "skip" then goto next_disk;
666 else goto exit_lfd;
667 end;
668
669 header_ptr = dfm_data.mca_wksp;
670 if mca_status.maj | mca_sub.data_p | code ^= 0
671 | substr (translate (header.unique_id, lc, uc), 1, 3) ^= substr (diskettes_tb_read (i), 1, 3)
672 | substr (header.title, 1, 4) ^= "UTIL" then do;
673 if substr (translate (header.unique_id, lc, uc), 1, 3) ^= substr (diskettes_tb_read (i), 1, 3) then do;
674 call complain (dfm_datap, print, pname,
675 "Diskette ^a mounted - instead of ^a? ", header.unique_id, diskettes_tb_read (i));
676 query_message = "Wrong diskette mounted. Enter: - (a)bort, (s)kip or (r)etry? ";
677 query_info.explanation_len = length (rtrim (query_message));
678 query_info.explanation_ptr = addr (query_message);
679 call command_query_ (query_info_ptr, user_reply, pname,
680 "Enter: - (a)bort, (s)kip or (r)etry? ");
681 if user_reply = "r" | user_reply = "retry" then goto remount;
682 if user_reply = "s" | user_reply = "skip" then goto next_disk;
683 else goto exit_lfd;
684 end;
685
686 next_disk: if i < n_diskettes_tb_read then do;
687 call command_query_$yes_no (yes_sw, code, pname,
688 "Unable to read the HEADER - want to continue",
689 "Unable to read the ^a - read the next diskette?", "HEADER");
690 if yes_sw then goto next_diskette;
691 else goto exit_lfd;
692 end;
693 else call complain (dfm_datap, wrapup, code,
694 "reading ^a HEADER", (diskettes_tb_read (i)));
695 end;
696
697 call complain (dfm_datap, print, 0,
698 "Mounted diskette ^a on drive ^d", header.unique_id, dfm_data.disk_num);
699 N = bin (substr (header.x_of_n, 1, 9), 9);
700 X = bin (substr (header.x_of_n, 10, 9), 9);
701 unspec (xofn) = header.x_of_n;
702 dir_number = 0;
703 substr (unspec (dir_number), 21, 16) = header.dir_size.msb || header.dir_size.lsb;
704 dir_number = dir_number / 16;
705 dfm_data.edit_date = header.date_changed;
706 diskette_type = header.equip_type;
707 dwg_num_tab = substr (header.disk_dwg_num, 11);
708 prod_num_tab = substr (header.unique_id, 7);
709 dfm_data.current_disk_name = rtrim (header.unique_id);
710 current_filename = rtrim ("HDR." || header.unique_id || prod_num_tab || "00");
711
712 if i = 1 then call add_name ("mca.diskettes.rev." || prod_num_tab);
713 call dfm_util_$get_cata (dfm_datap, dfm_data.fiocb_ptr,
714 "cata.nio." || rtrim (header.unique_id), dfm_data.dcatp, dfm_data.dksp, code);
715 if code ^= 0 then
716 call complain (dfm_datap, wrapup, code,
717 "can't get ^a catalog", header.unique_id);
718 call file_deck (dfm_data.mca_wksp, rl);
719 call dfm_util_$read_diskette (dfm_datap, "DIRECTORY",
720 dfm_data.mca_wksp, rl, mca_err, code);
721
722 if mca_status.maj | mca_sub.data_p | code ^= 0 then do;
723 if i < n_diskettes_tb_read then do;
724 call command_query_$yes_no (yes_sw, code, pname,
725 "Unable to read DIRECTORY file. Want to continue?",
726 "Unable to read ^a file. Read the next diskette?", "DIRECTORY");
727 if yes_sw then goto next_diskette;
728 else goto exit_lfd;
729 end;
730 else call complain (dfm_datap, wrapup, code,
731 "reading ^a DIRECTORY", diskettes_tb_read (i));
732 end;
733
734 dir_ptr = dfm_data.mca_wksp;
735 alloc directory in (free_area) set (dir_ptr);
736 directory = dfm_data.mca_wksp -> directory;
737 current_filename = rtrim (diskette_type || ".DIRECTRY" || prod_num_tab || "00");
738 call file_deck (dfm_data.mca_wksp, rl);
739
740 do j = 1 to dir_number;
741 dire_ptr = addr (directory.array (j));
742 if (dire.path_name = ".DPSFILE" & j < dir_number)
743 | dire.deleted then goto next_file;
744 call dfm_util_$read_diskette (dfm_datap, "P=" || dire.path_name,
745 dfm_data.mca_wksp, rl, mca_err, code);
746 if mca_status.maj | code ^= 0 then do;
747 if j < dir_number then do;
748 call command_query_$yes_no (yes_sw, code, pname,
749 "Unable to read last file. Want to continue?",
750 "Unable to read file ^a. Read the next file?", dire.path_name);
751 if yes_sw then goto next_file;
752 end;
753 else do;
754 free directory in (free_area);
755 dir_ptr = null;
756 call complain (dfm_datap, wrapup, code,
757 "unable to read file ^a", dire.path_name);
758 end;
759 end;
760 current_filename = rtrim (dire.path_name || prod_num_tab || dwg_num_tab);
761 call file_deck (dfm_data.mca_wksp, rl);
762 next_file: end;
763 free directory in (free_area);
764 dir_ptr = null;
765 current_filename = rtrim ("cata." || dfm_data.current_disk_name);
766 rl = dcata.n_entries * 24 + 4;
767 call file_deck (dfm_data.dcatp, rl);
768 next_diskette:
769 dfm_data.hdr_sw = true;
770 end;
771 dfm_data.current_filename = rtrim ("cata.mca");
772 rl = mcata.n_entries * 24 + 4;
773 call file_deck (dfm_data.mcatp, rl);
774
775 call dfm_util_$insert_deck (dfm_datap, dfm_data.fiocb_ptr, dfm_data.lcatp,
776 length (unspec (lcata)), "ls.cata." || dfm_data.ls_type || ".list");
777 call dfm_util_$print_list (dfm_datap, dfm_data.fiocb_ptr,
778 "ls.cata." || dfm_data.ls_type || ".list");
779
780 exit_lfd:
781 call wrap_up;
782
783 return;
784
785
786 %page;
787
788
789
790 load_from_tape: entry (P_sci_ptr, P_dfm_infop);
791
792 call setup_part1;
793 call setup_part2;
794 dfm_data.lft = true;
795
796 on cleanup call wrap_up;
797
798 call ssu_$arg_count (sci_ptr, nargs);
799
800 if nargs > 0 then do j = 1 to nargs;
801 call ssu_$arg_ptr (sci_ptr, j, ap, al);
802 if index (arg, "-") ^= 1 then do;
803 dfm_data.t_att_desc = "tape_nstd_ " || arg;
804
805 if tdec = 6250 | tdec = 1600 | tdec = 800 | tdec = 556 | tdec = 200 then
806 dfm_data.t_att_desc = rtrim (dfm_data.t_att_desc) || " -density " || ltrim (char (tdec));
807
808 tape_name = before (arg, ",");
809 dfm_data.l_att_desc = "vfile_ " || tape_name;
810 end;
811
812 else if arg = "-brief" | arg = "-bf" then dfm_data.bf_sw = true;
813 else if arg = "-firmware" | arg = "-fw" then do;
814 dfm_data.firmware_sw = true;
815 dfm_data.attach_copy, dfm_data.deckfile_sw = false;
816 end;
817
818 else if arg = "-copy" | arg = "-cp" then do;
819 j = j + 1;
820 call ssu_$arg_ptr (sci_ptr, j, ap, al);
821 if al = 0 then
822 call complain (dfm_datap, wrapup, code,
823 "obtaining ""-copy"" tape reel specification.", "");
824 c_att_desc = "tape_nstd_ " || arg;
825
826 if tdec = 6250 | tdec = 1600 | tdec = 800 | tdec = 556 | tdec = 200 then
827 c_att_desc = rtrim (c_att_desc) || " -density " || ltrim (char (tdec));
828 dfm_data.attach_copy = true;
829 dfm_data.firmware_sw = false;
830 end;
831
832 else if arg = "-deckfile" | arg = "-df" then do;
833 j = j + 1;
834 call ssu_$arg_ptr (sci_ptr, j, ap, al);
835 if al = 0 then
836 call complain (dfm_datap, wrapup, error_table_$bad_arg,
837 "obtaining ""-deckfile"" specification.", "");
838 else deckfile_path = arg;
839 dfm_data.deckfile_sw = true;
840 end;
841
842 else if arg = "-density" | arg = "-den" then do;
843 j = j + 1;
844 call ssu_$arg_ptr (sci_ptr, j, ap, al);
845 if al = 0 then
846 call complain (dfm_datap, wrapup, code,
847 "obtaining ""-density"" specification.", "");
848 tdec = cv_dec_check_ (arg, code);
849 if code ^= 0 then go to bad_arg;
850 if tdec = 6250 | tdec = 1600 | tdec = 800 | tdec = 556 | tdec = 200 then do;
851 if dfm_data.attach_copy then do;
852 c_att_desc = rtrim (c_att_desc) || " -density " || ltrim (char (tdec));
853 cd_sw = true;
854 end;
855 if dfm_data.tape_name ^= "" then
856 dfm_data.t_att_desc = rtrim (dfm_data.t_att_desc) || " -density " || ltrim (char (tdec));
857 end;
858 else go to bad_arg;
859 end;
860
861 else if arg = "-patches" then
862 dfm_data.allow_0_cksum = true;
863
864 else if arg = "-track" | arg = "-tk" then do;
865 j = j + 1;
866 call ssu_$arg_ptr (sci_ptr, j, ap, al);
867 if al = 0 then
868 call complain (dfm_datap, wrapup, code,
869 "obtaining ""-track"" specification.", "");
870 tdec = cv_dec_check_ (arg, code);
871 if code ^= 0 then go to bad_arg;
872 if tdec ^= 7 & tdec ^= 9 then go to bad_arg;
873 if dfm_data.attach_copy then
874 c_att_desc = rtrim (c_att_desc) || " -track " || arg;
875 else dfm_data.t_att_desc = rtrim (dfm_data.t_att_desc) || " -track " || arg;
876 end;
877
878 else do;
879 bad_arg: call complain (dfm_datap, wrapup, error_table_$bad_arg, "^a", arg);
880 end;
881 end;
882
883 if ^dfm_data.attach_copy
884 & ^dfm_data.deckfile_sw
885 & ^dfm_data.firmware_sw
886 then dfm_data.deckfile_sw = true;
887
888 if ^dfm_data.firmware_sw & dfm_data.deckfile_sw
889 then dfm_data.firmware_sw = true;
890
891 if dfm_data.tape_name = "" then do;
892 call complain (dfm_datap, print, error_table_$noarg,
893 "A tape name must be supplied", "");
894
895 query_message = "Enter the name of the tape, ifad or 6670bdt, to be mounted.";
896 query_info.explanation_len = length (rtrim (query_message));
897 query_info.explanation_ptr = addr (query_message);
898 call command_query_ (query_info_ptr, user_reply, pname,
899 "Enter <tape_name>: ");
900
901 dfm_data.t_att_desc = "tape_nstd_ " || user_reply;
902 tape_name = before (user_reply, ",");
903 dfm_data.l_att_desc = "vfile_ " || dfm_data.tape_name;
904 end;
905
906 if dfm_data.tape_name = "" then
907 call complain (dfm_datap, wrapup, code,
908 "^/Usage:^-load_from_tape reel_id {-control_args}", "");
909
910
911 call ssu_$get_temp_segment (sci_ptr, "tape buffer", dfm_data.bptr);
912 call ssu_$get_temp_segment (sci_ptr, "catalog buffer", dfm_data.catp);
913 call ssu_$get_temp_segment (sci_ptr, "catalog keys", dfm_data.lcatp);
914
915 call get_files;
916
917 call add_name (dfm_data.tape_name);
918
919
920 do while (^dfm_data.eot);
921 call dfm_util_$read_deck (dfm_datap, eof, err);
922 if err | (eof & one_eof) | dfm_data.eot then do;
923 dfm_data.eot = true;
924
925 if dfm_data.attach_copy then
926 call dfm_util_$copy_eof (dfm_datap);
927
928 if dfm_data.fnp_tape & ^err & ^dfm_data.list then do;
929 dfm_data.current_key = "cata." || rtrim (dfm_data.cat_key);
930 call dfm_util_$insert_deck (dfm_datap, dfm_data.fiocb_ptr, dfm_data.catp,
931 length (unspec (cata)), dfm_data.current_key);
932 call dfm_util_$update_list (dfm_datap, cata_list_type);
933 end;
934 end;
935 else if eof then do;
936 one_eof = true;
937 if dfm_data.attach_copy then
938 if ^dfm_data.copy_at_eof then
939 call dfm_util_$copy_eof (dfm_datap);
940
941 if dfm_data.cat_build
942 & ^dfm_data.fnp_tape then do;
943 dfm_data.cat_build, dfm_data.first_deck = false;
944 if index (dfm_data.cat_key, "itr.") ^= 0 then do;
945 if id_blk.type = "itr" | id_blk.type = "mdr" then do;
946 call complain (dfm_datap, print, 0, "Last object deck on itr file is not firmware", "");
947 call complain (dfm_datap, wrapup, 0, "Last object card image is:^/""^a""", dfm_data.obj_card);
948 end;
949 else do;
950 do i = cata.n_entries to 1 by -1 while (index (cata.key (i), ".") > 4);
951 end;
952 cata.n_entries = cata.n_entries + 1;
953 dfm_data.cat_key = rtrim (dfm_data.cat_key)
954 || substr (cata.key (i + 1), 8, 6) || "." || substr (cata.key (i + 1), 20, 2);
955 end;
956 end;
957 dfm_data.current_key = "cata." || rtrim (dfm_data.cat_key);
958 call dfm_util_$insert_deck (dfm_datap, dfm_data.fiocb_ptr,
959 dfm_data.catp, length (unspec (cata)), dfm_data.current_key);
960 call dfm_util_$update_list (dfm_datap, cata_list_type);
961 end;
962 end;
963
964 else do;
965 one_eof = false;
966 if dfm_data.list then
967 call dfm_util_$update_list (dfm_datap, data_list_type);
968
969 else if dfm_data.fnp_tape
970 | (dfm_util_$ck_applic (dfm_datap)
971 & dfm_data.deckfile_sw) then
972 call file_deck (dfm_data.bptr, dfm_data.dlen * 4);
973
974 end;
975 end;
976
977 call dfm_util_$insert_deck (dfm_datap, dfm_data.fiocb_ptr, dfm_data.lcatp,
978 length (unspec (lcata)), "ls.cata." || dfm_data.ls_type || ".list");
979
980 call dfm_util_$print_list (dfm_datap, dfm_data.fiocb_ptr, "ls.cata." || dfm_data.ls_type || ".list");
981 call wrap_up;
982 return;
983
984
985 %page;
986
987
988
989 merge_deckfiles: entry (P_sci_ptr, P_dfm_infop);
990
991 call setup_part1;
992 call setup_part2;
993 dfm_data.mdf = true;
994
995 call ssu_$arg_count (sci_ptr, nargs);
996 dkf_path_idx = 1;
997
998 do i = 1 to nargs;
999 call ssu_$arg_ptr (sci_ptr, i, ap, al);
1000
1001 if arg = "-brief"
1002 | arg = "-bf" then dfm_data.bf_sw = true;
1003
1004 else if arg = "-output_file"
1005 | arg = "-of" then do;
1006 i = i + 1;
1007 call ssu_$arg_ptr (sci_ptr, i, ap, al);
1008 if al = 0 then
1009 call complain (dfm_datap, wrapup, code, "obtaining ""-output_file"" specification.", "");
1010 else of_path = arg;
1011 end;
1012
1013 else if dkf_path_idx > hbound (dkf_path, 1) then
1014 call complain (dfm_datap, wrapup, error_table_$bad_arg,
1015 "More than ^d deck files to be merged", hbound (dkf_path, 1));
1016
1017 else do;
1018 dkf_path (dkf_path_idx) = arg;
1019 dkf_path_idx = dkf_path_idx + 1;
1020 end;
1021 end;
1022
1023 if dkf_path (1) = "" then do;
1024 call complain (dfm_datap, print, error_table_$noarg,
1025 "At least one input deckfile path is required", "");
1026
1027 query_message = "Input deckfile path may be either a path or -working_dir or -system";
1028 query_info.explanation_len = length (rtrim (query_message));
1029 query_info.explanation_ptr = addr (query_message);
1030 call command_query_ (query_info_ptr, user_reply, pname,
1031 "Enter <input deckfile path>: ");
1032
1033 dkf_path (1) = user_reply;
1034 end;
1035
1036
1037 if of_path = "" & dfm_info.deckfile_dir = "" then do;
1038 call complain (dfm_datap, print, error_table_$noarg,
1039 "An output deckfile path is required", "");
1040
1041 query_message = "Output deckfile path may be either a path or -working_dir or -system";
1042 query_info.explanation_len = length (rtrim (query_message));
1043 query_info.explanation_ptr = addr (query_message);
1044 call command_query_ (query_info_ptr, user_reply, pname,
1045 "Enter <output deckfile path>: ");
1046
1047 of_path = user_reply;
1048 end;
1049
1050 if dkf_path (1) = "" | of_path = "" then
1051 call complain (dfm_datap, wrapup, error_table_$noarg,
1052 "Both an input and output deckfile path are required", "");
1053
1054 do i = lbound (dkf_path, 1) to hbound (dkf_path, 1);
1055 if dkf_path (i) = "-working_dir"
1056 | dkf_path (i) = "-wd" then
1057 dkf_path (i) = rtrim (dir) || deckfile;
1058
1059 else if dkf_path (i) = "-system"
1060 | dkf_path (i) = "-sys" then
1061 dkf_path (i) = system_dir || deckfile;
1062
1063 if of_path = "-working_dir"
1064 | of_path = "-wd" then
1065 of_path = rtrim (dir) || ">" || deckfile;
1066
1067 else if of_path = "-system"
1068 | of_path = "-sys" then
1069 of_path = system_dir || ">" || deckfile;
1070
1071 if of_path = dkf_path (i) then dkf_path (i) = "";
1072 end;
1073
1074 call get_files;
1075
1076 call ssu_$get_temp_segment (sci_ptr, "temp data buffer", dfm_data.bptr);
1077 call ssu_$get_temp_segment (sci_ptr, "list catalog", dfm_data.lcatp);
1078
1079 do i = lbound (dfm_data.dkf_iocbp, 1) to hbound (dfm_data.dkf_iocbp, 1);
1080 if dfm_data.dkf_iocbp (i) ^= null & dfm_data.of_iocbp ^= null then
1081 call dfm_util_$merge_files (dfm_datap, dfm_data.dkf_iocbp (i), dfm_data.of_iocbp);
1082 end;
1083
1084 do i = lbound (list_types, 1) to hbound (list_types, 1);
1085 dfm_data.list_key = list_types (i);
1086 call dfm_util_$find_key (dfm_datap, dfm_data.of_iocbp, dfm_data.list_key, dfm_data.lcatp, code);
1087 if code ^= 0 then dfm_data.list_key = "";
1088 if dfm_data.list_key ^= "" then call dfm_util_$print_list (dfm_datap, dfm_data.of_iocbp, dfm_data.list_key);
1089 end;
1090
1091 call wrap_up;
1092 return;
1093
1094 %page;
1095
1096
1097
1098
1099 patch_deck: entry (P_sci_ptr, P_dfm_infop);
1100
1101 call setup_part1;
1102 call setup_part2;
1103 dfm_data.pd = true;
1104 dl_patch = false;
1105
1106 on cleanup call wrap_up;
1107
1108 call ssu_$arg_count (sci_ptr, nargs);
1109 if nargs > 0 then do i = 1 to nargs;
1110 call ssu_$arg_ptr (sci_ptr, i, ap, al);
1111
1112 if arg = "-brief"
1113 | arg = "-bf" then dfm_data.bf_sw = true;
1114
1115 else if arg = "-deckfile" | arg = "-df" then do;
1116 i = i + 1;
1117 call ssu_$arg_ptr (sci_ptr, i, ap, al);
1118 if al = 0 then
1119 call complain (dfm_datap, wrapup, code, "obtaining ""-deckfile"" specification.", "");
1120 else deckfile_path = arg;
1121 end;
1122
1123 else if arg = "-delete" | arg = "-dl" then dl_patch = true;
1124
1125 else if deck_tb_patched = "" then deck_tb_patched = arg;
1126
1127 else call complain (dfm_datap, wrapup, error_table_$bad_arg, "only one deck may be patched");
1128 end;
1129
1130 if deck_tb_patched = "" then do;
1131 call complain (dfm_datap, print, error_table_$noarg,
1132 "A search key for deck to be patched is required", "");
1133
1134 query_message = "Enter a key or partial key to specify the deck to be patched.";
1135 query_info.explanation_len = length (rtrim (query_message));
1136 query_info.explanation_ptr = addr (query_message);
1137 call command_query_ (query_info_ptr, user_reply, pname,
1138 "Enter <key of deck to be patched>: ");
1139
1140 deck_tb_patched = user_reply;
1141
1142 end;
1143
1144
1145 call ssu_$get_temp_segment (sci_ptr, "temp buffer", dfm_data.bptr);
1146 call ssu_$get_temp_segment (sci_ptr, "catalog keys", dfm_data.dfkp);
1147 call ssu_$get_temp_segment (sci_ptr, "list catalog", dfm_data.lcatp);
1148
1149 df_keys.n_entries = 0;
1150 lcata.n_entries = 0;
1151
1152 dfm_data.deckfile_sw = true;
1153
1154 call get_files;
1155
1156 call dfm_util_$get_cata (dfm_datap, dfm_data.fiocb_ptr, "ls.cata.ifad.list", dfm_data.lcatp, dfm_data.lksp, code);
1157 if code ^= 0 then
1158 call complain (dfm_datap, wrapup, code, "can't get list catalog", "");
1159
1160 call dfm_util_$find_key (dfm_datap, dfm_data.fiocb_ptr,
1161 deck_tb_patched, dfm_data.dfkp, code);
1162 if code ^= 0 then
1163 call complain (dfm_datap, wrapup, code, "attempting to find keys for ^a", deck_tb_patched);
1164
1165 term = false;
1166
1167 if df_keys.n_entries > 1 then do j = 1 to df_keys.n_entries while (^term);
1168 call command_query_$yes_no (yes_sw, 0, pname, "^d^2s entries matched the key given",
1169 "key given matched ^d entries.^/ Entry ^d is ^a - Is this the deck to be patched?",
1170 df_keys.n_entries, j, df_keys.key (j));
1171
1172 if yes_sw then do;
1173 term = true;
1174 j = j - 1;
1175 end;
1176 end;
1177
1178 else j = 1;
1179
1180 if j > df_keys.n_entries & ^term then
1181 call complain (dfm_datap, wrapup, 0, "There is no file to be patched", "");
1182 deck_tb_patched = df_keys.key (j);
1183
1184 term = false;
1185 if ^dl_patch then
1186 do i = lbound (dfm_data.opatches, 1) to hbound (dfm_data.opatches, 1) while (^term);
1187
1188 query_message = "Patch type may either be delete, chex, rhex or octal.";
1189 query_info.explanation_len = length (rtrim (query_message));
1190 query_info.explanation_ptr = addr (query_message);
1191 call command_query_ (query_info_ptr, user_reply, pname, "Enter patch type: ");
1192
1193 if user_reply = "delete"
1194 | user_reply = "dl" then dl_patch, term = true;
1195
1196 else if user_reply = "octal"
1197 | user_reply = "mask" then do;
1198 ascii_cardp = addr (dfm_data.opatches (i));
1199 o_patch = " ";
1200 o_patch.type = user_reply;
1201
1202 query_message = "Enter the octal address of this patch.";
1203 query_info.explanation_len = length (rtrim (query_message));
1204 query_info.explanation_ptr = addr (query_message);
1205 call command_query_ (query_info_ptr, user_reply, pname,
1206 "Enter beginning address: ");
1207 o_patch.add = user_reply;
1208
1209 query_message = "Enter the patches. Consecutive locations maybe separated by a (,) up to 10 patches";
1210 query_info.explanation_len = length (rtrim (query_message));
1211 query_info.explanation_ptr = addr (query_message);
1212 call command_query_ (query_info_ptr, user_reply, pname, "Enter patch data: ");
1213 o_patch.p_fld = user_reply;
1214 call ioa_$rsnnl ("^6a ^5a^[60a^;^3x^57a^]^12x",
1215 patch_word, patch_length, convert (add_pic, o_patch.add),
1216 o_patch.type, (o_patch.type = "mask"), o_patch.p_fld);
1217 call command_query_$yes_no (yes_sw, 0, pname,
1218 "Is this patch correct", "Patch entered: ^/^a^/Is this correct? ",
1219 patch_word);
1220 if yes_sw then string (opatches (i)) = patch_word;
1221 else i = i - 1;
1222 call command_query_$yes_no (yes_sw, 0, pname,
1223 "MORE PATCHES?", "Are there anymore patches?");
1224 if ^yes_sw then term = true;
1225 patch_ptr = addr (dfm_data.opatches);
1226 npatches = i;
1227 end;
1228
1229
1230 else if user_reply = "chex"
1231 | user_reply = "rhex" then do;
1232 ascii_cardp = addr (dfm_data.hpatches (i));
1233 h_patch = " ";
1234 h_patch.type = user_reply;
1235 query_message = "Enter the hex address of this patch.";
1236 query_info.explanation_len = length (rtrim (query_message));
1237 query_info.explanation_ptr = addr (query_message);
1238 call command_query_ (query_info_ptr, user_reply, pname, "Enter address: ");
1239 h_patch.add = "0000";
1240 substr (h_patch.add, 5 - length (user_reply)) = user_reply;
1241
1242 query_message = "Enter the hex patch for this location.";
1243 query_info.explanation_len = length (rtrim (query_message));
1244 query_info.explanation_ptr = addr (query_message);
1245 call command_query_ (query_info_ptr, user_reply, pname, "Enter patch data: ");
1246 h_patch.inst = "0000";
1247 substr (h_patch.inst, 5 - length (user_reply)) = user_reply;
1248 call ioa_$rsnnl ("^4a ^4a^5x^4a^61x", patch_word, patch_length,
1249 h_patch.add, h_patch.type, h_patch.inst);
1250 call command_query_$yes_no (yes_sw, 0, pname,
1251 "Is this patch correct", "Patch entered ^/^a^/Is this correct? ",
1252 patch_word);
1253 if yes_sw then string (dfm_data.hpatches (i)) = patch_word;
1254 else i = i - 1;
1255 call command_query_$yes_no (yes_sw, 0, pname,
1256 "MORE PATCHES?", "Are there anymore patches?");
1257 if ^yes_sw then term = true;
1258 patch_ptr = addr (dfm_data.hpatches);
1259 npatches = i;
1260 end;
1261 end;
1262
1263 if dl_patch then npatches = 0;
1264
1265 call dfm_util_$find_dkend (dfm_datap, deck_tb_patched, patch_ptr, npatches, code);
1266 if code ^= 0 then
1267 call complain (dfm_datap, wrapup, code, "attempting to patch file ^a", deck_tb_patched);
1268
1269 call dfm_util_$insert_deck (dfm_datap, dfm_data.fiocb_ptr,
1270 dfm_data.lcatp, length (unspec (lcata)), "ls.cata.ifad.list");
1271
1272 call dfm_util_$detach_file (dfm_datap, dfm_data.liocb_ptr);
1273 dfm_data.liocb_ptr = iox_$user_output;
1274 dfm_data.terminal_out = true;
1275
1276 dfm_data.list_key = "ls." || rtrim (deck_tb_patched);
1277
1278 call dfm_util_$find_key (dfm_datap, dfm_data.fiocb_ptr, dfm_data.list_key, dfm_data.lcatp, code);
1279 if code ^= 0 then
1280 call complain (dfm_datap, wrapup, code, "attempting to find keys for ^a", dfm_data.list_key);
1281
1282 call dfm_util_$print_list (dfm_datap, dfm_data.fiocb_ptr, rtrim (lcata.key (1)));
1283
1284 call wrap_up;
1285 return;
1286
1287
1288 %page;
1289
1290
1291
1292 pi_handler: entry (P_sci_ptr);
1293
1294 sci_ptr = P_sci_ptr;
1295 dfm_infop = ssu_$get_info_ptr (sci_ptr);
1296 dfm_datap = dfm_info.dfm_data_ptr;
1297 call wrap_up;
1298 return;
1299
1300
1301
1302 %page;
1303
1304
1305
1306 quit: entry (P_sci_ptr, P_dfm_infop);
1307
1308 call setup_part1;
1309
1310 call wrap_up;
1311 call ssu_$abort_subsystem (sci_ptr);
1312 return;
1313
1314
1315
1316 %page;
1317
1318
1319
1320
1321 add_name: proc (aname);
1322
1323 dcl aname char (*);
1324
1325
1326 if dfm_data.deckfile_sw then do;
1327 call hcs_$chname_file (dkf_dir (1), dkf_entry (1), "", rtrim (aname) || ".deckfile", code);
1328 if code ^= 0 & code ^= error_table_$segnamedup then
1329 call complain (dfm_datap, wrapup, code, "adding name ^a^/^-to ^a>^a",
1330 rtrim (aname) || ".deckfile", dfm_data.dir, dfm_data.entry);
1331
1332 if ^dfm_data.bf_sw & code = 0 then
1333 call complain (dfm_datap, print, 0, "added name ^a^/^-to ^a>^a",
1334 rtrim (aname) || ".deckfile", dfm_data.dir, dfm_data.entry);
1335
1336 call hcs_$chname_file (lsf_dir, lsf_entry, "", rtrim (aname) || ".list", code);
1337 if code ^= 0 & code ^= error_table_$segnamedup then
1338 call complain (dfm_datap, wrapup, code, "adding name ^a^/^-to ^a>^a",
1339 rtrim (aname) || ".list", lsf_dir, lsf_entry);
1340
1341 if ^dfm_data.bf_sw & code = 0 then
1342 call complain (dfm_datap, print, 0, "added name ^a^/^-to ^a>^a",
1343 rtrim (aname) || ".list", lsf_dir, lsf_entry);
1344 end;
1345 end add_name;
1346
1347 %page;
1348
1349
1350
1351 file_deck: proc (fptr, dlen);
1352
1353 dcl dlen fixed bin (21);
1354 dcl fptr ptr;
1355
1356 if dfm_data.lft
1357 & cata.n_entries = 0 then do;
1358 call dfm_util_$get_cata (dfm_datap, dfm_data.fiocb_ptr, "cata." || rtrim (dfm_data.cat_key),
1359 dfm_data.catp, dfm_data.cksp, code);
1360 if code ^= 0 then call complain (dfm_datap, wrapup, code,
1361 "Attempting to do a get catalog for cata.^a", rtrim (dfm_data.cat_key));
1362 end;
1363
1364 call dfm_util_$make_key (dfm_datap);
1365
1366 call dfm_util_$insert_deck (dfm_datap, dfm_data.fiocb_ptr,
1367 fptr, dlen, dfm_data.current_key);
1368
1369 call dfm_util_$update_list (dfm_datap, data_list_type);
1370
1371 end file_deck;
1372
1373
1374 %page;
1375
1376
1377
1378 get_files: proc ();
1379
1380
1381
1382
1383 if dfm_data.deckfile_sw then do;
1384 if deckfile_path ^= "" then do;
1385 if deckfile_path = "-working_dir"
1386 | deckfile_path = "-wd" then
1387 deckfile_path = rtrim (dir) || deckfile;
1388
1389 else if deckfile_path = "-system"
1390 | deckfile_path = "-sys" then
1391 deckfile_path = system_dir || deckfile;
1392
1393 call expand_pathname_ (deckfile_path, dkf_dir (1), dkf_entry (1), code);
1394 if code ^= 0 then call complain (dfm_datap, wrapup, code,
1395 "encountered while expanding path ^a", deckfile_path);
1396 end;
1397 else if dfm_info.deckfile_dir ^= "" then do;
1398 dkf_dir (1) = dfm_info.deckfile_dir;
1399 dkf_entry (1) = dfm_info.deckfile_entry;
1400 end;
1401 else do;
1402 dkf_dir (1) = dfm_data.dir;
1403 dkf_entry (1) = "tandd_deck_file";
1404 end;
1405
1406
1407 call dfm_util_$find_file (dfm_datap, dkf_dir (1), dkf_entry (1));
1408
1409 dfm_data.dir = dkf_dir (1);
1410 dfm_data.entry = dkf_entry (1);
1411
1412 if dfm_data.list then vfile_open_mode = Keyed_sequential_input;
1413 else vfile_open_mode = Keyed_sequential_update;
1414 call dfm_util_$open_file (dfm_datap, "dk_file_sw",
1415 "vfile_ " || rtrim (dkf_dir (1)) || ">" || rtrim (dkf_entry (1)), vfile_open_mode, dfm_data.fiocb_ptr);
1416
1417 end;
1418
1419
1420
1421
1422 else if dfm_data.mdf then do;
1423 do i = lbound (dkf_path, 1) to hbound (dkf_path, 1) while (dkf_path (i) ^= "");
1424 call expand_pathname_ ((dkf_path (i)), dkf_dir (i), dkf_entry (i), code);
1425 if code ^= 0 then call complain (dfm_datap, wrapup, code,
1426 "encountered while expanding path ^a", dkf_path (i));
1427
1428 if dkf_path (i) ^= "" then do;
1429 call dfm_util_$open_file (dfm_datap, "dkf_sw" || ltrim (char (i)),
1430 "vfile_ " || rtrim (dkf_dir (i)) || ">" || rtrim (dkf_entry (i)),
1431 Keyed_sequential_input, dfm_data.dkf_iocbp (i));
1432 end;
1433 end;
1434
1435 if of_path ^= "" then do;
1436 call expand_pathname_ (of_path, of_dir, of_entry, code);
1437 if code ^= 0 then call complain (dfm_datap, wrapup, code,
1438 "encountered while expanding path ^a", of_path);
1439 end;
1440
1441 else if dfm_info.deckfile_dir ^= "" then do;
1442 of_dir = dfm_info.deckfile_dir;
1443 of_entry = dfm_info.deckfile_entry;
1444 end;
1445
1446 else do;
1447 of_dir = dfm_data.dir;
1448 of_entry = "tandd_deck_file";
1449 end;
1450
1451
1452 call dfm_util_$find_file (dfm_datap, of_dir, of_entry);
1453
1454 dfm_data.dir = of_dir;
1455 dfm_data.entry = of_entry;
1456
1457 call dfm_util_$open_file (dfm_datap, "of_sw",
1458 "vfile_ " || rtrim (of_dir) || ">" || of_entry,
1459 Keyed_sequential_update, dfm_data.of_iocbp);
1460 end;
1461
1462
1463
1464
1465 if dfm_data.attach_copy then do;
1466 call dfm_util_$open_file (dfm_datap, "copy_sw",
1467 rtrim (c_att_desc) || " -write", Sequential_output, dfm_data.ciocb_ptr);
1468 end;
1469
1470
1471
1472
1473
1474 if (dfm_data.deckfile_sw | dfm_data.mdf)
1475 & ^dfm_data.terminal_out then do;
1476
1477 if of_dir ^= "" then lsf_dir = of_dir;
1478 else if dkf_dir (1) ^= "" then lsf_dir = dkf_dir (1);
1479 else if dfm_info.deckfile_dir ^= "" then lsf_dir = dfm_info.deckfile_dir;
1480 else lsf_dir = dfm_data.dir;
1481 lsf_entry = "deckfile.list";
1482
1483 call dfm_util_$find_file (dfm_datap, lsf_dir, lsf_entry);
1484
1485 if ^dfm_data.mdf & ^dfm_data.list then
1486 call dfm_util_$open_file (dfm_datap, "list_sw",
1487 rtrim ("vfile_ " || rtrim (lsf_dir) || ">" || rtrim (lsf_entry) || " -extend"),
1488 Stream_input_output, dfm_data.liocb_ptr);
1489
1490 else if dfm_data.mdf | dfm_data.list then
1491 call dfm_util_$open_file (dfm_datap, "list_sw",
1492 rtrim ("vfile_ " || rtrim (lsf_dir) || ">" || rtrim (lsf_entry)), Stream_output, dfm_data.liocb_ptr);
1493
1494 end;
1495
1496
1497
1498 if dfm_data.lft then
1499 call dfm_util_$open_file (dfm_datap, "tape_sw", dfm_data.t_att_desc, Sequential_input, dfm_data.tiocb_ptr);
1500
1501
1502
1503 end get_files;
1504
1505
1506 %page;
1507
1508
1509
1510 setup_part1: proc;
1511
1512 sci_ptr = P_sci_ptr;
1513 dfm_infop = P_dfm_infop;
1514 dfm_datap = dfm_info.dfm_data_ptr;
1515 dfm_data.infop = dfm_infop;
1516 dfm_data.sci_ptr = sci_ptr;
1517 pname = ssu_$get_subsystem_and_request_name (sci_ptr);
1518 end;
1519
1520 %page;
1521
1522
1523
1524 setup_part2: proc;
1525
1526
1527 dfm_info.flags.request_active = true;
1528 call date_time_ (clock (), dfm_data.time_string);
1529 dfm_data.gtime_string = date_time_$format ("^yc^my^dm", clock (), "system_zone", "system_lang");
1530 dfm_data.dir = get_wdir_ ();
1531
1532 dfm_data.bptr = null;
1533 dfm_data.catp = null;
1534 dfm_data.ciocb_ptr = null;
1535 dfm_data.dcatp = null;
1536 dfm_data.dfkp = null;
1537
1538 do i = lbound (dfm_data.dkf_iocbp, 1) to hbound (dfm_data.dkf_iocbp, 1);
1539 dfm_data.dkf_iocbp (i) = null;
1540 end;
1541
1542 dfm_data.fiocb_ptr = null;
1543 dfm_data.hbuff_p = null;
1544 dfm_data.lbuff_p = null;
1545 dfm_data.lcatp = null;
1546 dfm_data.liocb_ptr = null;
1547 dfm_data.mca_wksp = null;
1548 dfm_data.mcatp = null;
1549 dfm_data.of_iocbp = null;
1550 dfm_data.tiocb_ptr = null;
1551
1552 dfm_data.dd = false;
1553 dfm_data.allow_0_cksum = false;
1554 dfm_data.attach_copy = false;
1555 dfm_data.cat_build = false;
1556 dfm_data.cd_sw = false;
1557 dfm_data.copy_at_eof = false;
1558 dfm_data.deckfile_sw = false;
1559 dfm_data.finished = false;
1560 dfm_data.eot = false;
1561 dfm_data.first_deck = false;
1562 dfm_data.first_write = false;
1563 dfm_data.firmware_sw = false;
1564 dfm_data.fnp_tape = false;
1565 dfm_data.hdr_sw = true;
1566 dfm_data.lfd = false;
1567 dfm_data.lft = false;
1568 dfm_data.list = false;
1569 dfm_data.one_eof = false;
1570 dfm_data.mdf = false;
1571 term = false;
1572 dfm_data.terminal_out = false;
1573
1574 deck_tb_patched = "";
1575 deckfile_path = "";
1576 dfm_data.current_key = "";
1577 dfm_data.cat_key = "";
1578 dfm_data.list_key = "";
1579 dfm_data.tape_name = "";
1580 dfm_data.crec = 0;
1581 dfm_data.denno = 0;
1582 dfm_data.fnp_key = 0;
1583 n_diskettes_tb_read = 0;
1584 dfm_data.cfile = 1;
1585 dfm_data.pfile = 1;
1586 dfm_data.page_no = dfm_info.page_number;
1587 dkf_dir = "";
1588 dkf_entry = "";
1589 dkf_dir = "";
1590 dkf_entry = "";
1591 dkf_path = "";
1592 of_dir = "";
1593 of_entry = "";
1594 of_path = "";
1595
1596 query_info_ptr = addr (query_info);
1597 query_info.yes_or_no_sw = false;
1598 query_info.version = query_info_version_6;
1599 query_info.suppress_name_sw = false;
1600 query_info.suppress_spacing = false;
1601 query_info.cp_escape_control = "11"b;
1602 query_info.literal_sw = false;
1603 query_info.prompt_after_explanation = true;
1604 query_info.padding = false;
1605 query_info.status_code = 0;
1606 query_info.question_iocbp, query_info.answer_iocbp = null ();
1607 query_info.repeat_time = 0;
1608
1609 end;
1610
1611 %page;
1612
1613
1614
1615 wrap_up: proc ();
1616 if ^dfm_info.flags.request_active then return;
1617 dfm_info.page_number = dfm_data.page_no;
1618 if dfm_data.liocb_ptr ^= null & ^dfm_data.terminal_out then
1619 call dfm_util_$detach_file (dfm_datap, dfm_data.liocb_ptr);
1620 dfm_data.liocb_ptr = null;
1621
1622 if dfm_data.ciocb_ptr ^= null then
1623 call dfm_util_$detach_file (dfm_datap, dfm_data.ciocb_ptr);
1624 dfm_data.ciocb_ptr = null;
1625
1626 do i = lbound (dfm_data.dkf_iocbp, 1) to hbound (dfm_data.dkf_iocbp, 1);
1627 if dfm_data.dkf_iocbp (i) ^= null then
1628 call dfm_util_$detach_file (dfm_datap, dfm_data.dkf_iocbp (i));
1629 dfm_data.dkf_iocbp (i) = null;
1630 end;
1631
1632 if dfm_data.fiocb_ptr ^= null then
1633 call dfm_util_$detach_file (dfm_datap, dfm_data.fiocb_ptr);
1634 dfm_data.fiocb_ptr = null;
1635
1636 if dfm_data.of_iocbp ^= null then
1637 call dfm_util_$detach_file (dfm_datap, dfm_data.of_iocbp);
1638 dfm_data.of_iocbp = null;
1639
1640 if dfm_data.tiocb_ptr ^= null then
1641 call dfm_util_$detach_file (dfm_datap, dfm_data.tiocb_ptr);
1642 dfm_data.tiocb_ptr = null;
1643
1644 if dfm_data.lbuff_p ^= null then
1645 free dfm_data.lbuff_p -> lbuff in (free_area);
1646 dfm_data.lbuff_p = null;
1647
1648 if dfm_data.hbuff_p ^= null then
1649 free dfm_data.hbuff_p -> hbuff in (free_area);
1650 dfm_data.hbuff_p = null;
1651
1652 if dfm_data.m_attached then do;
1653 if ^mca_status.maj & mca_sub.data_p then
1654 call mca_$read_data (dfm_data.mca_ioi_idx, dfm_data.mca_wksp,
1655 max_words_to_rd, rl, "0"b, 0);
1656 call dfm_util_$mca_detach (dfm_datap);
1657 end;
1658
1659 if dfm_data.bptr ^= null then
1660 call ssu_$release_temp_segment (sci_ptr, dfm_data.bptr);
1661 dfm_data.bptr = null;
1662
1663 if dfm_data.catp ^= null then
1664 call ssu_$release_temp_segment (sci_ptr, dfm_data.catp);
1665 dfm_data.catp = null;
1666
1667 if dfm_data.dcatp ^= null then
1668 call ssu_$release_temp_segment (sci_ptr, dfm_data.dcatp);
1669 dfm_data.dcatp = null;
1670
1671 if dfm_data.dfkp ^= null then
1672 call ssu_$release_temp_segment (sci_ptr, dfm_data.dfkp);
1673 dfm_data.dfkp = null;
1674
1675 if dfm_data.mca_wksp ^= null then
1676 call ssu_$release_temp_segment (sci_ptr, dfm_data.mca_wksp);
1677 dfm_data.mca_wksp = null;
1678
1679 if dfm_data.lcatp ^= null then
1680 call ssu_$release_temp_segment (sci_ptr, dfm_data.lcatp);
1681 dfm_data.lcatp = null;
1682
1683 if dfm_data.mcatp ^= null then
1684 call ssu_$release_temp_segment (sci_ptr, dfm_data.mcatp);
1685 dfm_data.mcatp = null;
1686
1687 dfm_data.finished = true;
1688 dfm_info.flags.request_active = false;
1689
1690 end;
1691
1692
1693 %page;
1694
1695
1696
1697 %include dfm_info;
1698 %page;
1699 %include dfm_data;
1700 %page;
1701 %include iox_modes;
1702 %page;
1703 %include mca_diskette;
1704 %page;
1705 %include query_info;
1706 %page;
1707 %include sub_err_flags;
1708
1709
1710 end dfm_;