COMPILATION LISTING OF SEGMENT record_stream_attach_ Compiled by: Multics PL/I Compiler, Release 29, of July 28, 1986 Compiled at: Honeywell Bull, Phx, AZ, Sys-M Compiled on: 09/10/87 1506.3 mst Thu Options: optimize map 1 /****^ *********************************************************** 2* * * 3* * Copyright, (C) Honeywell Bull Inc., 1987 * 4* * * 5* * Copyright, (C) Honeywell Information Systems Inc., 1982 * 6* * * 7* * Copyright (c) 1972 by Massachusetts Institute of * 8* * Technology and Honeywell Information Systems, Inc. * 9* * * 10* *********************************************************** */ 11 12 13 /****^ HISTORY COMMENTS: 14* 1) change(84-08-22,Ranzenbach), approve(), audit(), install(): 15* Modified to call unique_chars_. 16* 2) change(87-07-01,GWMay), approve(87-07-01,MCR7730), audit(87-09-10,GDixon), 17* install(87-09-10,MR12.1-1104): 18* Completely restructured the code. Added any_other handlers. 19* Changed the close routine to always close the control block. 20* Changed the detach routine to always detach the control block. 21* Changed recursive call for -target attachment to a nonrecursive 22* method. 23* END HISTORY COMMENTS */ 24 25 26 /* format: off */ 27 28 /* main program of record_stream_ io module */ 29 30 record_stream_attach: proc (Piocb_ptr, /* (input) - control block pointer */ 31 option_array, 32 /* (input) - control arguments */ 33 Pcom_err, /* (input) - ON = report errors */ 34 Pcode); /* (output)- error status */ 35 36 iocb_ptr = Piocb_ptr; 37 Scom_err = Pcom_err; 38 call initialize$attach(); 39 40 if iocb.attach_descrip_ptr ^= null then 41 call CHECK_CODE_return_on_error (error_table_$not_detached, ME, 42 "^a", iocb.name); 43 44 call get_args (); 45 46 /* create and initialize rs attach block, with cleanup handler for block */ 47 48 rsab_ptr = null; 49 on cleanup call record_stream_detach_ (); 50 EXIT = EXIT_WITH_DETACH; 51 52 call alloc_cb_file (size (rs_attach_block), rsab_ptr); 53 54 /* If the -target option is present. Attach the target descrip. */ 55 56 if target_args ^= "" then do; 57 rs_attach_desc.switch_name = "rs_" || unique_chars_ ("0"b); 58 rs_attach_block.i_attached_target = TRUE; 59 call iox_$attach_name (rs_attach_desc.switch_name, 60 rs_attach_block.target_iocb_ptr, (target_args), null, code); 61 call CHECK_CODE_return_on_error (code, ME, 62 "Target attach description failed:^/^a", 63 target_args); 64 end; 65 66 /* Otherwise, find target IOCB. */ 67 68 else do; 69 rs_attach_block.i_attached_target = FALSE; 70 call iox_$find_iocb (rs_attach_desc.switch_name, 71 rs_attach_block.target_iocb_ptr, code); 72 call CHECK_CODE_return_on_error (code, ME, 73 "Looking for target IOCB ^a", 74 rs_attach_desc.switch_name); 75 end; 76 77 rs_attach_block.attach_descrip_string = 78 rs_attach_desc.module_name 79 || rtrim(rs_attach_desc.switch_name) 80 || rtrim(rs_attach_desc.args); 81 rs_attach_block.attach_descrip_len = 82 length (rtrim (rs_attach_block.attach_descrip_string)); 83 84 rs_attach_block.target_name = rs_attach_desc.switch_name; 85 rs_attach_block.length_n = arg_record_length; 86 rs_attach_block.open_descrip_len = 0; 87 rs_attach_block.open_descrip_string = ""; 88 rs_attach_block.mode = 0; 89 rs_attach_block.i_opened_target = FALSE; 90 rs_attach_block.base = 0; 91 rs_attach_block.n_left = 0; 92 93 /* Set the iocb to the attach state */ 94 95 ips_mask = ""b; 96 on any_other call hcs_$reset_ips_mask (ips_mask, ips_mask); 97 call hcs_$set_ips_mask ("0"b, ips_mask); 98 iocb.attach_data_ptr = rsab_ptr; 99 iocb.attach_descrip_ptr = addr (rs_attach_block.attach_descrip); 100 iocb.detach_iocb = record_stream_detach; 101 iocb.open = record_stream_open; 102 iocb.modes = record_stream_modes; 103 iocb.control = record_stream_control; 104 105 call iox_$propagate (iocb_ptr); 106 call hcs_$reset_ips_mask (ips_mask, ips_mask); 107 108 EXIT_BY_RETURN: 109 return; 110 111 EXIT_WITH_DETACH: 112 call record_stream_detach_(); 113 return; 114 115 get_args: proc (); 116 117 arg_record_length = 0; 118 rs_attach_desc.module_name = ME; 119 rs_attach_desc.switch_name = ""; 120 rs_attach_desc.args = ""; 121 target_args = ""; 122 123 do i = 1 to hbound (option_array, 1); 124 125 code = 0; 126 127 if option_array (i) = "-no_newline" | option_array (i) = "-nnl" then 128 arg_record_length = -1; 129 else 130 if option_array (i) = "-length" 131 | option_array (i) = "-ln" then do; 132 if i + 1 > hbound (option_array, 1) then 133 call CHECK_CODE (error_table_$noarg, ME, 134 "^/^a requires a positive integer value.", 135 option_array (i)); 136 else do; 137 i = i + 1; 138 arg_record_length = 139 cv_dec_check_ ((option_array (i)), ercode); 140 if ercode ^= 0 141 | arg_record_length <= 0 142 | arg_record_length > CHARS_PER_SEGMENT then 143 call CHECK_CODE (error_table_$bad_arg, ME, 144 "^/^a ^a. The value must be a positive integer less than ^d.", 145 option_array (i - 1), option_array (i), 146 CHARS_PER_SEGMENT+1); 147 end; 148 end; 149 150 else 151 if option_array (i) = "-target" then do; 152 153 /* Build the attach description for the target I/O module. */ 154 155 if i + 1 > hbound (option_array, 1) then 156 call CHECK_CODE (error_table_$noarg, ME, 157 "^a requires an attach description operand.", 158 option_array(i)); 159 else do; 160 i = i + 1; 161 target_args = target_args || option_array (i); 162 do i = i + 1 to hbound (option_array, 1); 163 target_args = target_args || " "; 164 target_args = 165 target_args || requote_string_ ((option_array (i))); 166 end; 167 end; 168 end; 169 170 else 171 if i = 1 then do; /* switch name must be in position 1*/ 172 if length (option_array (i)) > 173 length(rs_attach_desc.switch_name) then 174 call CHECK_CODE (error_table_$bigarg, ME, 175 "^/Target switch name value is longer than ^a characters: ^a.", 176 length(rs_attach_desc.switch_name), option_array (i)); 177 else 178 rs_attach_desc.switch_name = option_array (i); 179 end; 180 181 else 182 if index (option_array(i), "-") = 1 then 183 call CHECK_CODE (error_table_$bad_opt, ME, 184 "^a", option_array (i)); 185 186 else 187 call CHECK_CODE (error_table_$bad_arg, ME, 188 "^a", option_array (i)); 189 end; 190 191 if rs_attach_desc.switch_name = "" then do; 192 if target_args = "" then 193 call CHECK_CODE (error_table_$noarg, ME, "Target switch name"); 194 end; 195 else 196 if target_args ^= "" then 197 call CHECK_CODE (error_table_$bad_arg, ME, 198 "^/Cannot give both a target switch name and -target attach description."); 199 200 if Serror_occurred then 201 go to EXIT; 202 203 if arg_record_length < 0 then /* leading space separates switch */ 204 rs_attach_desc.args = " -nnl";/* name from control args in attach */ 205 else /* description. */ 206 if arg_record_length > 0 then 207 rs_attach_desc.args = 208 " -length " || ltrim (char (arg_record_length)); 209 210 return; 211 end get_args; 212 213 record_stream_open: entry (Piocb_ptr, /* (input) - control block pointer */ 214 open_mode, /* (input) - opening mode(sqi etc.) */ 215 Sextend, /* (input) - ON = add to the file */ 216 Pcode); /* (output)- error status */ 217 218 dcl open_mode fixed bin parameter, 219 Sextend bit (1) aligned parameter; 220 221 call initialize; 222 /* verify open args & set descript. */ 223 224 if open_mode < lbound (iox_modes, 1) 225 | open_mode > hbound(iox_modes, 1) 226 | Sextend then 227 call CHECK_CODE_return_on_error (error_table_$bad_arg, ME); 228 229 else 230 if open_mode = Stream_input_output 231 | open_mode > Sequential_output then 232 call CHECK_CODE_return_on_error (error_table_$bad_mode, ME); 233 234 else 235 if open_mode = Stream_output | open_mode = Sequential_input then do; 236 if rs_attach_block.length_n < 0 then 237 call CHECK_CODE_return_on_error ( 238 error_table_$invalid_record_length, ME); 239 end; 240 241 else 242 if open_mode = Sequential_output | open_mode = Stream_input then do; 243 if rs_attach_block.length_n > 0 then 244 call CHECK_CODE_return_on_error ( 245 error_table_$invalid_record_length, ME); 246 end; 247 248 /* The open_mode is valid set the open description */ 249 250 rs_attach_block.mode = open_mode; 251 rs_attach_block.open_descrip_len = 252 length (rtrim (iox_modes (open_mode))); 253 rs_attach_block.open_descrip_string = iox_modes (open_mode); 254 255 /* If the target switch exists, find out how the targets was opened. */ 256 257 if rs_attach_block.target_iocb_ptr = null then 258 call CHECK_CODE_return_on_error (error_table_$no_iocb, ME); 259 260 target_open_mode_ptr = 261 rs_attach_block.target_iocb_ptr -> iocb.open_descrip_ptr; 262 263 if target_open_mode_ptr ^= null then 264 target_open_mode = before (target_open_mode, SPACE); 265 266 /* If switch is its own target report the error -- looping attachment */ 267 268 if iocb_ptr -> iocb.actual_iocb_ptr 269 = rs_attach_block.target_iocb_ptr -> iocb.actual_iocb_ptr then 270 call CHECK_CODE_return_on_error (error_table_$att_loop, ME); 271 272 /* Set i_opened_target before the cleanup handler. */ 273 274 if rs_attach_block.target_iocb_ptr -> iocb.open_descrip_ptr = null then 275 rs_attach_block.i_opened_target = TRUE; 276 277 on cleanup call record_stream_close_ (); 278 EXIT = EXIT_WITH_CLOSE; 279 280 /* If not open, open the target switch else check its current open mode. */ 281 /* Open the target switch using the opposite mode of what was input. */ 282 283 if rs_attach_block.i_opened_target then 284 call iox_$open (rs_attach_block.target_iocb_ptr, 285 (op_mode (rs_attach_block.mode)), "0"b, code); 286 287 else /* target already opened */ 288 if (target_open_mode ^= iox_modes (op_mode (rs_attach_block.mode))) 289 & (target_open_mode ^= iox_modes (op_io_mode (rs_attach_block.mode))) then 290 code = error_table_$incompatible_attach; 291 292 call CHECK_CODE_return_on_error (code, ME); 293 294 /* Non-Sequential outputs require an internal buffer. */ 295 296 if rs_attach_block.mode ^= Sequential_output then do; 297 call get_temp_segment_ (ME, iocb.open_data_ptr, code); 298 call CHECK_CODE_return_on_error (code, ME); 299 end; 300 301 /* call initialization routine appropriate to opening mode */ 302 303 ips_mask = ""b; 304 on any_other call hcs_$reset_ips_mask (ips_mask, ips_mask); 305 call hcs_$set_ips_mask ("0"b, ips_mask); 306 307 if rs_attach_block.mode = Stream_input then 308 call rs_open_str_in_ (iocb_ptr); 309 else 310 if rs_attach_block.mode = Stream_output then 311 call rs_open_str_out_ (iocb_ptr); 312 else 313 if rs_attach_block.mode = Sequential_input then 314 call rs_open_seq_in_ (iocb_ptr); 315 else 316 call rs_open_seq_out_ (iocb_ptr); 317 318 /* Set up the iocb entries */ 319 320 iocb.open_descrip_ptr = addr (rs_attach_block.open_descrip); 321 iocb.close = record_stream_close; 322 323 call iox_$propagate (iocb_ptr); 324 325 call hcs_$reset_ips_mask (ips_mask, ips_mask); 326 return; 327 328 EXIT_WITH_CLOSE: 329 call record_stream_close_(); 330 return; 331 332 record_stream_close: entry (Piocb_ptr, /* (input) control block pointer */ 333 Pcode); /* (output) error status */ 334 335 call initialize; 336 call record_stream_close_ (); 337 call CHECK_CODE_return_on_error (code, ME); 338 return; 339 340 341 record_stream_close_: proc (); 342 343 /* This is an internal procedure so that the open entry can use it 344* in its cleanup handler. */ 345 346 /* If Stream_output, the target is open for sequential output. Flush the 347* temp work buffer. */ 348 349 if rs_attach_block.mode ^= Sequential_output then do; 350 351 if rs_attach_block.mode = Stream_output 352 & rs_attach_block.n_left > 0 then 353 call iox_$write_record (rs_attach_block.target_iocb_ptr, 354 iocb.open_data_ptr, rs_attach_block.n_left, code); 355 356 if iocb.open_data_ptr ^= null then 357 call release_temp_segment_ (ME, iocb.open_data_ptr, ercode); 358 end; 359 360 if rs_attach_block.i_opened_target then do; 361 call iox_$close (rs_attach_block.target_iocb_ptr, ercode); 362 if code = 0 then 363 code = ercode; 364 end; 365 366 ips_mask = ""b; 367 on any_other call hcs_$reset_ips_mask (ips_mask, ips_mask); 368 call hcs_$set_ips_mask ("0"b, ips_mask); 369 370 iocb.open_descrip_ptr = null; 371 iocb.open_data_ptr = null; 372 iocb.detach_iocb = record_stream_detach; 373 iocb.open = record_stream_open; 374 375 call iox_$propagate (iocb_ptr); 376 377 call hcs_$reset_ips_mask (ips_mask, ips_mask); 378 return; 379 end record_stream_close_; 380 381 record_stream_detach: entry (Piocb_ptr, /* (input) - control block pointer */ 382 Pcode); /* (output)- error status */ 383 384 call initialize(); 385 call record_stream_detach_ (); 386 call CHECK_CODE_return_on_error (code, ME); 387 return; 388 389 record_stream_detach_: proc (); 390 391 /* This is an internal procedure so that the attach entry can use it 392* in its cleanup handler. */ 393 394 /* detach target if it was attached with the -target option */ 395 396 if rsab_ptr = null then 397 return; 398 399 if rs_attach_block.i_attached_target then do; 400 call iox_$detach_iocb (rs_attach_block.target_iocb_ptr, code); 401 call iox_$destroy_iocb (rs_attach_block.target_iocb_ptr, ercode); 402 end; 403 404 ips_mask = ""b; 405 on any_other call hcs_$reset_ips_mask (ips_mask, ips_mask); 406 call hcs_$set_ips_mask ("0"b, ips_mask); 407 408 iocb.attach_data_ptr = null; 409 iocb.attach_descrip_ptr = null; 410 411 call iox_$propagate (iocb_ptr); 412 call hcs_$reset_ips_mask (ips_mask, ips_mask); 413 414 call free_cb_file (size (rs_attach_block), rsab_ptr); 415 rsab_ptr = null; 416 417 return; 418 end record_stream_detach_; 419 420 record_stream_modes: entry (Piocb_ptr, /* (input) - control block pointer */ 421 new_modes, /* (input) - modes to set to */ 422 old_modes, /* (output)- current modes */ 423 Pcode); /* (output)- error status */ 424 425 dcl new_modes char (*) parameter, 426 old_modes char (*) parameter; 427 428 call initialize; 429 call iox_$modes (rs_attach_block.target_iocb_ptr, new_modes, old_modes, 430 Pcode); 431 /* pass call to target */ 432 return; 433 434 record_stream_control: entry (Piocb_ptr,/* (input) - control block pointer */ 435 order, /* (input) - requested order */ 436 info_ptr, /* (input) - info for the control et*/ 437 Pcode); /* (output)- error status */ 438 439 dcl order char(*) parameter, 440 info_ptr ptr parameter; 441 442 call initialize; 443 call iox_$control (rs_attach_block.target_iocb_ptr, order, info_ptr, 444 Pcode); 445 /* pass call to target */ 446 return; 447 448 initialize: proc; 449 /* internal procedure for initializing pointers and other variables */ 450 451 iocb_ptr = Piocb_ptr -> iocb.actual_iocb_ptr; 452 rsab_ptr = iocb.attach_data_ptr; 453 Scom_err = FALSE; 454 455 initialize$attach: 456 entry; 457 458 Pcode, code = 0; 459 Serror_occurred = FALSE; 460 EXIT = EXIT_BY_RETURN; 461 return; 462 463 end initialize; 464 465 /* * * * * * * * * * * * * * * * * * * * * * * * * * */ 466 /* */ 467 /* This procedure examines its code parameter. If it is nonzero, it sets */ 468 /* the code output parameter of the current external entrypoint. It */ 469 /* optionally prints an error message. Execution stops (via nonlocal goto) */ 470 /* for nonzero codes passed to CHECK_CODE_return_on_error. If code is 0, */ 471 /* these programs do nothing but return to their caller. */ 472 /* */ 473 /* Syntax: call CHECK_CODE (code, program_name, ioa_ctl_str, ioa_args); */ 474 /* call CHECK_CODE_return_on_error */ 475 /* (code, program_name, ioa_ctl_str, ioa_args); */ 476 /* */ 477 /* * * * * * * * * * * * * * * * * * * * * * * * * * */ 478 479 CHECK_CODE: 480 proc options(variable); 481 482 dcl error_code fixed bin(35) based (p_error_code), 483 p_error_code ptr; 484 485 dcl Sfatal bit (1) aligned; 486 487 dcl cu_$arg_list_ptr entry returns(ptr), 488 cu_$arg_ptr entry (fixed bin, ptr, fixed bin(21), 489 fixed bin(35)), 490 cu_$generate_call entry (entry, ptr); 491 492 Sfatal = FALSE; 493 go to ERROR_COMMON; 494 495 CHECK_CODE_return_on_error: 496 entry options (variable); 497 498 Sfatal = TRUE; 499 500 ERROR_COMMON: 501 502 call cu_$arg_ptr (1, p_error_code, 0, 0); 503 if error_code = 0 then return; 504 if Pcode = 0 then /* set output code parameter if it */ 505 Pcode = error_code; /* hasn't been set before. */ 506 507 if Scom_err then 508 call cu_$generate_call (com_err_, cu_$arg_list_ptr()); 509 510 Serror_occurred = TRUE; 511 if Sfatal then 512 go to EXIT; 513 return; 514 end CHECK_CODE; 515 516 /* parameters */ 517 518 dcl Piocb_ptr ptr parameter, 519 Pcom_err bit (1) aligned parameter, 520 Pcode fixed bin (35) parameter, 521 option_array(*) char (*) varying parameter; 522 523 /* automatic */ 524 525 dcl EXIT label variable, 526 Scom_err bit (1) aligned, 527 Serror_occurred bit (1) aligned, 528 arg_record_length fixed bin (35), 529 code fixed bin(35), 530 ercode fixed bin (35), 531 i fixed bin, 532 ips_mask bit(36) aligned, 533 1 rs_attach_desc aligned, 534 2 module_name char (15), 535 2 switch_name char (32) unal, 536 2 args char (20), 537 target_args char (1024) varying; 538 539 /* based */ 540 541 dcl target_open_mode_ptr ptr, 542 target_open_mode char (24) varying 543 based (target_open_mode_ptr); 544 545 /* entries */ 546 547 dcl alloc_cb_file entry (fixed bin, ptr), 548 cv_dec_check_ entry (char(*), fixed bin(35)) returns(fixed bin(35)), 549 com_err_ entry() options(variable), 550 get_temp_segment_ entry (char(*), ptr, fixed bin(35)), 551 free_cb_file entry (fixed bin, ptr), 552 hcs_$reset_ips_mask entry (bit(36) aligned, bit(36) aligned), 553 hcs_$set_ips_mask entry (bit(36) aligned, bit(36) aligned), 554 release_temp_segment_ entry (char(*), ptr, fixed bin(35)), 555 requote_string_ entry (char(*)) returns(char(*)), 556 rs_open_seq_in_ entry (ptr), 557 rs_open_seq_out_ entry (ptr), 558 rs_open_str_in_ entry (ptr), 559 rs_open_str_out_ entry (ptr), 560 unique_chars_ entry (bit(*)) returns(char(15)); 561 562 /* external static */ 563 564 dcl (error_table_$att_loop, 565 error_table_$bad_arg, 566 error_table_$bad_opt , 567 error_table_$bad_mode, 568 error_table_$bigarg, 569 error_table_$incompatible_attach, 570 error_table_$invalid_record_length, 571 error_table_$no_iocb, 572 error_table_$noarg, 573 error_table_$not_detached) fixed bin(35) ext static; 574 575 /* internal static */ 576 577 dcl FALSE bit (1) aligned internal static 578 options (constant) init ("0"b); 579 580 dcl ME char (14) internal static 581 options (constant) 582 init ("record_stream_"); 583 584 dcl TRUE bit (1) aligned internal static 585 options (constant) init ("1"b); 586 587 dcl SPACE char (1) aligned internal static 588 options (constant) init (" "); 589 590 dcl op_io_mode (5) fixed bin internal static options 591 (constant) init (6, 6, 6, 3, 3); 592 593 dcl op_mode (5) fixed bin internal static options 594 (constant) init (4, 5, 6, 1, 2); 595 596 /* builtins */ 597 598 dcl (addr, before, char, hbound, index, lbound, length, ltrim, null, 599 rtrim, size) builtin; 600 601 /* conditions */ 602 603 dcl (any_other, cleanup) condition; 604 1 1 /* BEGIN: rs_attach_block.incl.pl1 * * * * * */ 1 2 1 3 1 4 /****^ HISTORY COMMENTS: 1 5* 1) change(75-02-13,Asherman), approve(), audit(), install(): 1 6* Initial coding. 1 7* 2) change(87-08-30,GWMay), approve(87-08-30,MCR7730), audit(87-09-10,GDixon), 1 8* install(87-09-10,MR12.1-1104): 1 9* Changed target_name to be unaligned. 1 10* END HISTORY COMMENTS */ 1 11 1 12 1 13 dcl rsab_ptr ptr; 1 14 dcl 1 rs_attach_block based (rsab_ptr) aligned, 1 15 /* record_stream_ attach block */ 1 16 /* the following are set during attachment */ 1 17 2 attach_descrip, 1 18 3 attach_descrip_len 1 19 fixed (35), 1 20 3 attach_descrip_string 1 21 char (66), /* "record_stream_