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 rtq_: proc ();
27
28
29
30
31 dcl bcd_to_ascii_ entry (bit (*), char (*));
32 dcl comp_8_to_ascii_ entry (bit (*), char (*));
33 dcl cv_dec_check_ entry (char (*), fixed bin (35)) returns (fixed bin (35));
34 dcl cv_oct_check_ entry (char (*), fixed bin (35)) returns (fixed bin (35));
35 dcl date_time_ entry (fixed bin (71), char (*));
36 dcl ebcdic_to_ascii_ entry (char (*), char (*));
37 dcl ebcdic8_to_ascii_ entry (bit (*), char (*));
38 dcl expand_pathname_$add_suffix entry (char (*), char (*), char (*), char (*), fixed bin (35));
39 dcl ioa_ entry options (variable);
40 dcl ioa_$rsnnl entry options (variable);
41 dcl iox_$attach_name entry (char (*), ptr, char (*), ptr, fixed bin (35));
42 dcl iox_$close entry (ptr, fixed bin (35));
43 dcl iox_$control entry (ptr, char (*), ptr, fixed bin (35));
44 dcl iox_$detach_iocb entry (ptr, fixed bin (35));
45 dcl iox_$open entry (ptr, fixed bin, bit (1) aligned, fixed bin (35));
46 dcl iox_$read_record entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35));
47 dcl iox_$put_chars entry (ptr, ptr, fixed bin (21), fixed bin (35));
48 dcl iox_$write_record entry (ptr, ptr, fixed bin (21), fixed bin (35));
49 dcl iox_$get_line entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35));
50 dcl pathname_ entry (char (*), char (*)) returns (char (168));
51 dcl ssu_$abort_line entry () options (variable);
52 dcl ssu_$abort_subsystem entry () options (variable);
53 dcl ssu_$arg_count entry (ptr, fixed bin);
54 dcl ssu_$arg_ptr entry (ptr, fixed bin, ptr, fixed bin);
55 dcl ssu_$get_subsystem_and_request_name entry (ptr) returns (char (72) var);
56 dcl ssu_$print_message entry () options (variable);
57
58
59 dcl (cleanup, conversion, program_interrupt) condition;
60
61
62 dcl (addr, addrel, bin, char, currentsize, divide, fixed, hbound, index, length, ltrim, mod, null, rtrim,
63 revert, search, substr, translate, unspec) builtin;
64
65
66 dcl BINARY_MODE fixed bin static options (constant) init (1);
67 dcl LABEL (0:6) char (9) int static options (constant) init
68 ("unlabeled", "Multics", "Multics", "GCOS", "IBM", "ANSI", "CP5");
69 dcl NL char (1) int static options (constant) init ("
70 ");
71 dcl NINE_MODE fixed bin static options (constant) init (3);
72 dcl NUMB_OF_CHARS_PER_WORD fixed bin static options (constant) init (4);
73 dcl YES_FLG bit (1) aligned;
74 dcl Nargs fixed bin;
75 dcl al fixed bin;
76 dcl ansid bit (1) aligned;
77 dcl ansi_mode fixed bin;
78 dcl ap ptr;
79 dcl arg_dex fixed bin;
80 dcl att_desc char (200);
81 dcl attach_desc_output char (200) varying;
82 dcl bcnt fixed bin (24);
83 dcl binck bit (1) aligned;
84 dcl blocksize fixed bin (35);
85 dcl (c_b_a,
86 c_c_a,
87 c_e_a,
88 cont,
89 cp5) bit (1) aligned;
90 dcl code fixed bin (35);
91 dcl dec_sw bit (1) aligned;
92 dcl direction bit (1) aligned;
93 dcl eoj_card char (14) static options (constant) init
94 ("$ endjob
95 ");
96 dcl first_record_flg bit (1) aligned;
97 dcl g_label bit (72) int static options (constant) init
98 ("272520200600002022634320"b3);
99 dcl gssf bit (1) aligned;
100 dcl (i, j) fixed bin;
101 dcl ibm_label fixed bin int static options (constant) init (4);
102 dcl ibmv bit (1) aligned;
103 dcl imcv bit (1) aligned;
104 dcl it_cnt fixed bin;
105 dcl iterations fixed bin (35);
106 dcl l_cnt fixed bin (35);
107 dcl l_rec bit (1) aligned;
108 dcl l_rec_len fixed bin (35);
109 dcl last_record_flg bit (1) aligned;
110 dcl lrp ptr;
111 dcl mode (3) char (7) int static options (constant) init
112 ("binary", "bcd", "nine");
113 dcl mssf bit (1) aligned;
114 dcl nchars fixed bin (21);
115 dcl nnl_sw bit (1) aligned;
116 dcl n_ops fixed bin;
117 dcl nunits fixed bin (35);
118 dcl nwds fixed bin (35);
119 dcl open_mode fixed bin;
120 dcl order char (16);
121 dcl pname char (19) int static options (constant) init
122 ("read_tape_and_query");
123 dcl rf bit (1) aligned;
124 dcl rpt bit (1) aligned;
125 dcl rtq_info_ptr ptr;
126 dcl s_filename char (32) varying;
127 dcl save_status_code fixed bin (35);
128 dcl sci_ptr ptr;
129 dcl scode fixed bin (35);
130 dcl schar fixed bin (35);
131 dcl spill fixed bin (21);
132 dcl status_story char (100) varying;
133 dcl t_stat bit (12) aligned;
134 dcl temp_logical_rec_len fixed bin (21);
135 dcl time_string char (24);
136 dcl tr_cnt fixed bin (35);
137 dcl trim_trailing_blanks_log_rec_len fixed bin (21);
138 dcl trunc_sw bit (1) aligned;
139 dcl who_asked char (32) varying;
140
141
142 dcl (error_table_$end_of_info,
143 error_table_$not_closed,
144 error_table_$not_detached,
145 error_table_$tape_error) fixed bin (35) ext;
146
147 dcl iox_$user_output ptr ext;
148 dcl sys_info$max_seg_size fixed bin (35) ext static;
149 dcl tape_status_table_$tape_status_table_ ext static;
150
151
152 dcl 1 ansi_db_lrec based (rtq_info.rptr) unaligned,
153 2 lrl char (4),
154 2 alrd char (l_rec_len),
155 2 nxt_lrec bit (0);
156
157 dcl 1 conv_buf based (lrp),
158 2 skip_char char (schar),
159 2 conv_dta char (rtq_info.rec_len - schar + 1);
160
161 dcl 1 cp5_phy_rec based (rtq_info.tptr) aligned,
162 ( 2 pbs fixed bin (18) unsigned,
163 2 nky fixed bin (18) unsigned,
164 2 first bit (1)) unaligned;
165
166 dcl 1 cp5_log_rec based (rtq_info.rptr) aligned,
167 ( 2 pad1 bit (36),
168 2 pad2 fixed bin,
169 2 rlen fixed bin (18) unsigned,
170 2 cp5_log_rec_data char (1 refer (cp5_log_rec.rlen))) unaligned;
171
172 dcl 1 dec_mult (it_cnt) based (lrp) aligned,
173 ( 2 first_32 bit (32),
174 2 last_4 bit (4)) unaligned;
175
176 dcl 1 dec_tape_raw based (rtq_info.tptr) aligned,
177 2 ps_wd (it_cnt) unaligned,
178 3 first_32 bit (32),
179 3 pad bit (4),
180 3 last_4 bit (4);
181
182 dcl 1 ibm_log_rec based (rtq_info.rptr) unaligned,
183 2 rdw,
184 3 pad1 bit (1),
185 3 msl bit (8),
186 3 pad2 bit (1),
187 3 lsl bit (8),
188 3 pad3 bit (18),
189 2 ilrd char (l_rec_len),
190 2 nxt_lrec bit (0);
191
192 dcl 1 ibm_phy_rec based (rtq_info.tptr) aligned,
193 ( 2 bdw,
194 3 pad1 bit (1),
195 3 msl bit (8),
196 3 pad2 bit (1),
197 3 lsl bit (8),
198 3 pad3 bit (18),
199 2 iprd char (blocksize - 4)) unaligned;
200
201 dcl 1 lrec_cbuf based (lrp),
202 2 skip_char char (schar),
203 2 chcv_buf (it_cnt) char (l_rec_len);
204
205 dcl 1 mult based (rtq_info.tptr) unaligned,
206 2 lab_id bit (36),
207 2 pad (7) bit (36),
208 2 vol_info like volume_identifier;
209
210 dcl 1 gcos based (rtq_info.tptr) unaligned,
211 2 lab_id bit (72),
212 2 pad bit (36),
213 2 vol_id bit (36);
214
215 dcl 1 ibm_ansi based (rtq_info.tptr) unaligned,
216 2 lab_id bit (32),
217 2 vol_id bit (48);
218
219 dcl 1 cp5_lab based (rtq_info.tptr) unaligned,
220 2 lab_id bit (32),
221 2 vol_id bit (32);
222
223 dcl arg char (al) based (ap);
224
225 dcl bit_buf bit (rtq_info.bits) based (rtq_info.tptr);
226
227 dcl char_buf char (rtq_info.rec_len) based (rtq_info.tptr);
228
229 dcl cdkbuf char (136) based (rtq_info.cdkp);
230
231 dcl cbuf char (rtq_info.buf_size) based (rtq_info.cbufp);
232
233 dcl cv_buf char (rtq_info.cvbl) based (rtq_info.cvbp);
234
235 dcl gssf_ascii char (gc_log_rec.rcw.rsize * 4) based (rtq_info.cvp);
236
237 dcl lab_buf char (rtq_info.rec_len) based (rtq_info.lblp);
238
239 dcl mult_move char (rtq_info.clen) based;
240
241 dcl 1 rtq_info aligned like rtq_structure_info based (rtq_info_ptr);
242
243 dcl rtq_area area based (rtq_info.rtq_area_ptr);
244
245 dcl sentinel char (4) based (rtq_info.lblp);
246
247
248 dcl 1 ai like area_info aligned;
249
250
251 %page;
252 set_up: entry (sci_ptr, rtq_info_ptr, code);
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272 dcl NUMB_OF_BITS_PER_BYTE fixed bin static options (constant) init (9);
273 dcl NUMB_OF_BYTES_PER_WORD fixed bin static options (constant) init (4);
274 dcl CP5_label bit (32) int static options (constant) init
275 ("72D3C2D3"b4);
276
277 dcl a_label bit (32) int static options (constant) init
278 ("564F4C31"b4);
279
280 dcl ansi_label fixed bin int static options (constant) init (5);
281 dcl cp5_label fixed bin int static options (constant) init (6);
282 dcl i_label bit (32) int static options (constant) init
283 ("E5D6D3F1"b4);
284
285 dcl (v1_mult_label init (1),
286 v3_mult_label init (2)) fixed bin int static options (constant);
287
288
289 dcl get_line_length fixed bin;
290 dcl rcd_volid char (32);
291 dcl terminate_read_sw bit (1);
292
293
294 dcl blab (0:15) bit (9) unaligned based (addr (rcd_volid));
295
296
297 dcl define_area_ entry (ptr, fixed bin (35));
298 dcl get_temp_segment_ entry (char (*), ptr, fixed bin (35));
299 dcl get_line_length_$switch entry (ptr, fixed bin (35)) returns (fixed bin);
300
301
302
303 mssf = "0"b;
304 rcd_volid = "";
305 unspec (ai) = "0"b;
306 ai.version = area_info_version_1;
307 ai.control.extend = "1"b;
308 ai.control.zero_on_alloc = "1"b;
309 ai.owner = pname;
310 ai.size = sys_info$max_seg_size;
311 ai.version_of_area = area_info_version_1;
312 ai.areap = null;
313
314
315 on cleanup call detach_tape_file (sci_ptr, rtq_info_ptr);
316
317
318 on program_interrupt goto SET_UP_EXIT;
319
320
321 get_line_length = get_line_length_$switch (null, scode);
322 if get_line_length < 118 & scode = 0 then
323 rtq_info.short_output_flg = "1"b;
324 else rtq_info.short_output_flg = "0"b;
325
326
327 call define_area_ (addr (ai), code);
328 if code ^= 0 then do;
329 call ssu_$print_message (sci_ptr, code, "Cannot define an area");
330 return;
331 end;
332
333 rtq_info.rtq_area_ptr = ai.areap;
334
335
336 call get_temp_segment_ (pname, rtq_info.tptr, code);
337 if code ^= 0 then do;
338 call ssu_$print_message (sci_ptr, code, "Getting temporary tape buffer segment");
339 call detach_tape_file (sci_ptr, rtq_info_ptr);
340 return;
341 end;
342
343
344
345 allocate cv_buf in (rtq_area);
346 allocate cdkbuf in (rtq_area);
347 allocate cbuf in (rtq_area);
348
349
350 TRY_AGAIN:
351 call iox_$attach_name ("tape_sw", rtq_info.tiocb_ptr, (rtq_info.tape_atd), null, code);
352 if code ^= 0 then do;
353 if code = error_table_$not_detached then do;
354 call iox_$detach_iocb (rtq_info.tiocb_ptr, code);
355 if code ^= error_table_$not_closed then do;
356 call ssu_$print_message (sci_ptr, code);
357 return;
358 end;
359 else do;
360 call iox_$close (rtq_info.tiocb_ptr, (0));
361 goto TRY_AGAIN;
362 end;
363 end;
364 else do;
365 call ssu_$print_message (sci_ptr, code, "^/ Attempting to attach tape.");
366 call detach_tape_file (sci_ptr, rtq_info_ptr);
367 return;
368 end;
369 end;
370
371 call iox_$open (rtq_info.tiocb_ptr, Sequential_input, "0"b, code);
372 if code ^= 0 then do;
373 call ssu_$print_message (sci_ptr, code, "^/Opening tape for sequential input");
374 call detach_tape_file (sci_ptr, rtq_info_ptr);
375 return;
376 end;
377
378
379 rtq_info.cvbl = divide (rtq_info.buf_size * NUMB_OF_BITS_PER_BYTE, NUMB_OF_BYTES_PER_WORD, 21, 0);
380
381
382 j = hbound (rtq_info.density, 1);
383 terminate_read_sw = "0"b;
384 do i = 1 to j while (^terminate_read_sw);
385 call iox_$control (rtq_info.tiocb_ptr, (rtq_info.density (i)), null, scode);
386 if scode = 0 then do;
387 call iox_$read_record (rtq_info.tiocb_ptr, rtq_info.tptr, rtq_info.buf_size, rtq_info.rec_len, code);
388 if code ^= error_table_$tape_error then do;
389 if (code ^= 0) & (code ^= error_table_$end_of_info) then
390 call ssu_$print_message (sci_ptr, code, "^/Attempting to determine density of tape volume ^a", rtq_info.tape_name);
391
392 terminate_read_sw = "1"b;
393 end;
394 call iox_$control (rtq_info.tiocb_ptr, "rewind", null, scode);
395 end;
396 end;
397
398
399 rtq_info.tmr = terminate_read_sw;
400
401 if ^rtq_info.tmr | (code ^= 0 & code ^= error_table_$end_of_info) then do;
402 if rtq_info.ddec ^= 0 then rtq_info.c_den = "d" || ltrim (char (rtq_info.ddec));
403 else rtq_info.c_den = rtq_info.density (1);
404
405 call iox_$control (rtq_info.tiocb_ptr, (rtq_info.c_den), null, scode);
406
407 call ssu_$print_message (sci_ptr, 0,
408 "Unable to determine density of tape volume ^a.^/ Density is currently set to ^a (bpi).",
409 rtq_info.tape_name, substr (rtq_info.c_den, 2));
410
411 code = 0;
412 scode = 0;
413 end;
414
415
416 else do;
417 rtq_info.c_den = rtq_info.density (i - 1);
418
419 call ioa_ ("Tape density is ^a bpi", substr (rtq_info.density (i - 1), 2));
420
421 call determine_tape_label_types;
422
423 if rtq_info.return_subsys_loop_flg then do;
424 rtq_info.return_subsys_loop_flg = "0"b;
425 return;
426 end;
427 end;
428
429 SET_UP_EXIT:
430
431 return;
432
433
434
435 %page;
436 bof_request: entry (sci_ptr, rtq_info_ptr);
437
438
439
440
441
442
443
444 on cleanup call detach_tape_file (sci_ptr, rtq_info_ptr);
445
446 on program_interrupt goto BOF_EXIT;
447
448 call ssu_$arg_count (sci_ptr, Nargs);
449 if Nargs ^= 0 then do;
450 call ssu_$print_message (sci_ptr, 0, "Usage: bof");
451 return;
452 end;
453
454
455 scode = 0;
456 l_cnt = 1;
457 rf, rpt = "1"b;
458 direction = "0"b;
459 order = "begin_file";
460
461
462 call process_control_order (order, rpt, direction, rf, l_cnt);
463
464 BOF_EXIT:
465 return;
466
467
468 %page;
469 bsf_request: entry (sci_ptr, rtq_info_ptr);
470
471
472
473
474
475
476
477
478
479 on cleanup call detach_tape_file (sci_ptr, rtq_info_ptr);
480
481 on program_interrupt goto BSF_EXIT;
482
483
484 l_cnt = 1;
485 scode = 0;
486 rf, rpt = "1"b;
487 direction = "0"b;
488 order = "backspace_file";
489
490
491 call ssu_$arg_count (sci_ptr, Nargs);
492 if Nargs >= 2 then do;
493 ERROR_BSF:
494 call ssu_$print_message (sci_ptr, scode, "^/ Usage: bsf {n}");
495 return;
496 end;
497
498
499 do arg_dex = 1 to Nargs;
500 call ssu_$arg_ptr (sci_ptr, arg_dex, ap, al);
501 l_cnt = cv_dec_check_ (arg, scode);
502 if scode ^= 0 then goto ERROR_BSF;
503 end;
504
505
506 call process_control_order (order, rpt, direction, rf, l_cnt);
507
508
509 rtq_info.eof, rtq_info.eov, rtq_info.one_eof, rtq_info.two_eofs = "0"b;
510
511 BSF_EXIT:
512 return;
513
514
515 %page;
516 bsr_request: entry (sci_ptr, rtq_info_ptr);
517
518
519
520
521
522
523
524
525
526 on cleanup call detach_tape_file (sci_ptr, rtq_info_ptr);
527
528 on program_interrupt goto BSR_EXIT;
529
530
531 l_cnt = 1;
532 scode = 0;
533 rpt = "1"b;
534 rf, direction = "0"b;
535 order = "backspace_record";
536
537
538 call ssu_$arg_count (sci_ptr, Nargs);
539 if Nargs >= 2 then do;
540 ERROR_BSR:
541 call ssu_$print_message (sci_ptr, scode, "Usage: bsr {N}");
542 return;
543 end;
544
545
546 do arg_dex = 1 to Nargs;
547 call ssu_$arg_ptr (sci_ptr, arg_dex, ap, al);
548 l_cnt = cv_dec_check_ (arg, scode);
549 if scode ^= 0 then goto ERROR_BSR;
550 else ;
551 end;
552
553
554 call process_control_order (order, rpt, direction, rf, l_cnt);
555
556 BSR_EXIT:
557 return;
558
559
560
561 %page;
562 density_request: entry (sci_ptr, rtq_info_ptr);
563
564
565
566
567
568
569
570
571
572
573 dcl array_index fixed bin;
574 dcl match bit (1) aligned;
575
576
577 on cleanup call detach_tape_file (sci_ptr, rtq_info_ptr);
578
579 on program_interrupt goto DENSITY_EXIT;
580
581
582 l_cnt = 1;
583 match = "0"b;
584 scode = 0;
585 rpt, rf, direction = "0"b;
586
587
588 call ssu_$arg_count (sci_ptr, Nargs);
589 if Nargs = 0 | Nargs >= 2 then do;
590 ERROR_DENSITY:
591 call ssu_$print_message (sci_ptr, scode, "Usage: density (den) <6250 | 1600 | 800 | 556 | 200>");
592 return;
593 end;
594
595
596 call ssu_$arg_ptr (sci_ptr, Nargs, ap, al);
597 do array_index = 1 to 5 while (^match);
598 if arg = substr (rtq_info.density (array_index), 2, 4) then
599 match = "1"b;
600 end;
601 if ^match then
602 goto ERROR_DENSITY;
603 else do;
604 rtq_info.ddec = cv_dec_check_ (arg, scode);
605 if scode ^= 0 then goto ERROR_DENSITY;
606 else rtq_info.c_den, order = "d" || ltrim (char (rtq_info.ddec));
607 end;
608
609
610 call process_control_order (order, rpt, direction, rf, l_cnt);
611
612 DENSITY_EXIT:
613
614 return;
615
616
617 %page;
618 dot_request: entry (sci_ptr, rtq_info_ptr);
619
620
621
622
623
624 on cleanup call detach_tape_file (sci_ptr, rtq_info_ptr);
625
626 on program_interrupt goto RETURNS_TO_SUBSYS;
627
628
629 call ssu_$arg_count (sci_ptr, Nargs);
630 if Nargs ^= 0 then do;
631 call ssu_$print_message (sci_ptr, 0, "No argument is allowed for this request.");
632 return;
633 end;
634
635
636 call ioa_ ("read_tape_and_query (rtq): Reading tape volume ""^a"" in ""^a"" mode.^/ Currently positioned to Physical file ^d, record ^d.",
637 rtq_info.tape_name, mode (rtq_info.c_mode), rtq_info.c_file, rtq_info.c_rec);
638
639 RETURNS_TO_SUBSYS:
640
641 return;
642
643
644 %page;
645 dump_record_request: entry (sci_ptr, rtq_info_ptr);
646
647
648
649
650
651
652
653
654 dcl dump_segment_ entry (ptr, ptr, fixed bin, fixed bin (35), fixed bin (35), bit (*));
655
656
657 dcl NUMB_OF_BITS_PER_CHAR fixed bin static options (constant) init (9);
658 dcl NUMB_OF_BITS_PER_WORD fixed bin static options (constant) init (36);
659 dcl doffset fixed bin;
660 dcl dump_index fixed bin;
661 dcl format (4) bit (11);
662 dcl n_words_specified_flg bit (1) aligned;
663 dcl ndumps fixed bin;
664 dcl offset_specified_flg bit (1) aligned;
665
666
667 on cleanup call detach_tape_file (sci_ptr, rtq_info_ptr);
668
669 on program_interrupt goto WANTS_TO_EXIT;
670
671
672 if ^rtq_info.buf_ful then do;
673 call ssu_$print_message (sci_ptr, 0, "Record buffer empty");
674 return;
675 end;
676
677
678 scode = 0;
679 ndumps = 1;
680 doffset = 0;
681 format (1) = "01000000000"b;
682 nwds = divide (rtq_info.rec_len * NUMB_OF_BITS_PER_CHAR + 35, NUMB_OF_BITS_PER_WORD, 35, 0);
683 offset_specified_flg, n_words_specified_flg = "0"b;
684
685
686 call ssu_$arg_count (sci_ptr, Nargs);
687
688
689 do arg_dex = 1 to Nargs;
690 call ssu_$arg_ptr (sci_ptr, arg_dex, ap, al);
691 if substr (arg, 1, 1) ^= "-" then do;
692
693 if ^offset_specified_flg then do;
694 offset_specified_flg = "1"b;
695 doffset = cv_oct_check_ (arg, scode);
696 if scode ^= 0 then do;
697 ERROR_DUMP:
698 call ssu_$print_message (sci_ptr, scode,
699 "^/ Usage: dump {offset (oct)} {n_words (oct)} {-bcd} {-ascii} {-ebcdic} {-hex}");
700 return;
701 end;
702
703 nwds = nwds - doffset;
704 end;
705
706 else if ^n_words_specified_flg then do;
707 n_words_specified_flg = "1"b;
708 nwds = cv_oct_check_ (arg, scode);
709 if scode ^= 0 then goto ERROR_DUMP;
710 end;
711
712 else goto ERROR_DUMP;
713 end;
714
715 else if arg = "-bcd" then
716 call set_dump_fmt ("01010000000"b);
717
718 else if arg = "-ascii" then
719 call set_dump_fmt ("01001000000"b);
720
721 else if arg = "-ebcdic" then do;
722 if rtq_info.c_mode = 3 then
723 call set_dump_fmt ("01000010000"b);
724 else call set_dump_fmt ("01000001000"b);
725 end;
726
727 else if arg = "-hex" then do;
728 if rtq_info.c_mode = 3 then
729 call set_dump_fmt ("01000000001"b);
730 else call set_dump_fmt ("01000000010"b);
731 end;
732
733 else goto ERROR_DUMP;
734 end;
735
736 if ndumps > 1 then ndumps = ndumps - 1;
737
738 do dump_index = 1 to ndumps;
739 call ioa_ (" ");
740 call dump_segment_ (iox_$user_output, addrel (rtq_info.tptr, doffset), 0, 0, nwds, format (dump_index));
741 end;
742
743 WANTS_TO_EXIT:
744
745 return;
746
747
748
749 set_dump_fmt: proc (fmt);
750
751
752
753 dcl fmt bit (11);
754
755
756 format (ndumps) = fmt;
757 ndumps = ndumps + 1;
758
759 if ndumps > (hbound (format, 1) + 1) then
760 goto ERROR_DUMP;
761
762 end set_dump_fmt;
763
764
765 %page;
766 eof_request: entry (sci_ptr, rtq_info_ptr);
767
768
769
770
771 Note
772
773
774
775
776
777
778 on cleanup call detach_tape_file (sci_ptr, rtq_info_ptr);
779
780 on program_interrupt goto SUBSYSTEM_RETURNED;
781
782
783 call ssu_$arg_count (sci_ptr, Nargs);
784
785 if Nargs ^= 0 then do;
786 call ssu_$print_message (sci_ptr, 0, "Usage: eof");
787 return;
788 end;
789
790
791 rtq_info.eof_request_flg = "1"b;
792 scode = 0;
793 order = "forward_record";
794 rpt = "1"b;
795 direction = "1"b;
796 rf = "0"b;
797 l_cnt = 1;
798
799
800 do while (scode ^= error_table_$end_of_info);
801 call process_control_order (order, rpt, direction, rf, l_cnt);
802
803 if scode = 0 then
804 rtq_info.c_rec = rtq_info.c_rec + 1;
805
806 if scode = error_table_$tape_error then do;
807 call ssu_$print_message (sci_ptr, scode,
808 "Attempting to perform ""forward_record"" order");
809 rtq_info.eof_request_flg = "0"b;
810 return;
811 end;
812 end;
813
814
815 direction = "0"b;
816 rpt = "0"b;
817 rf = "0"b;
818 l_cnt = 1;
819 order = "backspace_record";
820
821 call process_control_order (order, rpt, direction, rf, l_cnt);
822
823
824 if rtq_info.c_rec = 1 then
825
826 call ssu_$print_message (sci_ptr, 0,
827 "Positioned the tape to the beginning of the current file # ^d which has no data record.", rtq_info.c_file);
828
829
830 else call ssu_$print_message (sci_ptr, 0,
831 "Positioned the tape to the end of the current file # ^d, after the last record # ^d.",
832 rtq_info.c_file, rtq_info.c_rec - 1);
833
834 rtq_info.one_eof = "0"b;
835 rtq_info.eof_request_flg = "0"b;
836
837 SUBSYSTEM_RETURNED:
838 return;
839
840
841 %page;
842 fsf_request: entry (sci_ptr, rtq_info_ptr);
843
844
845
846
847
848
849
850
851
852 on cleanup call detach_tape_file (sci_ptr, rtq_info_ptr);
853
854 on program_interrupt goto RETURNS_TO_REQUEST_LOOP;
855
856
857 scode = 0;
858 l_cnt = 1;
859 direction, rpt, rf = "1"b;
860 order = "forward_file";
861
862
863 call ssu_$arg_count (sci_ptr, Nargs);
864 if Nargs >= 2 then do;
865 ERROR_FSF:
866 call ssu_$print_message (sci_ptr, scode, "Usage: fsf {N}");
867 return;
868 end;
869
870
871 do arg_dex = 1 to Nargs;
872 call ssu_$arg_ptr (sci_ptr, arg_dex, ap, al);
873 l_cnt = cv_dec_check_ (arg, scode);
874 if scode ^= 0 then goto ERROR_FSF;
875 else ;
876 end;
877
878
879 call process_control_order (order, rpt, direction, rf, l_cnt);
880
881 RETURNS_TO_REQUEST_LOOP:
882
883 return;
884
885
886 %page;
887 fsr_request: entry (sci_ptr, rtq_info_ptr);
888
889
890
891
892
893
894
895
896
897 on cleanup call detach_tape_file (sci_ptr, rtq_info_ptr);
898
899 on program_interrupt goto FSR_RETURN;
900
901
902 scode = 0;
903 l_cnt = 1;
904 direction, rpt = "1"b;
905 rf = "0"b;
906 order = "forward_record";
907
908
909 call ssu_$arg_count (sci_ptr, Nargs);
910 if Nargs >= 2 then do;
911 ERROR_FSR:
912 call ssu_$print_message (sci_ptr, scode, "Usage: fsr {N}");
913 return;
914 end;
915
916
917 do arg_dex = 1 to Nargs;
918 call ssu_$arg_ptr (sci_ptr, arg_dex, ap, al);
919 l_cnt = cv_dec_check_ (arg, scode);
920 if scode ^= 0 then goto ERROR_FSR;
921 else ;
922 end;
923
924
925 call process_control_order (order, rpt, direction, rf, l_cnt);
926
927 FSR_RETURN:
928 return;
929
930
931 %page;
932 list_tape_contents: entry (sci_ptr, rtq_info_ptr);
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957 dcl logical_file_num fixed bin;
958 dcl label_flg bit (1) aligned;
959 dcl last_length fixed bin;
960 dcl logical_file_flg bit (1) aligned;
961 dcl long_list_flg bit (1) aligned;
962 dcl nrecords fixed bin (35);
963 dcl unlabeled fixed bin int static options (constant) init (0);
964
965
966 on cleanup call detach_tape_file (sci_ptr, rtq_info_ptr);
967
968 on program_interrupt goto SUBSYSTEM_REQUEST_LOOP;
969
970
971 scode = 0;
972 mssf = "0"b;
973 iterations = 1;
974 rtq_info.eof, rtq_info.eov, rtq_info.one_eof, rtq_info.set_bin, rtq_info.set_nine, rtq_info.two_eofs = "0"b;
975
976
977 long_list_flg, label_flg, logical_file_flg = "0"b;
978 logical_file_num, last_length, nrecords = 0;
979
980
981 call ssu_$arg_count (sci_ptr, Nargs);
982
983
984 do arg_dex = 1 to Nargs;
985 call ssu_$arg_ptr (sci_ptr, arg_dex, ap, al);
986
987 if arg = "-long" | arg = "-lg" then long_list_flg = "1"b;
988
989 else if arg = "-label" | arg = "-lbl" then
990 if rtq_info.l_type = unlabeled then do;
991 call ssu_$print_message (sci_ptr, 0, """-label"" argument not allowed on unlabeled tapes");
992 return;
993 end;
994 else label_flg = "1"b;
995
996 else do;
997 call ssu_$print_message (sci_ptr, 0, "Usage: list_tape_contents (ltc) {-long (-lg)} {-label (-lbl)}");
998 return;
999 end;
1000 end;
1001
1002
1003 if rtq_info.c_rec ^= 1 | rtq_info.c_file ^= 1 then
1004 call process_control_order ("rewind", "0"b, "0"b, "0"b, 1);
1005 else ;
1006
1007
1008 if rtq_info.l_type > 0 & rtq_info.l_type <= 3 then
1009 call check_mode (BINARY_MODE);
1010
1011
1012 else if rtq_info.l_type > 3 then
1013 call check_mode (NINE_MODE);
1014
1015
1016 call ioa_ ("Listing tape contents of tape volume ^a in ^a mode.^/ Starting at BOT (physical file# 1, record# 1)^/ ",
1017 rtq_info.tape_name, mode (rtq_info.c_mode));
1018
1019
1020 do while (^rtq_info.two_eofs);
1021 call read_tape_record ("skip", rtq_info.eof, "1"b, mssf);
1022
1023 if rtq_info.return_subsys_loop_flg then do;
1024 rtq_info.return_subsys_loop_flg = "0"b;
1025 revert cleanup;
1026 call ssu_$abort_line (sci_ptr);
1027 end;
1028
1029 if ^rtq_info.eof then do;
1030
1031 if rtq_info.c_rec = 2 then
1032 call ioa_ ("Physical tape file # ^d.", rtq_info.c_file);
1033
1034 if ^valid_label_record (long_list_flg) then do;
1035
1036 if rtq_info.c_rec = 2 then do;
1037 last_length = rtq_info.bits;
1038 nrecords = 0;
1039 logical_file_num = logical_file_num + 1;
1040
1041 if rtq_info.l_type > 1 then do;
1042 call ioa_ ("Logical tape file # ^d.^[^/ ^]", logical_file_num, ^label_flg);
1043 logical_file_flg = "1"b;
1044 end;
1045 else call ioa_ (" ");
1046 end;
1047
1048 if last_length = rtq_info.bits then
1049 nrecords = nrecords + 1;
1050 else do;
1051 if nrecords = 0 then nrecords = 1;
1052
1053 if ^label_flg then call record_information (nrecords, (last_length), "1"b);
1054
1055 last_length = rtq_info.bits;
1056 nrecords = 0;
1057 end;
1058 end;
1059
1060 else last_length = 0;
1061 end;
1062 else do;
1063 if last_length > 0 & ^rtq_info.two_eofs then do;
1064 if nrecords = 0 then nrecords = 1;
1065
1066 if ^label_flg then call record_information (nrecords, (last_length), "1"b);
1067 end;
1068
1069 call ioa_ ("End of physical tape file # ^d, ^[(^a # ^d),^[^/ ^; ^]^;^3s^]^a: ^d.^/ ",
1070 rtq_info.c_file - 1, logical_file_flg, "logical tape file", logical_file_num,
1071 rtq_info.short_output_flg, "total records read", rtq_info.c_rec - 1);
1072
1073 logical_file_flg = "0"b;
1074 rtq_info.c_rec = 1;
1075
1076 if rtq_info.set_bin & ^label_flg then do;
1077 call check_mode (BINARY_MODE);
1078 call ioa_ (" ");
1079 rtq_info.set_bin = "0"b;
1080 end;
1081 else if rtq_info.set_nine & ^label_flg then do;
1082 call check_mode (NINE_MODE);
1083 call ioa_ (" ");
1084 rtq_info.set_nine = "0"b;
1085 end;
1086 end;
1087 end;
1088
1089
1090 call process_control_order ("rewind", "0"b, "0"b, "0"b, 1);
1091
1092
1093 call ioa_ ("Logical end of tape, positioning to BOT");
1094
1095 SUBSYSTEM_REQUEST_LOOP:
1096
1097 return;
1098
1099
1100 %page;
1101
1102 mode_request: entry (sci_ptr, rtq_info_ptr);
1103
1104
1105
1106 Note
1107
1108
1109 dcl mode_dex fixed bin;
1110
1111
1112 on cleanup call detach_tape_file (sci_ptr, rtq_info_ptr);
1113
1114 on program_interrupt goto WANTS_TO_RETURN;
1115
1116
1117 scode = 0;
1118 l_cnt = 1;
1119 rpt, rf, direction = "0"b;
1120
1121
1122 call ssu_$arg_count (sci_ptr, Nargs);
1123 if Nargs >= 2 then do;
1124 ERROR_MODE:
1125 call ssu_$print_message (sci_ptr, 0, "Usage: mode <bcd | bin | nine>");
1126 return;
1127 end;
1128
1129
1130 if Nargs = 0 then do;
1131 order = "binary";
1132 rtq_info.c_mode = 1;
1133 end;
1134 else ;
1135
1136 do arg_dex = 1 to Nargs;
1137 call ssu_$arg_ptr (sci_ptr, arg_dex, ap, al);
1138 if arg = "bcd" | arg = "bin" | arg = "nine" then do;
1139 do mode_dex = 1 to 3;
1140 if substr (arg, 1, 3) = substr (mode (mode_dex), 1, 3) then
1141 rtq_info.c_mode = mode_dex;
1142 else ;
1143 end;
1144 order = mode (rtq_info.c_mode);
1145 end;
1146 else goto ERROR_MODE;
1147 end;
1148
1149
1150 call process_control_order (order, rpt, direction, rf, l_cnt);
1151
1152 WANTS_TO_RETURN:
1153
1154 return;
1155
1156
1157 %page;
1158 position_request: entry (sci_ptr, rtq_info_ptr);
1159
1160
1161
1162
1163
1164 on cleanup call detach_tape_file (sci_ptr, rtq_info_ptr);
1165
1166 on program_interrupt goto SUBSYS_QUERY;
1167
1168
1169 call ssu_$arg_count (sci_ptr, Nargs);
1170 if Nargs ^= 0 then do;
1171 call ssu_$print_message (sci_ptr, 0, "No argument is allowed for this request.");
1172 return;
1173 end;
1174
1175
1176 call ssu_$print_message (sci_ptr, 0,
1177 "Reading tape volume ""^a"" in ""^a"" mode.^/Currently positioned to physical file ^d, record ^d.",
1178 rtq_info.tape_name, mode (rtq_info.c_mode), rtq_info.c_file, rtq_info.c_rec);
1179
1180 SUBSYS_QUERY:
1181
1182 return;
1183
1184
1185 %page;
1186
1187 quit_request: entry (sci_ptr, rtq_info_ptr);
1188
1189
1190
1191 call ssu_$abort_subsystem (sci_ptr, 0);
1192
1193 return;
1194
1195
1196 %page;
1197 read_file_request: entry (sci_ptr, rtq_info_ptr);
1198
1199
1200
1201
1202
1203
1204
1205 Note
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218 dcl conversion_flg bit (1) aligned;
1219
1220
1221 conversion_flg, first_record_flg, last_record_flg = "0"b;
1222
1223
1224 on cleanup call detach_tape_file (sci_ptr, rtq_info_ptr);
1225
1226 on program_interrupt goto RETURN;
1227
1228 rtq_info.return_subsys_loop_flg = "0"b;
1229
1230
1231
1232 rtq_info.eov, rtq_info.one_eof, rtq_info.two_eofs = "0"b;
1233
1234 rtq_info.atd_sw, rtq_info.extend_sw, rtq_info.fw_file, rtq_info.last_job_deck_flg, rtq_info.set_bin = "0"b;
1235 rtq_info.filename = "";
1236
1237
1238 call ssu_$arg_count (sci_ptr, Nargs);
1239
1240
1241 scode = 0;
1242 iterations = 1;
1243 s_filename = "";
1244 prptr, lrp = rtq_info.tptr;
1245 n_ops, schar = 0;
1246 cont, trunc_sw, cp5, ibmv, ansid, dec_sw, gssf, mssf, nnl_sw, l_rec, c_e_a, c_b_a, c_c_a, imcv = "0"b;
1247
1248
1249 call detach_file_if_attached;
1250
1251
1252 call read_file_get_control_args;
1253 if scode ^= 0 | rtq_info.return_subsys_loop_flg then
1254 goto SUBSYSTEM_LOOP_RETURN;
1255
1256
1257 if (n_ops > 1) & ^(l_rec & (c_e_a | c_b_a | c_c_a)) then do;
1258 call ssu_$print_message (sci_ptr, 0, "Inconsistent combination of optional control arguments.");
1259 return;
1260 end;
1261
1262
1263 if rtq_info.c_rec > 1 then
1264 call process_control_order ("begin_file", "1"b, "0"b, "1"b, 1);
1265
1266
1267 do nunits = 1 to iterations while (^rtq_info.two_eofs);
1268
1269 call ioa_ ("Reading tape file # ^d in ^a mode", rtq_info.c_file, mode (rtq_info.c_mode));
1270
1271 open_mode = Stream_output;
1272
1273 if (rtq_info.atd_sw & rtq_info.fw_file) | (rtq_info.atd_sw & nunits = 1) then do;
1274 call get_output_descript_and_attach;
1275
1276 if rtq_info.return_subsys_loop_flg then
1277 goto SUBSYSTEM_LOOP_RETURN;
1278 end;
1279
1280
1281 call read_in_the_entire_file;
1282
1283 if conversion_flg then return;
1284
1285 if rtq_info.return_subsys_loop_flg then do;
1286
1287 SUBSYSTEM_LOOP_RETURN:
1288 rtq_info.return_subsys_loop_flg = "0"b;
1289 return;
1290 end;
1291
1292
1293 if rtq_info.fw_file & ^rtq_info.extend_sw then do;
1294
1295 if s_filename = "" then
1296 s_filename = rtq_info.filename;
1297
1298 rtq_info.filename = rtrim (s_filename) || "." || ltrim (char (nunits + 1));
1299
1300 if ^valid_pathname ((rtq_info.filename), "") then do;
1301 call ssu_$print_message (sci_ptr, scode,
1302 "^/ Expanding pathname for file name ""^a""", rtq_info.filename);
1303 return;
1304 end;
1305
1306 rtq_info.fw_file = "0"b;
1307 end;
1308
1309 end;
1310
1311
1312 if rtq_info.extend_sw then
1313 call detach_file_if_attached;
1314
1315 RETURN:
1316 return;
1317
1318
1319 %page;
1320 read_record_request: entry (sci_ptr, rtq_info_ptr);
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334 on cleanup call detach_tape_file (sci_ptr, rtq_info_ptr);
1335
1336 on program_interrupt goto SUBSYS_REQUEST_LOOP;
1337
1338 rtq_info.return_subsys_loop_flg = "0"b;
1339
1340
1341
1342 rtq_info.eov, rtq_info.one_eof, rtq_info.two_eofs = "0"b;
1343
1344
1345 scode = 0;
1346 mssf = "0"b;
1347 iterations = 1;
1348
1349
1350 call ssu_$arg_count (sci_ptr, Nargs);
1351
1352
1353 do arg_dex = 1 to Nargs;
1354 call ssu_$arg_ptr (sci_ptr, arg_dex, ap, al);
1355 if arg = "-count" | arg = "-ct" then do;
1356 if arg_dex < Nargs then do;
1357 arg_dex = arg_dex + 1;
1358 call ssu_$arg_ptr (sci_ptr, arg_dex, ap, al);
1359 iterations = cv_dec_check_ (arg, scode);
1360 if scode ^= 0 then goto ERROR_RDREC;
1361 end;
1362 else goto ERROR_RDREC;
1363 end;
1364 else do;
1365 ERROR_RDREC:
1366 call ssu_$print_message (sci_ptr, scode, "^/ Usage: read_record (rdrec) {-count (-ct) N}");
1367 return;
1368 end;
1369
1370 end;
1371
1372 do nunits = 1 to iterations while (^rtq_info.two_eofs);
1373
1374 call ssu_$print_message (sci_ptr, 0, "Reading record ^d, File ^d in ^a mode", rtq_info.c_rec,
1375 rtq_info.c_file, mode (rtq_info.c_mode));
1376
1377 call read_tape_record ("stop", rtq_info.eof, "0"b, mssf);
1378
1379 if rtq_info.return_subsys_loop_flg then do;
1380 rtq_info.return_subsys_loop_flg = "0"b;
1381 return;
1382 end;
1383
1384 if ^rtq_info.eof then
1385 call record_information (1, rtq_info.bits, "0"b);
1386 end;
1387
1388 SUBSYS_REQUEST_LOOP:
1389 return;
1390
1391
1392 %page;
1393 records_in_file_request: entry (sci_ptr, rtq_info_ptr);
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405 dcl end_file_flg bit (1) aligned;
1406 dcl numb_of_recs_to_be_backspaced fixed bin;
1407 dcl save_current_record fixed bin;
1408 dcl save_current_file fixed bin;
1409
1410
1411 on cleanup call detach_tape_file (sci_ptr, rtq_info_ptr);
1412
1413 on program_interrupt goto RETURNED;
1414
1415 call ssu_$arg_count (sci_ptr, Nargs);
1416 if Nargs ^= 0 then do;
1417 call ssu_$print_message (sci_ptr, 0, "Usage: records_in_file, rif");
1418 return;
1419 end;
1420
1421
1422 rtq_info.eov, rtq_info.two_eofs, rtq_info.one_eof = "0"b;
1423 scode = 0;
1424 rtq_info.records_in_file_flg = "1"b;
1425 rtq_info.return_subsys_loop_flg = "0"b;
1426 save_current_record = rtq_info.c_rec;
1427 save_current_file = rtq_info.c_file;
1428 end_file_flg = "0"b;
1429 mssf = "0"b;
1430
1431
1432 do while (^end_file_flg);
1433 call read_tape_record ("skip", end_file_flg, "1"b, mssf);
1434 end;
1435
1436
1437 call ioa_ ("The current file # ^d contains ^d record^[s^]." ||
1438 "^/Repositioned the tape to its original position: record # ^d, file # ^d.", save_current_file,
1439 rtq_info.c_rec - 1, (rtq_info.c_rec > 1), save_current_record, save_current_file);
1440
1441 rtq_info.c_file = rtq_info.c_file - 1;
1442
1443
1444 order = "backspace_record";
1445 rpt = "1"b;
1446 direction = "0"b;
1447 rf = "0"b;
1448 numb_of_recs_to_be_backspaced = rtq_info.c_rec - save_current_record;
1449
1450
1451 if numb_of_recs_to_be_backspaced = 0 then
1452 call iox_$control (rtq_info.tiocb_ptr, order, null, (0));
1453
1454
1455 else call process_control_order (order, rpt, direction, rf, (numb_of_recs_to_be_backspaced));
1456
1457 rtq_info.one_eof = "0"b;
1458
1459 rtq_info.records_in_file_flg = "0"b;
1460
1461 RETURNED:
1462 return;
1463
1464
1465 %page;
1466 rewind_request: entry (sci_ptr, rtq_info_ptr);
1467
1468
1469
1470
1471
1472
1473
1474 on cleanup call detach_tape_file (sci_ptr, rtq_info_ptr);
1475
1476 on program_interrupt goto PI_RETURN;
1477
1478 call ssu_$arg_count (sci_ptr, Nargs);
1479 if Nargs ^= 0 then do;
1480 call ssu_$print_message (sci_ptr, 0, "Usage: rewind (rew)");
1481 return;
1482 end;
1483
1484
1485 scode = 0;
1486 l_cnt = 1;
1487 rpt, rf, direction = "0"b;
1488 order = "rewind";
1489
1490 call process_control_order (order, rpt, direction, rf, l_cnt);
1491
1492
1493 rtq_info.eof, rtq_info.eov, rtq_info.one_eof, rtq_info.two_eofs = "0"b;
1494
1495 PI_RETURN:
1496 return;
1497
1498
1499 %page;
1500 ANSI_DB_records: proc (conversion_flg);
1501
1502
1503
1504 dcl conversion_flg bit (*) aligned;
1505
1506
1507 nchars = 0;
1508 rtq_info.rptr = rtq_info.tptr;
1509
1510 on conversion begin;
1511 call ssu_$print_message (sci_ptr, 0,
1512 "Conversion condition detected attempting to convert ANSI log rec len (""^a"") to binary",
1513 ansi_db_lrec.lrl);
1514
1515 conversion_flg = "1"b;
1516 goto BACK_TO_RTQ_REQUEST_LOOP;
1517 end;
1518
1519 do while (nchars < rtq_info.rec_len - 3);
1520 l_rec_len = bin (ansi_db_lrec.lrl) - NUMB_OF_CHARS_PER_WORD;
1521
1522 if l_rec_len = 0 then do;
1523 call write_file (addr (NL), 1, s_filename);
1524
1525 if rtq_info.return_subsys_loop_flg then return;
1526 end;
1527 else do;
1528 if c_e_a then
1529 call ebcdic_to_ascii_ (ansi_db_lrec.alrd, rtq_info.cbufp -> cbuf);
1530 else rtq_info.cbufp -> cbuf = ansi_db_lrec.alrd;
1531
1532 trim_trailing_blanks_log_rec_len = length (rtrim (rtq_info.cbufp -> cbuf));
1533
1534 if ^nnl_sw then do;
1535 trim_trailing_blanks_log_rec_len = trim_trailing_blanks_log_rec_len + 1;
1536 substr (rtq_info.cbufp -> cbuf, trim_trailing_blanks_log_rec_len, 1) = NL;
1537 end;
1538
1539 call write_file (rtq_info.cbufp, trim_trailing_blanks_log_rec_len, s_filename);
1540
1541 if rtq_info.return_subsys_loop_flg then return;
1542 end;
1543
1544 rtq_info.rptr = addr (ansi_db_lrec.nxt_lrec);
1545 nchars = nchars + l_rec_len + NUMB_OF_CHARS_PER_WORD;
1546
1547 end;
1548
1549 BACK_TO_RTQ_REQUEST_LOOP:
1550 return;
1551
1552 end ANSI_DB_records;
1553
1554
1555 %page;
1556 CP5_variable_length_records: proc ();
1557
1558
1559
1560
1561
1562 rtq_info.rptr = addr (cp5_phy_rec.first);
1563
1564 do i = 1 to cp5_phy_rec.nky;
1565 call ebcdic_to_ascii_ (cp5_log_rec.cp5_log_rec_data, rtq_info.cbufp -> cbuf);
1566
1567 substr (rtq_info.cbufp -> cbuf, cp5_log_rec.rlen + 1, 1) = NL;
1568
1569 call write_file (rtq_info.cbufp, cp5_log_rec.rlen + 1, s_filename);
1570
1571 if rtq_info.return_subsys_loop_flg then
1572 return;
1573
1574 rtq_info.rptr = addrel (rtq_info.rptr, currentsize (cp5_log_rec));
1575 end;
1576
1577 return;
1578
1579 end CP5_variable_length_records;
1580
1581
1582 %page;
1583 DEC_tape_records: proc ();
1584
1585
1586
1587
1588 dcl DEC_40_bits_per_word fixed bin static options (constant) init (40);
1589
1590
1591 it_cnt = divide (rtq_info.bits, DEC_40_bits_per_word, 17, 0);
1592
1593 do i = 1 to it_cnt;
1594 dec_mult (i).first_32 = dec_tape_raw.ps_wd (i).first_32;
1595
1596 dec_mult (i).last_4 = dec_tape_raw.ps_wd (i).last_4;
1597 end;
1598
1599 call write_file (lrp, it_cnt * 4, s_filename);
1600
1601 return;
1602
1603 end DEC_tape_records;
1604
1605
1606 %page;
1607 IBM_VB_records: proc ();
1608
1609
1610
1611
1612
1613 nchars = 0;
1614 blocksize = bin (bdw.msl || bdw.lsl) - NUMB_OF_CHARS_PER_WORD;
1615 rtq_info.rptr = addr (ibm_phy_rec.iprd);
1616
1617 do while (nchars < blocksize);
1618 l_rec_len = bin (rdw.msl || rdw.lsl) - NUMB_OF_CHARS_PER_WORD;
1619
1620 if c_e_a then
1621 call ebcdic_to_ascii_ (ibm_log_rec.ilrd, rtq_info.cbufp -> cbuf);
1622 else rtq_info.cbufp -> cbuf = ibm_log_rec.ilrd;
1623
1624 trim_trailing_blanks_log_rec_len = length (rtrim (substr (rtq_info.cbufp -> cbuf, 1, rtq_info.rec_len)));
1625
1626 if ^nnl_sw then do;
1627 trim_trailing_blanks_log_rec_len = trim_trailing_blanks_log_rec_len + 1;
1628 substr (rtq_info.cbufp -> cbuf, trim_trailing_blanks_log_rec_len, 1) = NL;
1629 end;
1630
1631 call write_file (rtq_info.cbufp, trim_trailing_blanks_log_rec_len, s_filename);
1632
1633 if rtq_info.return_subsys_loop_flg then
1634 return;
1635
1636 rtq_info.rptr = addr (ibm_log_rec.nxt_lrec);
1637 nchars = nchars + l_rec_len + NUMB_OF_CHARS_PER_WORD;
1638 end;
1639
1640 return;
1641
1642 end IBM_VB_records;
1643
1644
1645 %page;
1646 GCOS_ssf: proc (cont, imcv, nchars, binck, first_record_flg, s_filename);
1647
1648
1649
1650 dcl binck bit (1) aligned;
1651 dcl card_cnt fixed bin;
1652 dcl cont bit (1) aligned;
1653 dcl dkend_card bit (1) aligned;
1654 dcl eoc bit (1) aligned;
1655 dcl (fc, fl) bit (1) aligned;
1656 dcl first_record_flg bit (1) aligned;
1657 dcl gcos_trans (9) char (6) static options (constant) init
1658 ("gmap ", "355map", "355sim", "algol ", "forta ", "forty ", "cobol ", "cob68 ", "jovial");
1659 dcl imcv bit (1) aligned;
1660 dcl nchars fixed bin (21);
1661 dcl obj_card bit (1) aligned;
1662 dcl p_arg char (168) varying init ("");
1663 dcl s_filename char (32) var;
1664
1665
1666 dcl 1 comdk aligned based (rtq_info.cdptr),
1667 ( 2 type bit (12),
1668 2 bin_seq bit (24),
1669 2 ckeck_sum bit (36),
1670 2 data bit (21 * 36),
1671 2 h_seq (4) bit (12),
1672 2 pad bit (12)) unaligned;
1673
1674 dcl 1 com_fld unaligned based (rtq_info.cfptr),
1675 2 f_len bit (6),
1676 2 s_len bit (6),
1677 2 bcd_str bit (fixed (com_fld.s_len, 6) * 6),
1678 2 nxt bit (6),
1679 2 nxt_fld bit (6);
1680
1681
1682 if ^first_record_flg then do;
1683 bcnt = gc_phy_rec.bcw.bsn;
1684 first_record_flg = "1"b;
1685 end;
1686 else do;
1687 bcnt = bcnt + 1;
1688 if gc_phy_rec.bcw.bsn ^= bcnt then do;
1689 call ssu_$print_message (sci_ptr, 0,
1690 "Block serial number error; BSN was ^d, S/B ^d", gc_phy_rec.bcw.bsn, bcnt);
1691
1692 YES_FLG = command_query_yes_no ("Do you want to stop and return to the rtq request loop? Answer ""yes"" or ""no"".", "Stop?");
1693
1694 if YES_FLG then do;
1695 call detach_file_if_attached;
1696
1697 rtq_info.return_subsys_loop_flg = "1"b;
1698
1699 return;
1700 end;
1701 else bcnt = gc_phy_rec.bcw.bsn;
1702 end;
1703 end;
1704
1705 if gc_phy_rec.bcw.blk_size > rtq_info.wd_buf_size then do;
1706 call ssu_$print_message (sci_ptr, 0, "Phyical record size (^d) is larger than buffer size (^d)",
1707 gc_phy_rec.bcw.blk_size, rtq_info.wd_buf_size);
1708
1709 YES_FLG = command_query_yes_no ("Do you want to stop and return to the rtq request loop? Answer ""yes"" or ""no"".", "Stop?");
1710
1711 if YES_FLG then do;
1712 call detach_file_if_attached;
1713
1714 rtq_info.return_subsys_loop_flg = "1"b;
1715
1716 return;
1717 end;
1718 end;
1719
1720 lrptr = addr (gc_phy_rec.gc_phy_rec_data (1));
1721 nwds = 0;
1722 card_cnt = 1;
1723 obj_card, dkend_card = "0"b;
1724
1725 do while (nwds < gc_phy_rec.bcw.blk_size);
1726 if ^cont then rtq_info.cbufp -> cbuf = "";
1727 go to media_type (rcw.media_code);
1728 %page;
1729
1730
1731 media_type (1):
1732 rtq_info.cdptr = addr (gc_log_rec.gc_log_rec_data);
1733 if comdk.type = "5005"b3 then do;
1734 rtq_info.cfptr = addr (comdk.data);
1735 fc = "0"b;
1736
1737 do while (^fc);
1738 if ^cont then do;
1739 nchars = 1;
1740 rtq_info.cbufp -> cbuf = "";
1741 end;
1742
1743 fl = "0"b;
1744 do while (^fl & ^fc);
1745 i = fixed (f_len, 6);
1746 j = fixed (s_len, 6);
1747
1748 if f_len = "77"b3 then do;
1749 cont = "0"b;
1750 fl = "1"b;
1751 rtq_info.cfptr = addr (com_fld.s_len);
1752 end;
1753
1754 else if i < j | (i = 0 & j = 0) then do;
1755 eoc, fc = "1"b;
1756 cont = "0"b;
1757 end;
1758
1759 else do;
1760 eoc = "0"b;
1761 if j ^= 0 then do;
1762 rtq_info.cdkp -> cdkbuf = "";
1763 call bcd_to_ascii_ (bcd_str, rtq_info.cdkp -> cdkbuf);
1764 substr (rtq_info.cbufp -> cbuf, nchars + (i - j), j) = rtq_info.cdkp -> cdkbuf;
1765 end;
1766
1767 nchars = nchars + i;
1768
1769 if com_fld.nxt = "76"b3 then do;
1770 fc = "1"b;
1771 cont = "0"b;
1772 end;
1773
1774 else if com_fld.nxt = "77"b3 then do;
1775 fl = "1"b;
1776 cont = "0"b;
1777 rtq_info.cfptr = addr (com_fld.nxt_fld);
1778 end;
1779
1780 else if com_fld.nxt = "00"b3 then
1781 cont, fc = "1"b;
1782
1783 else rtq_info.cfptr = addr (com_fld.nxt);
1784 end;
1785 end;
1786
1787 if ^cont & ^eoc then do;
1788 substr (rtq_info.cbufp -> cbuf, nchars, 1) = NL;
1789 call write_file (rtq_info.cbufp, nchars, s_filename);
1790 end;
1791 end;
1792 end;
1793 else do;
1794
1795 ck_obj:
1796 if obj_card then do;
1797 obj_card = "0"b;
1798 if card_cnt ^= 2 then do;
1799 call ssu_$print_message (sci_ptr, 0, "$ object card not first card of blk");
1800 rtq_info.return_subsys_loop_flg = "1"b;
1801 return;
1802 end;
1803
1804
1805 nchars = (rtq_info.cvp -> rcw.rsize + rcw.rsize + 3) * NUMB_OF_CHARS_PER_WORD;
1806 rtq_info.cvp = addrel (rtq_info.cvp, -1);
1807 end;
1808
1809 else if card_cnt = 1 then do;
1810 nchars = (rcw.rsize + 2) * NUMB_OF_CHARS_PER_WORD;
1811 rtq_info.cvp = addrel (lrptr, -1);
1812 end;
1813
1814 else do;
1815 nchars = (rcw.rsize + 1) * NUMB_OF_CHARS_PER_WORD;
1816 rtq_info.cvp = lrptr;
1817 end;
1818
1819 call write_file (rtq_info.cvp, nchars, s_filename);
1820
1821 if dkend_card then do;
1822 dkend_card = "0"b;
1823
1824 call detach_file_if_attached;
1825 end;
1826 end;
1827
1828 go to gssf_end;
1829 %page;
1830
1831
1832 media_type (0):
1833 media_type (2):
1834 media_type (3):
1835 media_type (9):
1836
1837 call bcd_to_ascii_ (gc_log_rec_bits, rtq_info.cbufp -> cbuf);
1838 rtq_info.cbufp -> cbuf = translate (rtq_info.cbufp -> cbuf, "='+)(", "#@&]%"); /* take care of stange conversion chars */
1839 if rcw.media_code = 2 then do;
1840 nchars = length (rtrim (substr (rtq_info.cbufp -> cbuf, 1, 80))) + 1;
1841 if substr (rtq_info.cbufp -> cbuf, 1, 13) = "$ object" then do;
1842 obj_card = "1"b;
1843 rtq_info.cvp = addrel (lrptr, currentsize (gc_log_rec));
1844 if rtq_info.cvp -> rcw.media_code = 1 then do;
1845 binck = "1"b;
1846 call detach_file_if_attached;
1847
1848 call get_file_name ("obj", nchars);
1849 if rtq_info.return_subsys_loop_flg then
1850 return;
1851
1852 go to gssf_end;
1853 end;
1854 end;
1855
1856 else if substr (rtq_info.cbufp -> cbuf, 1, 12) = "$ dkend" then
1857 if binck then do;
1858 if substr (rtq_info.cbufp -> cbuf, 16, 8) ^= "continue" then
1859 dkend_card = "1"b;
1860 go to ck_obj;
1861 end;
1862 else ;
1863
1864 else if substr (rtq_info.cbufp -> cbuf, 1, 12) = "$ snumb" then do;
1865 i = search (substr (rtq_info.cbufp -> cbuf, 16, 6), ",");
1866 if i = 0 then
1867 p_arg = substr (rtq_info.cbufp -> cbuf, 16, 6);
1868 else p_arg = substr (rtq_info.cbufp -> cbuf, 16, i - 1);
1869
1870 if ^valid_pathname ((p_arg), "imcv") then do;
1871 rtq_info.return_subsys_loop_flg = "1"b;
1872 return;
1873 end;
1874
1875 call detach_file_if_attached;
1876
1877 imcv = "1"b;
1878 rtq_info.fw_file, cont = "0"b;
1879 end;
1880
1881 else if ^imcv then do;
1882 rtq_info.tmr = "0"b;
1883 do i = 1 to hbound (gcos_trans, 1) while (^rtq_info.tmr);
1884 if substr (rtq_info.cbufp -> cbuf, 8, 6) = gcos_trans (i) then rtq_info.tmr = "1"b;
1885 end;
1886 if rtq_info.tmr then do;
1887 if rtq_info.f_attached then do;
1888 call write_file (addr (eoj_card), length (eoj_card), s_filename);
1889
1890 if rtq_info.return_subsys_loop_flg then
1891 return;
1892
1893 call detach_file_if_attached;
1894 end;
1895
1896 call get_file_name ("ascii", nchars);
1897
1898 if rtq_info.return_subsys_loop_flg then
1899 return;
1900
1901 rtq_info.last_job_deck_flg = "1"b;
1902 call ioa_$rsnnl ("$ snumb ^a^/$ ident^/^a^/$ limits 8,64k,,50000^/",
1903 rtq_info.cbufp -> cbuf, rtq_info.clen, substr (rtq_info.filename, 1, 3),
1904 substr (rtq_info.cbufp -> cbuf, 1, nchars));
1905
1906 call write_file (rtq_info.cbufp, rtq_info.clen, s_filename);
1907
1908 cont = "0"b;
1909
1910 if rtq_info.return_subsys_loop_flg then
1911 return;
1912
1913 go to gssf_end;
1914 end;
1915 end;
1916 end;
1917
1918 else if rcw.media_code = 9 then do;
1919 rtq_info.cbufp -> cbuf = substr (rtq_info.cbufp -> cbuf, 3);
1920 nchars = length (rtrim (substr (rtq_info.cbufp -> cbuf, 1, rcw.rsize * 6))) - 2;
1921 end;
1922
1923 else nchars = length (rtrim (substr (rtq_info.cbufp -> cbuf, 1, rcw.rsize * 6))) + 1;
1924
1925 substr (rtq_info.cbufp -> cbuf, nchars, 1) = NL;
1926
1927 call write_file (rtq_info.cbufp, nchars, s_filename);
1928
1929 if rtq_info.return_subsys_loop_flg then
1930 return;
1931
1932 go to gssf_end;
1933 %page;
1934
1935
1936 media_type (6):
1937 media_type (7):
1938 media_type (10):
1939 media_type (13):
1940
1941 rtq_info.cvp = addr (gc_log_rec.gc_log_rec_data);
1942 if rcw.nchar_used ^= 0 then
1943 nchars = ((rcw.rsize - 1) * NUMB_OF_CHARS_PER_WORD) + rcw.nchar_used + 1;
1944 else nchars = rcw.rsize * NUMB_OF_CHARS_PER_WORD + 1;
1945
1946 rtq_info.cbufp -> cbuf = substr (gssf_ascii, 1, nchars - 1) || NL;
1947 if rcw.media_code = 13 then do;
1948 rtq_info.cbufp -> cbuf = substr (rtq_info.cbufp -> cbuf, 3);
1949 nchars = nchars - 2;
1950 end;
1951
1952 call write_file (rtq_info.cbufp, nchars, s_filename);
1953
1954 if rtq_info.return_subsys_loop_flg then
1955 return;
1956
1957 go to gssf_end;
1958
1959
1960
1961
1962 media_type (4):
1963 media_type (5):
1964 media_type (11):
1965 media_type (12):
1966 media_type (14):
1967 media_type (15):
1968
1969 call ssu_$print_message (sci_ptr, 0, "Illegal media code ^o detected in card number ^d of block ^d",
1970 rcw.media_code, card_cnt, bcnt);
1971 rtq_info.return_subsys_loop_flg = "1"b;
1972 return;
1973
1974
1975 media_type (8):
1976
1977 gssf_end:
1978 nwds = nwds + rcw.rsize + 1;
1979 rtq_info.cvp = lrptr;
1980 lrptr = addrel (lrptr, currentsize (gc_log_rec));
1981 card_cnt = card_cnt + 1;
1982
1983 end;
1984
1985 end GCOS_ssf;
1986
1987
1988 %page;
1989 MULT_ssf: proc (first_record_flg, last_record_flg, s_filename);
1990
1991
1992
1993 dcl first_record_flg bit (1) aligned;
1994 dcl last_record_flg bit (1) aligned;
1995 dcl s_filename char (32) varying;
1996
1997 dcl 1 mult_buf based (rtq_info.tptr) aligned,
1998 2 cur_rec (1040) bit (36),
1999 2 last_rec char (rtq_info.clen);
2000
2001
2002 mstrp = rtq_info.tptr;
2003
2004 if ^first_record_flg then do;
2005 first_record_flg = "1"b;
2006 bcnt = mstr.head.rec_within_file;
2007 end;
2008
2009 else if ^mstr.head.flags.repeat then do;
2010 bcnt = bcnt + 1;
2011 if bcnt ^= mstr.head.rec_within_file & ^last_record_flg then do;
2012 call ssu_$print_message (sci_ptr, 0,
2013 "Record sequence number error; Record sequence number was ^d; S/B ^d",
2014 mstr.head.rec_within_file, bcnt);
2015
2016 YES_FLG = command_query_yes_no ("Do you want to stop and return to the rtq request loop? Answer ""yes"" or ""no"".", "Stop?");
2017
2018 if YES_FLG then do;
2019 call detach_file_if_attached;
2020
2021 rtq_info.return_subsys_loop_flg = "1"b;
2022
2023 return;
2024 end;
2025 else bcnt = mstr.head.rec_within_file;
2026 end;
2027
2028 call write_file (addr (mult_buf.last_rec), rtq_info.clen, s_filename);
2029
2030 if rtq_info.return_subsys_loop_flg then return;
2031
2032 end;
2033
2034 if ^last_record_flg then do;
2035 rtq_info.clen = divide (mstr.head.data_bits_used, 9, 17, 0);
2036 addr (mult_buf.last_rec) -> mult_move = addr (mstr.data) -> mult_move;
2037 end;
2038
2039 end MULT_ssf;
2040
2041
2042 %page;
2043 attach_and_open_output_file: proc;
2044
2045
2046 RETRY:
2047 call iox_$attach_name ("file_sw", rtq_info.fiocb_ptr, att_desc, null, scode);
2048 if scode ^= 0 then do;
2049
2050 if scode = error_table_$not_detached then do;
2051 call iox_$detach_iocb (rtq_info.fiocb_ptr, scode);
2052 if scode ^= error_table_$not_closed then
2053 goto ERR_ATTACHED;
2054 else do;
2055 call iox_$close (rtq_info.fiocb_ptr, scode);
2056 goto RETRY;
2057 end;
2058 end;
2059 else do;
2060
2061 ERR_ATTACHED:
2062 call ssu_$print_message (sci_ptr, scode,
2063 "^/ Attempting to attach file.^/ Attach description: ^a", att_desc);
2064
2065 rtq_info.return_subsys_loop_flg = "1"b;
2066 return;
2067 end;
2068 end;
2069
2070 rtq_info.f_attached = "1"b;
2071
2072
2073 call iox_$open (rtq_info.fiocb_ptr, open_mode, "0"b, scode);
2074
2075 if scode ^= 0 then do;
2076 call ssu_$print_message (sci_ptr, scode,
2077 "^/ Opening ^a for ^a", att_desc, iox_modes (open_mode));
2078
2079 call detach_file_if_attached;
2080
2081 rtq_info.return_subsys_loop_flg = "1"b;
2082 return;
2083 end;
2084
2085
2086 end attach_and_open_output_file;
2087
2088
2089 %page;
2090 check_mode: proc (a_mode);
2091
2092
2093
2094 dcl a_mode fixed bin;
2095
2096
2097 if rtq_info.c_mode ^= a_mode then do;
2098 rtq_info.c_mode = a_mode;
2099
2100 call ioa_ ("Setting tape dim to read in ^a mode", mode (rtq_info.c_mode));
2101
2102 call process_control_order (mode (rtq_info.c_mode), "0"b, "0"b, "0"b, 1);
2103 end;
2104
2105 end check_mode;
2106
2107
2108 %page;
2109 command_query_no_entrypoint: proc (explain_to_users, ask_users_question) returns (char (200) varying);
2110
2111
2112 dcl ask_users_question char (*);
2113 dcl explain_to_users char (*);
2114 dcl get_users_answer char (64);
2115
2116
2117 dcl command_query_ entry options (variable);
2118
2119 %page;
2120 %include query_info;
2121 %page;
2122
2123 who_asked = ssu_$get_subsystem_and_request_name (sci_ptr);
2124
2125 unspec (query_info) = "0"b;
2126
2127 query_info.version = query_info_version_6;
2128 query_info.prompt_after_explanation = "1"b;
2129 query_info.question_iocbp, query_info.answer_iocbp = null;
2130 query_info.explanation_ptr = addr (explain_to_users);
2131 query_info.explanation_len = length (explain_to_users);
2132
2133 call command_query_ (addr (query_info), get_users_answer, (who_asked), ask_users_question);
2134
2135 return (rtrim (get_users_answer));
2136
2137 end command_query_no_entrypoint;
2138
2139
2140 %page;
2141 command_query_yes_no: proc (interpretation_string, query_string) returns (bit (1) aligned);
2142
2143
2144
2145 dcl A_YES_OR_NO_ANSWER bit (1) aligned;
2146 dcl interpretation_string char (95);
2147 dcl query_string char (28);
2148
2149
2150 dcl command_query_$yes_no entry options (variable);
2151
2152
2153 A_YES_OR_NO_ANSWER = "0"b;
2154
2155 who_asked = ssu_$get_subsystem_and_request_name (sci_ptr);
2156
2157 call command_query_$yes_no (A_YES_OR_NO_ANSWER, 0, (who_asked), interpretation_string, query_string);
2158
2159 return (A_YES_OR_NO_ANSWER);
2160
2161 end command_query_yes_no;
2162
2163
2164 %page;
2165 detach_file_if_attached: proc ();
2166
2167
2168
2169
2170 if rtq_info.f_attached then do;
2171 call iox_$close (rtq_info.fiocb_ptr, (0));
2172 call iox_$detach_iocb (rtq_info.fiocb_ptr, (0));
2173 rtq_info.last_job_deck_flg, rtq_info.f_attached = "0"b;
2174 end;
2175
2176 end detach_file_if_attached;
2177
2178
2179 %page;
2180 detach_tape_file: proc (sci_ptr, rtq_info_ptr);
2181
2182
2183
2184 dcl release_area_ entry (ptr);
2185 dcl release_temp_segment_ entry (char (*), ptr, fixed bin (35));
2186 dcl (rtq_info_ptr, sci_ptr) ptr;
2187
2188
2189 if rtq_info.tiocb_ptr ^= null then do;
2190 call iox_$close (rtq_info.tiocb_ptr, (0));
2191 call iox_$detach_iocb (rtq_info.tiocb_ptr, (0));
2192 rtq_info.tiocb_ptr = null;
2193 end;
2194
2195
2196 if rtq_info.tptr ^= null then
2197 call release_temp_segment_ (pname, rtq_info.tptr, (0));
2198
2199
2200 if rtq_info.rtq_area_ptr ^= null then do;
2201 call release_area_ (rtq_info.rtq_area_ptr);
2202 ai.areap = null;
2203 end;
2204
2205
2206 call detach_file_if_attached;
2207
2208 return;
2209
2210 end detach_tape_file;
2211
2212
2213 %page;
2214 determine_tape_label_types: proc ();
2215
2216
2217
2218
2219
2220 if rtq_info.tptr -> mult.lab_id = header_c1 then do;
2221 rcd_volid = rtq_info.tptr -> mult.tape_reel_id;
2222 rtq_info.l_type = v1_mult_label;
2223 end;
2224
2225 else if rtq_info.tptr -> mult.lab_id = label_c1 then do;
2226
2227 if (rtq_info.tptr -> mst_label.head.c1 = header_c1) & (rtq_info.tptr -> mst_label.head.label) then do;
2228 rcd_volid = rtq_info.tptr -> mst_label.tape_reel_id;
2229 rtq_info.l_type = v3_mult_label;
2230 end;
2231 end;
2232
2233 else if rtq_info.tptr -> gcos.lab_id = g_label then do;
2234 call bcd_to_ascii_ (rtq_info.tptr -> gcos.vol_id, rcd_volid);
2235 rtq_info.l_type = 3;
2236 end;
2237
2238 else if rtq_info.tptr -> ibm_ansi.lab_id = i_label then do;
2239 call ebcdic8_to_ascii_ (rtq_info.tptr -> ibm_ansi.vol_id, rcd_volid);
2240 rtq_info.l_type = ibm_label;
2241 end;
2242
2243 else if rtq_info.tptr -> ibm_ansi.lab_id = a_label then do;
2244 do i = 0 to 5;
2245 blab (i) = "0"b || substr (rtq_info.tptr -> ibm_ansi.vol_id, (i * 8) + 1, 8);
2246 end;
2247 rtq_info.l_type = ansi_label;
2248 end;
2249
2250 else if rtq_info.tptr -> cp5_lab.lab_id = CP5_label then do;
2251 call ebcdic8_to_ascii_ (rtq_info.tptr -> cp5_lab.vol_id, rcd_volid);
2252 rtq_info.l_type = cp5_label;
2253 end;
2254
2255 else do;
2256 call ioa_ ("Tape ^a is ^a or has unrecognized label.^/Tape will remain positioned at BOT.",
2257 rtq_info.tape_name, LABEL (rtq_info.l_type));
2258
2259 return;
2260 end;
2261
2262 call ioa_ ("Tape ^a is a labeled ^a tape.^/Volume name recorded on tape label is ^a.",
2263 rtq_info.tape_name, LABEL (rtq_info.l_type), rcd_volid);
2264
2265 if rtq_info.l_type = ibm_label | rtq_info.l_type = ansi_label then do;
2266 call check_mode (NINE_MODE);
2267
2268 call process_control_order ("forward_record", "1"b, "1"b, "0"b, 2);
2269
2270 call read_tape_record ("stop", rtq_info.eof, "0"b, mssf);
2271
2272 if rtq_info.return_subsys_loop_flg then
2273 return;
2274
2275 if ^rtq_info.eof then do;
2276
2277 call ioa_ ("First data file format:");
2278
2279 if ^valid_label_record ("0"b) then
2280
2281 call ssu_$print_message (sci_ptr, 0, "Could not find ^a HDR2 record.", LABEL (rtq_info.l_type));
2282 end;
2283 else do;
2284 call ssu_$print_message (sci_ptr, 0, "Error reading HDR2 record, tape will be rewound to BOT");
2285
2286 call process_control_order ("rewind", "0"b, "0"b, "0"b, 1);
2287
2288 return;
2289 end;
2290 end;
2291
2292 call ioa_ ("Positioning to beginning of physical tape file # 2, (logical file # 1)");
2293
2294 call process_control_order ("forward_file", "1"b, "1"b, "1"b, 1);
2295
2296 return;
2297
2298 end determine_tape_label_types;
2299
2300
2301 %page;
2302 get_file_name: proc (dtype, nchars);
2303
2304
2305
2306 dcl dtype char (5);
2307 dcl nchars fixed bin (21);
2308 dcl output_filename char (168) aligned;
2309
2310
2311 if nchars >= 73 then
2312 if substr (rtq_info.cbufp -> cbuf, 73, 4) ^= "" |
2313 substr (rtq_info.cbufp -> cbuf, 73, 4) ^= "0000" then do;
2314 rtq_info.filename = rtrim (substr (rtq_info.cbufp -> cbuf, 73, 4));
2315 i = index (rtq_info.filename, NL);
2316 if i ^= 0 then
2317 substr (rtq_info.filename, i) = substr (rtq_info.filename, i + 1);
2318 end;
2319 else ;
2320 else do;
2321 call ioa_ ("^a", substr (rtq_info.cbufp -> cbuf, 1, 80));
2322
2323 rtq_info.tmr = "0"b;
2324 output_filename = "";
2325 do while (^rtq_info.tmr);
2326 output_filename = command_query_no_entrypoint ("Please enter an output file name.", "Ouput file name: ");
2327
2328 rtq_info.tmr = valid_pathname ((output_filename), "");
2329 if ^rtq_info.tmr then
2330 goto PATHNAME_ERROR;
2331 end;
2332 end;
2333
2334 if ^valid_pathname ((rtq_info.filename), dtype) then do;
2335
2336 PATHNAME_ERROR:
2337 call ssu_$print_message (sci_ptr, scode, "Expanding pathname for file name ""^a""", rtq_info.filename);
2338 rtq_info.return_subsys_loop_flg = "1"b;
2339 return;
2340 end;
2341
2342 rtq_info.fw_file = "0"b;
2343
2344 end get_file_name;
2345
2346
2347 %page;
2348 get_output_descript_and_attach: proc ();
2349
2350
2351
2352
2353
2354 if ^rtq_info.f_attached then do;
2355
2356 attach_desc_output = command_query_no_entrypoint ("Please enter an output attach description.", "Output attach description: ");
2357
2358 att_desc = attach_desc_output;
2359
2360 attach_desc_output = command_query_no_entrypoint ("Please enter an opening mode.", "Opening mode: ");
2361
2362
2363 do i = 1 to hbound (iox_modes, 1)
2364 while (attach_desc_output ^= iox_modes (i) & attach_desc_output ^= short_iox_modes (i));
2365 end;
2366
2367 if i > hbound (iox_modes, 1) then do;
2368 call ssu_$print_message (sci_ptr, 0, "Invalid opening mode specification ""^a""", attach_desc_output);
2369
2370 rtq_info.return_subsys_loop_flg = "1"b;
2371 return;
2372 end;
2373
2374
2375 open_mode = i;
2376
2377
2378 call attach_and_open_output_file;
2379 end;
2380
2381 return;
2382
2383 end get_output_descript_and_attach;
2384
2385
2386 %page;
2387 get_tape_status: proc;
2388
2389
2390
2391 dcl analyze_device_stat_$rsnnl entry (char (*) var, ptr, bit (72) aligned, bit (18) aligned);
2392
2393
2394 status_story = "";
2395 call iox_$control (rtq_info.tiocb_ptr, "saved_status", addr (t_stat), scode);
2396
2397 call analyze_device_stat_$rsnnl (status_story, addr (tape_status_table_$tape_status_table_), (t_stat), ("0"b));
2398
2399 end get_tape_status;
2400
2401
2402 %page;
2403 process_control_order: proc (a_order, a_rpt, a_dir, a_rf, a_cnt);
2404
2405
2406
2407 dcl a_cnt fixed bin (35);
2408 dcl a_dir bit (1) aligned;
2409 dcl a_order char (*);
2410 dcl a_rf bit (1) aligned;
2411 dcl a_rpt bit (1) aligned;
2412 dcl backspace_file_flg bit (1) aligned init ("0"b);
2413 dcl count fixed bin (35);
2414 dcl i fixed bin (35);
2415 dcl order char (16);
2416
2417
2418 order = a_order;
2419 count = a_cnt;
2420 backspace_file_flg = "0"b;
2421
2422 if a_rpt then do;
2423 if ^a_dir then do;
2424 if a_rf then do;
2425 if rtq_info.c_file - count < 1 then do;
2426
2427 call ioa_ ("Tape will be positioned at BOT");
2428
2429 call process_control_order ("rewind", "0"b, "0"b, "0"b, 1);
2430 return;
2431 end;
2432 else do;
2433 rtq_info.c_rec = 1;
2434
2435 if order = "begin_file" then do;
2436 order = "backspace_file";
2437 backspace_file_flg = "1"b;
2438 end;
2439 else do;
2440
2441 rtq_info.c_file = rtq_info.c_file - count;
2442
2443 if rtq_info.c_file > 1 then
2444 backspace_file_flg = "1"b;
2445
2446 count = count + 1;
2447 end;
2448 end;
2449 end;
2450 else if rtq_info.c_rec - count < 1 then do;
2451 call ioa_ ("Tape will be positioned at beginning of file ^d", rtq_info.c_file);
2452
2453 call process_control_order ("begin_file", "1"b, "0"b, "1"b, 1);
2454 return;
2455 end;
2456 else rtq_info.c_rec = rtq_info.c_rec - count;
2457
2458 end;
2459 else do;
2460 if a_rf then do;
2461 rtq_info.c_rec = 1;
2462 rtq_info.c_file = rtq_info.c_file + count;
2463 end;
2464 else if ^rtq_info.eof_request_flg then
2465 rtq_info.c_rec = rtq_info.c_rec + count;
2466 end;
2467 end;
2468
2469 if order = "rewind" then
2470 rtq_info.c_rec, rtq_info.c_file = 1;
2471
2472 do i = 1 to count;
2473 call iox_$control (rtq_info.tiocb_ptr, order, null, scode);
2474
2475 if scode ^= 0 then do;
2476 if scode = error_table_$end_of_info & rtq_info.records_in_file_flg then do;
2477 scode = 0;
2478 i = i - 1;
2479 end;
2480
2481 if ^rtq_info.eof_request_flg & scode ^= 0 then do;
2482
2483 save_status_code = scode;
2484 call get_tape_status;
2485
2486 call ssu_$print_message (sci_ptr, save_status_code,
2487 "^/Tape status = ^4.3b.^/^[ ""^a""^;,^1s^] while executing iteration # ^d of ^a control order",
2488 t_stat, (status_story ^= ""), status_story, i, a_order);
2489 return;
2490 end;
2491 end;
2492 end;
2493
2494 if backspace_file_flg then do;
2495 call iox_$control (rtq_info.tiocb_ptr, "forward_file", null, scode);
2496 if scode ^= 0 then do;
2497 save_status_code = scode;
2498 call get_tape_status;
2499
2500 call ssu_$print_message (sci_ptr, save_status_code,
2501 "^/Tape status = ^4.3b.^/^[ ""^a""^;,^1s^] while forward spacing to beginning of file ^d",
2502 t_stat, (status_story ^= ""), status_story, rtq_info.c_file);
2503 return;
2504 end;
2505 end;
2506
2507 end process_control_order;
2508
2509
2510 %page;
2511 process_logical_record_length: proc ();
2512
2513
2514
2515
2516
2517 it_cnt = divide (rtq_info.rec_len - schar, l_rec_len, 17, 0);
2518 spill = mod (rtq_info.rec_len - schar, l_rec_len);
2519
2520 do i = 1 to it_cnt;
2521 rtq_info.cbufp -> cbuf = chcv_buf (i);
2522 temp_logical_rec_len = l_rec_len;
2523
2524 if open_mode = Stream_output | open_mode = Stream_input_output then do;
2525 substr (rtq_info.cbufp -> cbuf, l_rec_len + 1, 1) = NL;
2526 temp_logical_rec_len = temp_logical_rec_len + 1;
2527 end;
2528
2529 call write_file (rtq_info.cbufp, temp_logical_rec_len, s_filename);
2530
2531 if rtq_info.return_subsys_loop_flg then
2532 return;
2533
2534 end;
2535
2536 if spill ^= 0 then do;
2537 it_cnt = it_cnt + 1;
2538 rtq_info.cbufp -> cbuf = substr (chcv_buf (it_cnt), 1, spill);
2539
2540 if open_mode = Stream_output | open_mode = Stream_input_output then do;
2541 substr (rtq_info.cbufp -> cbuf, spill + 1, 1) = NL;
2542 spill = spill + 1;
2543 end;
2544
2545 call write_file (rtq_info.cbufp, spill, s_filename);
2546
2547 if rtq_info.return_subsys_loop_flg then
2548 return;
2549
2550 end;
2551
2552 return;
2553
2554 end process_logical_record_length;
2555
2556
2557 %page;
2558 read_file_get_control_args: proc ();
2559
2560
2561
2562 do arg_dex = 1 to Nargs;
2563 call ssu_$arg_ptr (sci_ptr, arg_dex, ap, al);
2564 if arg = "-gcos" | arg = "-gc" then do;
2565 gssf = "1"b;
2566 call check_mode (BINARY_MODE);
2567 n_ops = n_ops + 1;
2568 end;
2569
2570 else if arg = "-multics" | arg = "-mult" then do;
2571 mssf = "1"b;
2572 call check_mode (BINARY_MODE);
2573 n_ops = n_ops + 1;
2574 end;
2575
2576 else if arg = "-extend" then
2577 rtq_info.extend_sw = "1"b;
2578
2579 else if arg = "-nnl" then
2580 nnl_sw = "1"b;
2581
2582 else if arg = "-output_description" | arg = "-ods" then
2583 rtq_info.atd_sw = "1"b;
2584
2585 else if arg = "-cp5" then do;
2586 cp5 = "1"b;
2587 call check_mode (NINE_MODE);
2588 n_ops = n_ops + 1;
2589 end;
2590
2591 else if arg = "-dec" then do;
2592 lrp = rtq_info.cvbp;
2593 dec_sw = "1"b;
2594 call check_mode (BINARY_MODE);
2595 n_ops = n_ops + 1;
2596 end;
2597
2598 else if arg = "-ibm_vb" then do;
2599 ibmv = "1"b;
2600 if arg_dex < Nargs then do;
2601 call ssu_$arg_ptr (sci_ptr, arg_dex + 1, ap, al);
2602 if substr (arg, 1, 1) ^= "-" then do;
2603 arg_dex = arg_dex + 1;
2604 if arg = "binary" | arg = "bin" then
2605 rtq_info.set_bin = "1"b;
2606 else if arg = "ebcdic" then
2607 c_e_a = "1"b;
2608 else if arg ^= "ascii" then do;
2609 IBM_VB_ERROR:
2610 call ssu_$print_message (sci_ptr, 0,
2611 " Usage: read_file (rdfile) {-ibm_vb {ascii | binary (bin) | ebcdic}}");
2612 goto GET_CONTROL_ARG_ERROR;
2613 end;
2614 end;
2615 else c_e_a = "1"b;
2616 end;
2617 else if arg_dex = Nargs then
2618 c_e_a = "1"b;
2619 else goto IBM_VB_ERROR;
2620 if rtq_info.set_bin then
2621 call check_mode (BINARY_MODE);
2622 else call check_mode (NINE_MODE);
2623 n_ops = n_ops + 1;
2624 end;
2625
2626 else if arg = "-ansi_db" then do;
2627 ansid = "1"b;
2628 if arg_dex < Nargs then do;
2629 call ssu_$arg_ptr (sci_ptr, arg_dex + 1, ap, al);
2630 if substr (arg, 1, 1) ^= "-" then do;
2631 arg_dex = arg_dex + 1;
2632 if arg = "binary" | arg = "bin" then
2633 rtq_info.set_bin = "1"b;
2634 else if arg = "ebcdic" then
2635 c_e_a = "1"b;
2636 else if arg ^= "ascii" then do;
2637 ANSI_DB_ERROR:
2638 call ssu_$print_message (sci_ptr, 0,
2639 "Usage: read_file (rdfile) {-ansi_db {ascii | binary (bin) | ebcdic}}");
2640 goto GET_CONTROL_ARG_ERROR;
2641 end;
2642 end;
2643 end;
2644 else if arg_dex > Nargs then
2645 goto ANSI_DB_ERROR;
2646 else ;
2647 if rtq_info.set_bin then
2648 call check_mode (BINARY_MODE);
2649 else call check_mode (NINE_MODE);
2650 n_ops = n_ops + 1;
2651 end;
2652
2653 else if arg = "-truncate" | arg = "-tc" then do;
2654 if arg_dex < Nargs then do;
2655 call ssu_$arg_ptr (sci_ptr, arg_dex + 1, ap, al);
2656 tr_cnt = cv_dec_check_ (arg, scode);
2657 if scode ^= 0 then do;
2658 TC_ERROR:
2659 call ssu_$print_message (sci_ptr, scode,
2660 "^/ Usage: read_file (rdfile) {-truncate (-tc) N}");
2661 goto GET_CONTROL_ARG_ERROR;
2662 end;
2663 arg_dex = arg_dex + 1;
2664 trunc_sw = "1"b;
2665 end;
2666 else do;
2667 scode = 0;
2668 goto TC_ERROR;
2669 end;
2670 end;
2671
2672 else if arg = "-logical_record_length" | arg = "-lrl" then do;
2673 if arg_dex < Nargs then do;
2674 call ssu_$arg_ptr (sci_ptr, arg_dex + 1, ap, al);
2675 l_rec_len = cv_dec_check_ (arg, scode);
2676 if scode ^= 0 then do;
2677 LRL_ERROR:
2678 call ssu_$print_message (sci_ptr, scode,
2679 "^/ Usage: read_file (rdfile) {-logical_record_length (-lrl) N}");
2680 goto GET_CONTROL_ARG_ERROR;
2681 end;
2682 arg_dex = arg_dex + 1;
2683 if l_rec_len > length (rtq_info.cbufp -> cbuf) then do;
2684 call ssu_$print_message (sci_ptr, 0,
2685 "Logical record lengths > ^d characters not supported", length (rtq_info.cbufp -> cbuf));
2686 goto GET_CONTROL_ARG_ERROR;
2687 end;
2688 l_rec = "1"b;
2689 n_ops = n_ops + 1;
2690 end;
2691 else do;
2692 scode = 0;
2693 goto LRL_ERROR;
2694 end;
2695 end;
2696
2697 else if arg = "-count" | arg = "-ct" then do;
2698 if arg_dex < Nargs then do;
2699 call ssu_$arg_ptr (sci_ptr, arg_dex + 1, ap, al);
2700 iterations = cv_dec_check_ (arg, scode);
2701 if scode ^= 0 then do;
2702 CNT_ERROR:
2703 call ssu_$print_message (sci_ptr, scode,
2704 "^/ Usage: read_file (rdfile) {-count (-ct) N}");
2705 goto GET_CONTROL_ARG_ERROR;
2706 end;
2707 arg_dex = arg_dex + 1;
2708 end;
2709 else do;
2710 scode = 0;
2711 goto CNT_ERROR;
2712 end;
2713 end;
2714
2715 else if arg = "-skip" then do;
2716 if arg_dex < Nargs then do;
2717 call ssu_$arg_ptr (sci_ptr, arg_dex + 1, ap, al);
2718 schar = cv_dec_check_ (arg, scode);
2719 if scode ^= 0 then do;
2720 SKIP_ERROR:
2721 call ssu_$print_message (sci_ptr, scode,
2722 "^/ Usage: read_file (rdfile) {-skip N}");
2723 goto GET_CONTROL_ARG_ERROR;
2724 end;
2725 arg_dex = arg_dex + 1;
2726 end;
2727 else do;
2728 scode = 0;
2729 goto SKIP_ERROR;
2730 end;
2731 end;
2732
2733 else if arg = "-convert" | arg = "-conv" then do;
2734 if arg_dex < Nargs then do;
2735 call ssu_$arg_ptr (sci_ptr, arg_dex + 1, ap, al);
2736 arg_dex = arg_dex + 1;
2737 if arg = "ebcdic_to_ascii" | arg = "ebcdic" then
2738 c_e_a = "1"b;
2739 else if arg = "bcd_to_ascii" | arg = "bcd" then
2740 c_b_a = "1"b;
2741 else if arg = "comp8_to_ascii" | arg = "comp8" then do;
2742 c_c_a = "1"b;
2743 call check_mode (NINE_MODE);
2744 end;
2745 else do;
2746 CONV_ERROR:
2747 call ssu_$print_message (sci_ptr, 0,
2748 "Usage: read_file (rdfile) {-convert (-conv) ebcdic_to_ascii (ebcdic) | bcd_to_ascii (bcd) | comp8_to_ascii (comp8)}");
2749 goto GET_CONTROL_ARG_ERROR;
2750 end;
2751 end;
2752 else goto CONV_ERROR;
2753
2754 lrp = rtq_info.cvbp;
2755 n_ops = n_ops + 1;
2756 end;
2757
2758 else if arg = "-output_file" | arg = "-of" then do;
2759 if arg_dex < Nargs then do;
2760 call ssu_$arg_ptr (sci_ptr, arg_dex + 1, ap, al);
2761 if substr (arg, 1, 1) ^= "-" then do;
2762 arg_dex = arg_dex + 1;
2763
2764 if ^valid_pathname ((arg), "") then do;
2765 OF_ERROR:
2766 call ssu_$print_message (sci_ptr, scode,
2767 "^/ Usage: read_file (rdfile) {-output_file (-of) FILE_NAME}");
2768 goto GET_CONTROL_ARG_ERROR;
2769 end;
2770
2771 end;
2772 end;
2773 else do;
2774 scode = 0;
2775 goto OF_ERROR;
2776 end;
2777 end;
2778
2779 else do;
2780 call ssu_$print_message (sci_ptr, 0,
2781 "Invalid input optional control argument ""^a""", arg);
2782 goto GET_CONTROL_ARG_ERROR;
2783 end;
2784 end;
2785
2786 return;
2787
2788 GET_CONTROL_ARG_ERROR:
2789 rtq_info.return_subsys_loop_flg = "1"b;
2790 return;
2791
2792 end read_file_get_control_args;
2793
2794
2795 %page;
2796 read_in_the_entire_file: proc ();
2797
2798
2799
2800
2801
2802
2803
2804
2805
2806 rtq_info.eof, binck = "0"b;
2807 do while (^rtq_info.eof);
2808
2809 call read_tape_record ("skip", rtq_info.eof, "0"b, mssf);
2810
2811 if rtq_info.return_subsys_loop_flg then
2812 return;
2813
2814 if ^rtq_info.eof then do;
2815
2816 if valid_label_record ("0"b) then
2817 goto nxt_rcd;
2818
2819 if trunc_sw then
2820 rtq_info.rec_len = tr_cnt;
2821
2822 if gssf then
2823 call GCOS_ssf (cont, imcv, nchars, binck, first_record_flg, s_filename);
2824
2825 else if mssf then
2826 call MULT_ssf (first_record_flg, last_record_flg, s_filename);
2827
2828 else if cp5 then
2829 call CP5_variable_length_records;
2830
2831 else if dec_sw then
2832 call DEC_tape_records;
2833
2834 else if ibmv then
2835 call IBM_VB_records;
2836
2837 else if ansid then do;
2838 conversion_flg = "0"b;
2839 call ANSI_DB_records (conversion_flg);
2840 if conversion_flg then
2841 return;
2842 end;
2843
2844 else do;
2845 if c_e_a then do;
2846
2847 if rtq_info.c_mode = NINE_MODE then
2848 call ebcdic_to_ascii_ (rtq_info.tptr -> char_buf, rtq_info.cvbp -> cv_buf);
2849 else do;
2850 rtq_info.rec_len = divide (rtq_info.bits + 8 - 1, 8, 21, 0);
2851
2852 call ebcdic8_to_ascii_ (rtq_info.tptr -> bit_buf, rtq_info.cvbp -> cv_buf);
2853 end;
2854 end;
2855
2856 else if c_b_a then do;
2857 rtq_info.rec_len = divide (rtq_info.bits + 6 - 1, 6, 21, 0);
2858 call bcd_to_ascii_ (rtq_info.tptr -> bit_buf, rtq_info.cvbp -> cv_buf);
2859 end;
2860
2861 else if c_c_a then do;
2862 rtq_info.rec_len = divide (rtq_info.bits + 4 - 1, 4, 21, 0);
2863 call comp_8_to_ascii_ (rtq_info.tptr -> bit_buf, rtq_info.cvbp -> cv_buf);
2864 end;
2865
2866 if l_rec then
2867 call process_logical_record_length;
2868
2869 else if rtq_info.atd_sw | nnl_sw then
2870 call write_file (addr (conv_buf.conv_dta), rtq_info.rec_len - schar, s_filename);
2871
2872 else do;
2873 substr (conv_buf.conv_dta, rtq_info.rec_len - schar + 1, 1) = NL;
2874
2875 rtq_info.rec_len = (rtq_info.rec_len - schar) + 1;
2876
2877 call write_file (addr (conv_buf.conv_dta), rtq_info.rec_len, s_filename);
2878 end;
2879 end;
2880 end;
2881
2882 if rtq_info.return_subsys_loop_flg then
2883 return;
2884
2885 nxt_rcd:
2886 end;
2887
2888 if gssf then do;
2889 if rtq_info.last_job_deck_flg then do;
2890
2891 call write_file (addr (eoj_card), length (eoj_card), s_filename);
2892
2893 if rtq_info.return_subsys_loop_flg then
2894 return;
2895 end;
2896 end;
2897
2898 if mssf then do;
2899 last_record_flg = "1"b;
2900
2901 call MULT_ssf (first_record_flg, last_record_flg, s_filename);
2902
2903 if rtq_info.return_subsys_loop_flg then
2904 return;
2905 end;
2906
2907 if ^rtq_info.extend_sw then
2908
2909 call detach_file_if_attached;
2910
2911 end read_in_the_entire_file;
2912
2913
2914 %page;
2915 read_tape_record: proc (neg, end_file, quiet_sw, mssf);
2916
2917
2918
2919
2920
2921
2922
2923
2924
2925
2926
2927
2928
2929
2930
2931
2932
2933
2934
2935 dcl auto_retry fixed bin;
2936 dcl end_file bit (1) aligned;
2937 dcl explanation_string char (95);
2938 dcl get_answer char (5) varying;
2939 dcl mssf bit (1) aligned;
2940 dcl neg char (6);
2941 dcl query_flg bit (1) aligned;
2942 dcl question_string char (20);
2943 dcl quiet_sw bit (1) aligned;
2944
2945
2946
2947 if rtq_info.two_eofs then goto gleot;
2948
2949 end_file = "0"b;
2950 auto_retry = 0;
2951
2952 retry_rd:
2953 call iox_$read_record (rtq_info.tiocb_ptr, rtq_info.tptr, rtq_info.buf_size - NUMB_OF_CHARS_PER_WORD, rtq_info.rec_len, scode);
2954
2955 if scode ^= 0 then do;
2956
2957 if scode ^= error_table_$end_of_info then do;
2958 save_status_code = scode;
2959 call get_tape_status;
2960
2961 if mssf then do;
2962 auto_retry = auto_retry + 1;
2963 if auto_retry > 10 then do;
2964 call ssu_$print_message (sci_ptr, save_status_code,
2965 "^/Tape status = ^4.3b.^/^[""^a""^;^1s^] ^/ Therefore, skipping record ^d, file ^d, ^a.",
2966 t_stat, (status_story ^= ""), status_story, rtq_info.c_rec,
2967 rtq_info.c_file, "due to unrecoverable read error");
2968
2969 rtq_info.c_rec = rtq_info.c_rec + 1;
2970 end;
2971 else call iox_$control (rtq_info.tiocb_ptr, "backspace_record", null, scode);
2972
2973 go to retry_rd;
2974 end;
2975
2976 call ssu_$print_message (sci_ptr, save_status_code,
2977 "Tape status = ^4.3b.^/^[ ""^a""^;,^1s^] while reading record ^d, file ^d",
2978 t_stat, (status_story ^= ""), status_story, rtq_info.c_rec, rtq_info.c_file);
2979
2980 if neg ^= "stop" then do;
2981 explanation_string = "Do you want to retry, skip to the next record, or stop? Answer ""retry"", ""skip"", or ""stop"".";
2982 question_string = "Retry, skip or stop?";
2983 end;
2984 else do;
2985 explanation_string = "Do you want to retry or stop? Answer ""retry"" or ""stop"".";
2986 question_string = "Retry or stop?";
2987 end;
2988
2989 get_answer = command_query_no_entrypoint (explanation_string, question_string);
2990
2991 query_flg = "1"b;
2992 do while (query_flg);
2993 query_flg = "0"b;
2994 if get_answer = "retry" then do;
2995 call iox_$control (rtq_info.tiocb_ptr, "backspace_record", null, scode);
2996
2997 if scode = error_table_$end_of_info then
2998 goto END_OF_INFO_REACHED;
2999 else go to retry_rd;
3000 end;
3001
3002 else if get_answer = "skip" then do;
3003 rtq_info.c_rec = rtq_info.c_rec + 1;
3004 go to retry_rd;
3005 end;
3006
3007 else if get_answer = "stop" then do;
3008 rtq_info.return_subsys_loop_flg = "1"b;
3009 end_file = "1"b;
3010 return;
3011 end;
3012
3013 else do;
3014 get_answer = command_query_no_entrypoint (explanation_string, question_string);
3015
3016 query_flg = "1"b;
3017 end;
3018 end;
3019 end;
3020
3021 else do;
3022 END_OF_INFO_REACHED:
3023 if rtq_info.one_eof | rtq_info.eov then rtq_info.two_eofs = "1"b;
3024 else rtq_info.one_eof = "1"b;
3025
3026 gleot:
3027 if ^quiet_sw then do;
3028 if rtq_info.two_eofs then do;
3029 call ioa_ ("End of file encountered on file # ^d. No data read.", rtq_info.c_file);
3030
3031 call ioa_ ("Logical end of tape at physical file # ^d", rtq_info.c_file);
3032 end;
3033 else do;
3034 if rtq_info.c_rec = 1 then do;
3035 call ioa_ ("End of file encountered on file # ^d. No data read.", rtq_info.c_file);
3036
3037 call ioa_ ("Positioning to start of file # ^d.", rtq_info.c_file + 1);
3038 end;
3039 else do;
3040 call ioa_ ("End of file after ^d record^[s^] read from tape file # ^d",
3041 rtq_info.c_rec - 1, (rtq_info.c_rec > 2), rtq_info.c_file);
3042 call ioa_ ("Positioning to start of file # ^d.", rtq_info.c_file + 1);
3043 end;
3044 end;
3045
3046 rtq_info.c_rec = 1;
3047 end;
3048
3049 rtq_info.c_file = rtq_info.c_file + 1;
3050 rtq_info.bits = 0;
3051 end_file = "1"b;
3052 end;
3053 end;
3054 else do;
3055 rtq_info.c_rec = rtq_info.c_rec + 1;
3056 rtq_info.buf_ful = "1"b;
3057 rtq_info.bits = rtq_info.rec_len * 9;
3058 rtq_info.one_eof = "0"b;
3059 end;
3060
3061 end read_tape_record;
3062
3063
3064 %page;
3065 record_information: proc (numrecs, nbits, rcd_tally);
3066
3067
3068
3069
3070 dcl (bit6, bit8, bit9) fixed bin (35) init (0);
3071 dcl (nbits, numrecs) fixed bin (35);
3072 dcl rcd_tally bit (1);
3073
3074
3075 if ^rcd_tally then
3076 if valid_label_record ("1"b) then return;
3077
3078 nwds = divide (nbits, 36, 35);
3079 bit9 = divide (nbits, 9, 35);
3080 bit8 = divide (nbits, 8, 35);
3081 bit6 = divide (nbits, 6, 35);
3082
3083 call ioa_ ("^[ ^d record^[s^]:^;^2sRecord^] ^a ^d ^a, ^d ^a, ^d ^a,^[^/ ^-^[^- ^;^6x^]^;^1s ^] ^d ^a, ^d ^a",
3084 rcd_tally, numrecs, (numrecs > 1), "length =", nbits, "bits", nwds, "words", bit9,
3085 "nine bit bytes", rtq_info.short_output_flg, rcd_tally, bit8, "eight bit bytes", bit6, "six bit chars");
3086
3087 end record_information;
3088
3089
3090 %page;
3091 valid_label_record: proc (lg_ck) returns (bit (1) aligned);
3092
3093
3094
3095
3096 dcl ansi_hdr2_fmt char (108) int static options (constant) init
3097 ("Record format ^a^[^[B^]^;^1s^]; Block length ^d; Record length ^d; Mode ^[ASCII^;EBCDIC^;BINARY^;UNKNOWN^];");
3098
3099 dcl (eov, lg_ck) bit (1) aligned;
3100
3101
3102 go to lab_type (rtq_info.l_type);
3103
3104 lab_type (1):
3105 if rtq_info.tptr -> mstr.head.label then do;
3106 call ioa_ ("^[^/^] ^a version ^[2^;1^] label record for volume ^a", (rtq_info.c_rec = 2),
3107 LABEL (rtq_info.l_type), (unspec (substr (rtq_info.tptr -> mult.volume_set_id, 1, 1)) ^= "777"b3), rtq_info.tptr -> mult.tape_reel_id);
3108
3109 if lg_ck then do;
3110 if substr (rtq_info.tptr -> mstr.head.uid, 18, 1) then
3111 call date_time_ (bin (substr (rtq_info.tptr -> mstr.head.uid, 19, 52), 71), time_string);
3112 else call date_time_ (bin (rtq_info.tptr -> mstr.head.uid, 71), time_string);
3113
3114 call ioa_ ("Tape created on:^-^a", time_string);
3115
3116 if rtq_info.tptr -> mult.installation_id ^= "" then
3117 call ioa_ ("Tape created at:^-^a", rtq_info.tptr -> mult.installation_id);
3118
3119 if unspec (substr (rtq_info.tptr -> mult.volume_set_id, 1, 1)) ^= "777"b3 then
3120 if rtq_info.tptr -> mult.volume_set_id ^= "" then
3121
3122 call ioa_ ("Volume Set Name:^-^a", rtq_info.tptr -> mult.volume_set_id);
3123 end;
3124 end;
3125
3126 else if rtq_info.tptr -> mstr.head.eor then
3127 call ioa_ ("^[^/^] ^a end of reel record", (rtq_info.c_rec = 2), LABEL (rtq_info.l_type));
3128 else return ("0"b);
3129
3130 return ("1"b);
3131
3132
3133 lab_type (2):
3134 if rtq_info.c_file = 1 & rtq_info.tptr -> mst_label.head.label then do;
3135 call ioa_ ("^[^/^] ^a version ^d label record for volume ^a", (rtq_info.c_rec = 2), LABEL (rtq_info.l_type),
3136 rtq_info.tptr -> mst_label.label_version, rtq_info.tptr -> mst_label.tape_reel_id);
3137
3138 if lg_ck then do;
3139 if substr (rtq_info.tptr -> mst_label.head.uid, 18, 1) then
3140 call date_time_ (bin (substr (rtq_info.tptr -> mst_label.head.uid, 19, 52), 71), time_string);
3141 else call date_time_ (bin (rtq_info.tptr -> mst_label.head.uid, 71), time_string);
3142
3143 call ioa_ ("Tape created on:^-^a", time_string);
3144
3145 if rtq_info.tptr -> mst_label.installation_id ^= "" then
3146 call ioa_ ("Tape created at:^-^a", rtq_info.tptr -> mst_label.installation_id);
3147
3148 if rtq_info.tptr -> mst_label.userid ^= "" then
3149 call ioa_ ("Tape created by:^-^a", rtq_info.tptr -> mst_label.userid);
3150
3151 if rtq_info.tptr -> mst_label.boot_pgm_path ^= "" then
3152 call ioa_ ("Boot program path:^-^a", rtq_info.tptr -> mst_label.boot_pgm_path);
3153
3154 if rtq_info.tptr -> mst_label.volume_set_id ^= "" then
3155 call ioa_ ("Volume Set Name:^-^a", rtq_info.tptr -> mst_label.volume_set_id);
3156
3157 if rtq_info.tptr -> mst_label.copyright ^= "" then
3158 call ioa_ ("Protection Notice:^-^a", rtq_info.tptr -> mst_label.copyright);
3159 end;
3160 end;
3161
3162 else if rtq_info.tptr -> mstr.head.eor then
3163 call ioa_ ("^[^/^] ^a end of reel record", (rtq_info.c_rec = 2), LABEL (rtq_info.l_type));
3164 else return ("0"b);
3165
3166 return ("1"b);
3167
3168
3169 lab_type (3):
3170 if rtq_info.bits = 504 then do;
3171 call bcd_to_ascii_ (bit_buf, rtq_info.cbufp -> cbuf);
3172
3173 if gcos.lab_id = g_label then do;
3174 if substr (bit_buf, 145, 216) = "0"b then do;
3175 rtq_info.eov, rtq_info.two_eofs = "1"b;
3176 j = 24;
3177 end;
3178 else j = 60;
3179
3180 call ioa_ ("^a ^[Partial ^]^[BTL ^]^a^[; Tape reel # ^a^;^1s^].^[^/(""^a"")^;^1s^]^[^/^]",
3181 LABEL (rtq_info.l_type), eov, (rtq_info.c_file = 1), "header label record", (rtq_info.c_file ^= 1),
3182 substr (rtq_info.cbufp -> cbuf, 19, 6), lg_ck, substr (rtq_info.cbufp -> cbuf, 1, j), eov);
3183 end;
3184
3185 else call ioa_ ("^/^a ""^a"" label record. ^a ^d^[; Next reel # ^a^;^1s^].^[^/(""^a"")^;^1s^]",
3186 LABEL (rtq_info.l_type), substr (rtq_info.cbufp -> cbuf, 2, 3), "Block count of previous file",
3187 bin (substr (bit_buf, 37, 36)), (substr (rtq_info.cbufp -> cbuf, 79, 6) ^= ""),
3188 substr (rtq_info.cbufp -> cbuf, 79, 6), lg_ck, rtq_info.cbufp -> cbuf);
3189 return ("1"b);
3190 end;
3191
3192 else return ("0"b);
3193
3194
3195 lab_type (4):
3196 if rtq_info.rec_len = 80 then do;
3197 call ebcdic_to_ascii_ (rtq_info.tptr -> char_buf, rtq_info.cvbp -> cv_buf);
3198 rtq_info.lblp = rtq_info.cvbp;
3199 go to ibm_asc_join;
3200 end;
3201
3202 else return ("0"b);
3203
3204
3205 lab_type (5):
3206 if rtq_info.rec_len = 80 then do;
3207 rtq_info.lblp = rtq_info.tptr;
3208
3209 ibm_asc_join:
3210
3211 if substr (lab_buf, 1, 4) = "VOL1" then
3212 call ioa_ ("^[^/^] ^a ^a label record. Volume serial number ^a^[^/(""^a"")^;^1s^]^/", (rtq_info.c_rec = 2),
3213 LABEL (rtq_info.l_type), substr (lab_buf, 1, 4), substr (lab_buf, 5, 6), lg_ck, lab_buf);
3214
3215 else if substr (lab_buf, 1, 4) = "HDR1" then
3216 call ioa_ ("^[^/^] ^a ^a label record. Data set ID ^a^[^/(""^a"")^;^1s^]^/", (rtq_info.c_rec = 2),
3217 LABEL (rtq_info.l_type), substr (lab_buf, 1, 4), substr (lab_buf, 5, 17), lg_ck, lab_buf);
3218
3219 else if substr (lab_buf, 1, 4) = "HDR2" then do;
3220 call ioa_ ("^a ^a label record. Next file format:", LABEL (rtq_info.l_type), substr (lab_buf, 1, 4));
3221
3222 if rtq_info.l_type = ibm_label then do;
3223 ibm_hdr2P = rtq_info.lblp;
3224 call ioa_ ("Record format ^a^a; Block length ^d; Record length ^d;",
3225 ibm_hdr2.format, ibm_hdr2.block_attribute, bin (ibm_hdr2.blksize), bin (ibm_hdr2.lrecl));
3226 end;
3227 else do;
3228 ansi_hdr2P = rtq_info.lblp;
3229 ansi_mode = index ("123", ansi_hdr2.mode);
3230
3231 if ansi_mode = 0 then ansi_mode = 4;
3232 call ioa_ (ansi_hdr2_fmt, ansi_hdr2.format, (ansi_hdr2.blocked = "0" | ansi_hdr2.blocked = "1"),
3233 (ansi_hdr2.blocked = "1"), bin (ansi_hdr2.blklen), bin (ansi_hdr2.reclen),
3234 ansi_mode);
3235
3236 if ansi_mode = 3 then
3237 rtq_info.set_bin, rtq_info.set_nine = "1"b;
3238 end;
3239
3240 if lg_ck then call ioa_ ("(""^a"")", lab_buf);
3241 end;
3242
3243 else if substr (lab_buf, 1, 3) = "EOV" | substr (lab_buf, 1, 3) = "EOF" |
3244 substr (lab_buf, 1, 3) = "UHL" | substr (lab_buf, 1, 3) = "UTL" then do;
3245 call ioa_ ("^[^/^] ^a ^a label record. ^[^/(""^a"")^;^1s^]^/", (rtq_info.c_rec = 2),
3246 LABEL (rtq_info.l_type), substr (lab_buf, 1, 4), lg_ck, lab_buf);
3247
3248 if substr (lab_buf, 1, 3) = "EOV" then eov = "1"b;
3249 end;
3250
3251 else return ("0"b);
3252
3253 return ("1"b);
3254 end;
3255
3256 else return ("0"b);
3257
3258
3259 lab_type (6):
3260 if substr (bit_buf, 1, 9) ^= "172"b3 then
3261 return ("0"b);
3262
3263 call ebcdic_to_ascii_ (rtq_info.tptr -> char_buf, rtq_info.cvbp -> cv_buf);
3264 rtq_info.lblp = rtq_info.cvbp;
3265
3266 if sentinel = ":LBL" | sentinel = ":ACN" | sentinel = ":BOF" |
3267 sentinel = ":EOV" | sentinel = ":EOR" | sentinel = ":EOF" then do;
3268 call ioa_ ("^[^/^] ^a ^a label record^[; Volume id ^a^;^1s^].^[^/(""^a"")^;^1s^]^/", (rtq_info.c_rec = 2),
3269 LABEL (rtq_info.l_type), sentinel, (sentinel = ":LBL"), substr (lab_buf, 5, 4), lg_ck, lab_buf);
3270 return ("1"b);
3271 end;
3272 else return ("0"b);
3273
3274
3275 lab_type (0):
3276 return ("0"b);
3277
3278 end valid_label_record;
3279
3280
3281 %page;
3282 valid_pathname: proc (pathname_argument, suffix) returns (bit (1) aligned);
3283
3284
3285
3286
3287
3288 dcl p_dir char (168);
3289 dcl p_entry char (32);
3290 dcl pathname_argument char (*);
3291 dcl suffix char (*);
3292
3293
3294 call expand_pathname_$add_suffix (pathname_argument, suffix, p_dir, p_entry, scode);
3295 if scode ^= 0 then
3296 return ("0"b);
3297 else do;
3298 rtq_info.filename = p_entry;
3299 rtq_info.filepath = pathname_ (p_dir, p_entry);
3300 return ("1"b);
3301 end;
3302
3303 end valid_pathname;
3304
3305
3306 %page;
3307 write_file: proc (bufptr, wrtchars, s_file_name);
3308
3309
3310
3311
3312
3313
3314
3315
3316
3317
3318
3319 dcl bufptr ptr;
3320 dcl output_filename char (168) aligned;
3321 dcl s_file_name char (32) varying;
3322 dcl wrtchars fixed bin (21);
3323
3324
3325 if ^rtq_info.f_attached then do;
3326 if rtq_info.filename = "" then do;
3327 rtq_info.tmr = "0"b;
3328 do while (^rtq_info.tmr);
3329 output_filename = command_query_no_entrypoint ("Please enter an output file name.", "Output file name: ");
3330
3331 rtq_info.tmr = valid_pathname ((output_filename), "");
3332 if ^rtq_info.tmr then do;
3333 call ssu_$print_message (sci_ptr, scode,
3334 "Expanding pathname while writing to the ouput file name ""^a""",
3335 output_filename);
3336
3337 rtq_info.return_subsys_loop_flg = "1"b;
3338 return;
3339 end;
3340 end;
3341 end;
3342
3343 if ^nnl_sw & n_ops = 0 & s_file_name = "" then do;
3344
3345 call ioa_ ("Warning: Tape file # ^d will be written to stream file ^a.^/A new line " ||
3346 "character (octal 012) will be appended to the end of each physical record.",
3347 rtq_info.c_file, rtq_info.filename);
3348
3349 YES_FLG = command_query_yes_no ("Do you want to add a new line character to each physical record? Answer ""yes"" or ""no"".", "Append a new line character?");
3350
3351 if ^YES_FLG then do;
3352 rtq_info.return_subsys_loop_flg = "1"b;
3353 return;
3354 end;
3355 end;
3356
3357 att_desc = "vfile_ " || rtq_info.filepath;
3358
3359
3360 call attach_and_open_output_file;
3361 end;
3362
3363 if ^rtq_info.fw_file then do;
3364 rtq_info.fw_file = "1"b;
3365 if ^rtq_info.atd_sw then
3366 call ioa_ ("Writing file ""^a"".", rtq_info.filepath);
3367 end;
3368
3369 RETRY_WRITE:
3370 if open_mode = Stream_output | open_mode = Stream_input_output then
3371 call iox_$put_chars (rtq_info.fiocb_ptr, bufptr, wrtchars, scode);
3372 else call iox_$write_record (rtq_info.fiocb_ptr, bufptr, wrtchars, scode);
3373
3374 if scode ^= 0 then do;
3375 call ssu_$print_message (sci_ptr, scode, "while writing to ""^a""", att_desc);
3376
3377 YES_FLG = command_query_yes_no ("Do you want to retry? Answer ""yes"" or ""no"".", "Retry?");
3378
3379 if YES_FLG then
3380 goto RETRY_WRITE;
3381 end;
3382
3383 end write_file;
3384
3385
3386 %page;
3387 %include rtq_structure_info;
3388 %page;
3389 %include ibm_hdr2;
3390 %include ansi_hdr2;
3391 %page;
3392 %include mstr;
3393 %include gcos_ssf_records;
3394 %page;
3395 %include iox_modes;
3396 %include area_info;
3397
3398 end rtq_;