*copyc OSD$DEFAULT_PRAGMATS
MODULE icm$open;

?? PUSH (LISTEXT := ON) ??
?? POP ??
*copyc AMT$FILE_POSITION
*copyc amc$fap_request_codes
*copyc osd$virtual_address
*copyc amt$access_level
*copyc amt$attribute_source
*copyc amt$average_record_length
*copyc amt$block_type
*copyc amt$collate_table
*copyc amt$collation_value
*copyc amt$data_padding
*copyc amt$error_exit_procedure
*copyc amt$error_limit
*copyc amt$estimated_record_count
*copyc amt$file_access_selections
*copyc amt$file_attribute_keys
*copyc amt$file_attributes
*copyc amt$file_byte_address
*copyc amt$file_identifier
*copyc amt$file_length
*copyc amt$file_limit
*copyc amt$file_organization
*copyc amt$file_position
*copyc amt$forced_write
*copyc amt$global_file_position
*copyc amt$index_padding
*copyc amt$internal_code
*copyc amt$key_length
*copyc amt$key_position
*copyc amt$key_type
*copyc amt$label_exit_procedure
*copyc amt$label_options
*copyc amt$label_type
*copyc amt$local_file_name
*copyc amc$mau_length
*copyc amt$max_block_length
*copyc amt$max_record_length
*copyc amt$message_control
*copyc amt$min_block_length
*copyc amt$min_record_length
*copyc amt$padding_character
*copyc amt$record_limit
*copyc amt$record_type
*copyc amt$records_per_block
*copyc amt$return_option
*copyc amt$user_info
*copyc amt$vertical_print_density
*copyc ost$status
*copyc amt$file_access_selections
*copyc AMP$FETCH
*copyc AMP$SET_FILE_INSTANCE_ABNORMAL
*copyc CLP$READ_VARIABLE
*copyc I#PTR
*copyc I#REL
*copyc ICE$ERROR_CODES
*copyc MLP$ADD_SENDER
*copyc MLP$CONFIRM_SEND
*copyc MLP$SIGN_ON
*copyc ICF$OPEN_FILE_DESCRIPTOR
*copyc ICT$PARTNER_MESSAGES
*copyc ICP$INITIATE_PARTNER_JOB
*copyc ICP$SET_STATUS_ABNORMAL
*copyc ICV$OPEN_FILE_COUNT_LOCK
*copyc JMP$GET_JOB_ATTRIBUTES
*copyc OST$STATUS
*copyc OSS$JOB_PAGED_LITERAL
*copyc OSP$APPEND_STATUS_INTEGER
*copyc OSP$CLEAR_SIGNATURE_LOCK
*copyc OSP$SET_SIGNATURE_LOCK
*copyc PMP$EXIT
*copyc PMP$GET_USER_IDENTIFICATION
*copyc PMP$WAIT
*copyc RHP$GET_LINK_USER_DESCRIPTOR
?? POP ??

  TYPE
    ict$validation_information = packed record
      job: array [1 .. 10] of icf$170_record,
      user_name: array [1 .. 2] of icf$170_record,
      family_name: array [1 .. 2] of icf$170_record,
      password: array [1 .. 4] of icf$170_record,
      charge_number: array [1 .. 4] of icf$170_record,
      project_number: array [1 .. 4] of icf$170_record,
      original_user_name: array [1 .. 2] of icf$170_record,
      original_family_name: array [1 .. 2] of icf$170_record,
      original_charge_number: array [1 .. 4] of icf$170_record,
      original_project_number: array [1 .. 4] of icf$170_record,
    recend;

  VAR
    clv_gets: integer,
    single_string: boolean,
    previous_length: integer,
    clv_length: integer,
    clv_end: boolean,
    curr_ptr: ^cell,
    clvptr: ^cell;

?? EJECT ??
{  ICP$READ_CV
{
{     The purpose of this procedure is to read the command language
{  variable named in User_Info in the link file to get certain
{  attributes of the command language variable, i.e., a pointer to
{  the value string, the length of the string, and the dimensions
{  of the variable.
{
{     ICP$READ_CV (CVNAME, STAT);
{
{  CVNAME: (input) This parameter specifies the name of the command
{     language variable to be read.
{
{  STAT: (output) This parameter indicates whether or not the attempt
{     to read the command language variable was successful.

  PROCEDURE icp$read_cv
    (    cvname: string ( * );
     VAR clvar: clt$variable_reference;
     VAR stat: ost$status);

    VAR
      len_ptr: ^ost$string_size;

    clp$read_variable (cvname, clvar, stat);
    IF NOT stat.normal THEN
      RETURN;
    IFEND;
    IF clvar.value.kind <> clc$string_value THEN
      stat.normal := FALSE;
      RETURN;
    IFEND;
    single_string := clvar.lower_bound = clvar.upper_bound;
    IF single_string THEN
      previous_length := 1;
    ELSE
      previous_length := 0;
    IFEND;
    clv_length := clvar.value.max_string_size;
    clvptr := clvar.value.string_value;
    curr_ptr := clvptr;
    len_ptr := curr_ptr;
    clv_end := (clv_length = 0) OR (len_ptr^ = 0);
    clv_gets := 0;

  PROCEND icp$read_cv;
?? EJECT ??
{  ICP$GET_NEXT_CV
{
{     The purpose of this procedure is to locate the next NOS command
{  within the string of the command language variable named in User_
{  Info of the link file.  A pointer to the beginning of the next NOS
{  command, and the length of the NOS command are returned.
{
{     ICP$GET_NEXT_CV (PTR,LEN);
{
{  PTR: (output) This parameter points to the beginning of the next
{     NOS command.
{
{  LEN: (output) This parameter indicates the length of the next NOS
{     command.

  PROCEDURE icp$get_next_cv
    (VAR ptr: ^cell;
     VAR clvar: clt$variable_reference;
     VAR len: integer);

    VAR
      remains: integer,
      str_ptr: ^string (osc$max_string_size),
      len_ptr: ^ost$string_size;

    IF clv_end THEN
      len := 0;
      ptr := NIL;
      RETURN;
    IFEND;
    IF single_string THEN
      curr_ptr := i#ptr ((previous_length + 1), curr_ptr);
    ELSE
      len_ptr := i#ptr (previous_length, curr_ptr);
      curr_ptr := i#ptr (2, len_ptr);
    IFEND;

    IF single_string THEN
      remains := clv_length - i#rel (clvptr, curr_ptr);
      str_ptr := curr_ptr;

    /loop/
      FOR len := 1 TO remains DO
        IF str_ptr^ (len) = ';' THEN
          EXIT /loop/;
        IFEND;
      FOREND /loop/;
      clv_end := len >= remains;
      len := len - 1;
      previous_length := len;
    ELSE
      len := len_ptr^;
      clv_gets := clv_gets + 1;
      clv_end := clv_gets > (clvar.upper_bound - clvar.lower_bound);
      previous_length := clv_length;
    IFEND;
    ptr := curr_ptr;

  PROCEND icp$get_next_cv;
?? EJECT ??
{  ICP$CONVERT
{
{     The purpose of this routine is to convert a 180 ASCII string to
{  a 170 Z-type display code record.  The length of the 170 record is
{  'measured' in terms of words.  Conversion stops when the 170 record
{  area is filled (an error), or the 180 string is exhausted.  A Z-
{  type record is terminated by a right justified field of 12 to 60
{  bits of zeros.
{
{     ICP$CONVERT (SOURCE_STRING,SOURCE_LENGTH,ZREC,ZINDEX,ZLEN,STAT);
{
{  SOURCE_STRING (input) This parameter is a pointer to the ASCII
{     string that is to be converted.
{
{  SOURCE_LENGTH (input) This parameter indicates the length of
{     the ASCII string.
{
{  ZREC (input) This parameter is a pointer to where the converted
{     string is to be placed.
{
{  ZINDEX (output) This parameter indicates the number of 170
{     words needed to hold the converted string.
{
{  ZLEN (input) This parameter indicates the size (in words) of the
{     area where the converted string is to be placed.
{
{  STAT (output) This parameter indicates whether or not the converted
{     string would fit into ZREC.

  TYPE

    icf$170_record = packed record
      f1: 0 .. 0f(16),
      chr0: 0 .. 3f(16),
      chr1: 0 .. 3f(16),
      f_word: packed array [2 .. 9] of 0 .. 3f(16),
    recend,
    icf$180_record = 0 .. 0ff(16);


  PROCEDURE icp$convert
    (    source_string: ^array [1 .. 256] of icf$180_record;
         source_length: integer;
         z_rec: ^array [1 .. * ] of icf$170_record;
     VAR z_rec_index: integer;
         z_rec_length: integer;
     VAR status: ost$status);


?? FMT (FORMAT := ON) ??

    VAR
      cnv_tab: [STATIC, READ, oss$job_paged_literal] array [0 .. 255] of
            0 .. 3f(16) :=
{  } [REP 32 of 39,
{  } 45, 54, 52, 48, 43, 51, 55, 56, 41, 42, 39, 37, 46, 38, 47, 40,
{  } 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 00, 63, 58, 44, 59, 57,
{  } 60, 01, 02, 03, 04, 05, 06, 07, 08, 09, 10, 11, 12, 13, 14, 15,
{  } 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 49, 61, 50, 62, 53,
{  } 61, 01, 02, 03, 04, 05, 06, 07, 08, 09, 10, 11, 12, 13, 14, 15,
{  } 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 39, 39, 39, 39, 39,
{  } REP 128 of 39];


    VAR
      i: integer,
      source_offset: integer,
      working_length: integer,
      zeros_needed: 0 .. 11;

    source_offset := 1;
    z_rec_index := 0;
    working_length := source_length;

  /trailing_blanks/
    FOR i := working_length DOWNTO 1 DO
      IF source_string^ [i] = 32 THEN
        working_length := working_length - 1;
      ELSE
        EXIT /trailing_blanks/;
      IFEND;
    FOREND /trailing_blanks/;
    WHILE (z_rec_index <= z_rec_length) AND
          (source_offset <= working_length) DO
      icp$insert_next_170_char (z_rec, z_rec_index,
            cnv_tab [source_string^ [source_offset]]);
      source_offset := source_offset + 1;
    WHILEND;
    zeros_needed := (11 - source_offset MOD 10);
    IF zeros_needed < 2 THEN
      zeros_needed := zeros_needed + 10;
    IFEND;
    IF ((zeros_needed DIV 10) + z_rec_index) > z_rec_length THEN
      status.normal := FALSE;
      RETURN;
    IFEND;
    FOR i := 1 TO zeros_needed DO
      icp$insert_next_170_char (z_rec, z_rec_index, 0);
    FOREND;

  PROCEND icp$convert;

?? EJECT ??
{  ICP$INSERT_NEXT_170_CHAR
{
{     The purpose of this procedure is to insert  a display code
{  character into the next six bit character position in the lower
{  sixty bits of a word.
{
{     ICP$INSERT_NEXT_170_CHAR (ZREC, ZINDEX, ZCHAR);
{
{  ZREC (input) This parameter is a pointer to a 170 record area.
{
{  ZINDEX (input,output) This parameter indicates which word within
{     the 170 record area is to hold the next display code character.
{
{  ZCHAR (input) This parameter is the six bit display code character
{     to be inserted.

  PROCEDURE icp$insert_next_170_char
    (    z_rec: ^array [1 .. * ] of icf$170_record;
     VAR z_rec_index: integer;
         z_char: 0 .. 3f(16));

    VAR
      c: [STATIC] 0 .. 10;

    IF z_rec_index = 0 THEN
      z_rec_index := 1;
      c := 0;
    IFEND;
    IF c = 10 THEN
      z_rec_index := z_rec_index + 1;
      c := 0;
    IFEND;
    IF c < 2 THEN
      IF c = 0 THEN
        z_rec^ [z_rec_index].f1 := 0;
        z_rec^ [z_rec_index].chr0 := z_char;
      ELSE
        z_rec^ [z_rec_index].chr1 := z_char;
      IFEND;
    ELSE
      z_rec^ [z_rec_index].f_word [c] := z_char;
    IFEND;
    c := c + 1;

  PROCEND icp$insert_next_170_char;
?? EJECT ??
{  ICP$OPEN
{
{     The purpose of this procedure is to 'open' the link file, i.e.,
{  to signon to the memory link, to start the 170 partner job, and
{  to permit the 170 partner job to send to this 180 job.

  PROCEDURE [XDCL] icp$open
    (    icf_file: ^icf_open_file_descriptor;
         operation: amt$fap_operation;
         access_level: amt$access_level;
     VAR status: ost$status);

    VAR
      nos_card_counter: integer,
      liu_stuff: rht$link_user_descriptor,
      clvar: clt$variable_reference,
      get_attribute_p: ^jmt$job_attribute_results,
      validation_information: ict$validation_information,
      fetch_access: array [1 .. 2] of amt$fetch_item,
      stat: ost$status,
      rec: array [1 .. icc$max_partner_image_length] of icf$170_record,
      z_rec: ^array [1 .. icc$max_partner_image_length] of icf$170_record,
      z_rec_index: integer,
      z_rec_length: integer,
      ptr: ^cell,
      len: integer;

{  Initialize.

    status.normal := TRUE;
    icf_file^.position := amc$boi;
    icf_file^.record_length := 0;
    icf_file^.last_fap_op := amc$close_req;
    icf_file^.last_status := 0;
    icf_file^.buff := NIL;
    osp$set_signature_lock (icv$open_file_count_lock, osc$wait, stat);
    IF NOT stat.normal THEN
      pmp$exit (stat);
    IFEND;
    icv$open_file_count := icv$open_file_count + 1;
    osp$clear_signature_lock (icv$open_file_count_lock, stat);
    IF icv$open_file_count > icc$max_open_files_per_job THEN
      amp$set_file_instance_abnormal (icf_file^.file_id,
            ice$link_is_already_open, operation, '', status);
      RETURN;
    IFEND;
    IF access_level <> amc$record THEN
      amp$set_file_instance_abnormal (icf_file^.file_id,
            ice$access_level_not_record, operation, '', status);
      RETURN;
    IFEND;
    fetch_access [1].key := amc$user_info;
    fetch_access [2].key := amc$access_mode;
    amp$fetch (icf_file^.file_id, fetch_access, stat);
    IF fetch_access [1].source = amc$access_method_default THEN
      amp$set_file_instance_abnormal (icf_file^.file_id,
            ice$no_job_spec_variable, operation, '', status);
      RETURN;
    IFEND;

    icf_file^.opened_for_get := pfc$read IN fetch_access [2].access_mode;
    icf_file^.opened_for_put := (pfc$shorten IN fetch_access [2].
          access_mode) OR (pfc$append IN fetch_access [2].access_mode) OR
          (pfc$modify IN fetch_access [2].access_mode);

{  Sign on to the memory link.

  /loop_1/
    WHILE TRUE DO
      mlp$sign_on (mlc$null_name, 1, icf_file^.application_name, stat);

      IF (stat.normal) OR (stat.condition = mlc$ok) THEN
        EXIT /loop_1/;
      ELSE
        CASE stat.condition OF
        = mlc$busy_interlock, mlc$pool_buffer_not_avail =
          pmp$wait (icf_short_interval, icf_short_interval);
          CYCLE /loop_1/;
        ELSE
          icp$set_status_abnormal (stat);
          pmp$exit (stat);
        CASEND;
      IFEND;
    WHILEND /loop_1/;

{  Start the 170 partner job.

    icp$read_cv (fetch_access [1].user_info, clvar, stat);
    IF NOT stat.normal THEN
      amp$set_file_instance_abnormal (icf_file^.file_id,
            ice$no_job_spec_variable, operation, fetch_access [1].user_info,
            status);
      RETURN;
    IFEND;
    icp$get_next_cv (ptr, clvar, len);
    IF (ptr = NIL) OR (len = 0) THEN
      amp$set_file_instance_abnormal (icf_file^.file_id,
            ice$empty_job_spec_variable, operation, '', status);
      RETURN;
    IFEND;
    z_rec_length := icc$max_partner_image_length - icc$validation_image_length;

{ Convert all validation info to a 170 display code string
    icp$convert (ptr, len, ^validation_information.job, z_rec_index, 10, stat);
    rhp$get_link_user_descriptor (liu_stuff, stat);
    ptr := ^liu_stuff.user;
    icp$convert (ptr, 9, ^validation_information.user_name, z_rec_index, 2,
          stat);
    ptr := ^liu_stuff.password;
    icp$convert (ptr, 31, ^validation_information.password, z_rec_index, 4,
          stat);
    ptr := ^liu_stuff.family;
    icp$convert (ptr, 9, ^validation_information.family_name, z_rec_index, 2,
          stat);
    ptr := ^liu_stuff.charge;
    icp$convert (ptr, 31, ^validation_information.charge_number, z_rec_index,
          4, stat);
    ptr := ^liu_stuff.project;
    icp$convert (ptr, 31, ^validation_information.project_number, z_rec_index,
          4, stat);
    PUSH get_attribute_p: [1 .. 4];
    get_attribute_p^ [1].key := jmc$login_family;
    get_attribute_p^ [2].key := jmc$login_user;
    get_attribute_p^ [3].key := jmc$login_account;
    get_attribute_p^ [4].key := jmc$login_project;
    jmp$get_job_attributes (get_attribute_p, stat);

    IF NOT stat.normal THEN
      pmp$exit (stat);
    IFEND;

{ We also need to convert the original login USER, FAMILY, ACCOUNT, and
{ PROJECT.
    ptr := ^get_attribute_p^ [2].login_user;
    icp$convert (ptr, 9, ^validation_information.original_user_name,
          z_rec_index, 2, stat);
    ptr := ^get_attribute_p^ [1].login_family;
    icp$convert (ptr, 9, ^validation_information.original_family_name,
          z_rec_index, 2, stat);
    ptr := ^get_attribute_p^ [3].login_account;
    icp$convert (ptr, 31, ^validation_information.original_charge_number,
          z_rec_index, 4, stat);
    ptr := ^get_attribute_p^ [4].login_project;
    icp$convert (ptr, 31, ^validation_information.original_project_number,
          z_rec_index, 4, stat);
    z_rec := ^rec;
    stat.normal := TRUE;
    icp$get_next_cv (ptr, clvar, len);
    nos_card_counter := 1;
    WHILE (ptr <> NIL) AND (stat.normal) DO
      icp$convert (ptr, len, z_rec, z_rec_index, z_rec_length, stat);
      z_rec := i#ptr (z_rec_index * 8, z_rec);
      z_rec_length := z_rec_length - z_rec_index;
      icp$get_next_cv (ptr, clvar, len);
      nos_card_counter := nos_card_counter + 1;
    WHILEND;
    IF NOT stat.normal THEN
      amp$set_file_instance_abnormal (icf_file^.file_id,
            ice$partner_job_too_long, operation, '', status);
      osp$append_status_integer (osc$status_parameter_delimiter,
            nos_card_counter, 10, FALSE, status);
      RETURN;
    IFEND;
    z_rec_length := z_rec_length + icc$validation_image_length;
    icp$initiate_partner_job ((icc$max_partner_image_length - z_rec_length),
          ^rec, 1, ^icf_file^.application_name, icc$validation_image_length,
          ^validation_information, icf_file^.partner_id, stat);
    IF NOT stat.normal THEN
      amp$set_file_instance_abnormal (icf_file^.file_id,
            ice$partner_cannot_be_started, operation, '', status);
      RETURN;
    IFEND;

{  Permit the 170 partner job to send to us.

  /loop_2/
    WHILE TRUE DO
      mlp$add_sender (icf_file^.application_name,
            icf_file^.partner_id.application_name, stat);

      IF (stat.normal) OR (stat.condition = mlc$ok) OR
            (stat.condition = mlc$receiver_not_signed_on) THEN
        EXIT /loop_2/;
      ELSE
        CASE stat.condition OF
        = mlc$busy_interlock =
          pmp$wait (icf_short_interval, icf_short_interval);
          CYCLE /loop_2/;
        ELSE
          icp$set_status_abnormal (stat);
          pmp$exit (stat);
        CASEND;
      IFEND;
    WHILEND /loop_2/;

  PROCEND icp$open;
MODEND icm$open;
