home *** CD-ROM | disk | FTP | other *** search
/ Columbia Kermit / kermit.zip / old / misc / prime / prime814.src < prev    next >
Text File  |  2020-01-01  |  285KB  |  9,081 lines
  1.  
  2. /* KERMIT.BUILD.CPL -- Build file for PRIME Kermit. */
  3.  
  4. &severity &error &routine err
  5. /*
  6. &args rest_of_line : uncl; compile : -c, -comp, -compile fn : entry = @.plp; ~
  7.       como : -como como_file : tree = kermit.build.como; load : -l, -load; ~
  8.       no_compress : -noc, -no_compress; rebuild : -r, -reb, -rebuild; ~
  9.       help : -h, -help, -u, -usage
  10. /*
  11. &if [null %compile%%load%%rebuild%] &then ~
  12.     &s help := HELP
  13. /*
  14. &if ^ [null %help%] &then ~
  15.     &do
  16.        &call print_help
  17.        &stop
  18.     &end
  19. /*
  20. &if ^ [null %rebuild%] &then ~
  21.     &do
  22.        &s compile := true
  23.        &s load := true
  24.     &end
  25. /*
  26. &if [null %no_compress%] & [index [quote %rest_of_line%] -debug] = 0 &then ~
  27.     &s compress := compress
  28. &else ~
  29.     &s compress :=
  30. /*
  31. &if ^ [null %como%] &then ~
  32.     &do
  33.        &debug &echo com
  34.        como %como_file%
  35.        date
  36.     &end
  37. /*
  38. &if ^ [null %compile%] &then ~
  39.     &do
  40.        &if [index [quote %rest_of_line%] -b] = 0 &then ~
  41.            &s binary := -b *>obj>=.+bin
  42.        &else ~
  43.            &s binary :=
  44.  
  45.        &if ^ [exists *>obj -dir] &then ~
  46.            create *>obj
  47.        &else ~
  48.            &if ^ [null %rebuild%] &then ~
  49.                delete  *>obj>@@ -nvfy -force
  50. /*
  51.        &if [entryname %fn%] = %fn% &then   /* [dir %fn%] = *, doesn't work. ~
  52.            &s fn := *>source>%fn%
  53. /*
  54.        plp %fn% %binary% %rest_of_line%
  55.     &end
  56. /*
  57. &if ^ [null %load%] &then ~
  58.     &data bind
  59.           lo *>obj>kermit
  60.           lo *>obj>kermit_init
  61.           lo *>obj>bk_hndlr
  62.           lo *>obj>timeout_hndlr
  63.           lo *>obj>ren_hndlr
  64.           lo *>obj>get_user_info
  65.           lo *>obj>comnd
  66.           lo *>obj>server
  67.           lo *>obj>generic_cmd
  68.           lo *>obj>rec_switch
  69.           lo *>obj>rec_packet
  70.           lo *>obj>get_response
  71.           lo *>obj>send_switch
  72.           lo *>obj>send_packet
  73.           lo *>obj>connect
  74.           lo *>obj>rec_amlc
  75.           lo *>obj>send_amlc
  76.           lo *>obj>input
  77.           lo *>obj>utilities
  78.           lo *>obj>chks
  79.           lo *>obj>ack_send_init
  80.           lo *>obj>prs_send_init
  81.           lo *>obj>set_params
  82.           lo *>obj>set_path
  83.           lo *>obj>read_input
  84.           lo *>obj>write_output
  85.           lo *>obj>write_ibuf
  86.           lo *>obj>log_packet
  87.           lo *>obj>log_info
  88.           lo *>obj>next_file
  89.           lo *>obj>setup_trans_char
  90.           lo *>obj>get_attr
  91.           lo *>obj>get_dtc
  92.           lo *>obj>get_len
  93.           lo *>obj>change_dir
  94.           lo *>obj>open_input
  95.           lo *>obj>open_output
  96.           lo *>obj>close_input
  97.           lo *>obj>close_output
  98.           lo *>obj>discard_output
  99.           lo *>obj>open_log
  100.           lo *>obj>match_file
  101.           lo *>obj>assign
  102.           lo *>obj>xfer_mode
  103.           lo *>obj>get_error_msg
  104.           lo *>obj>convert_file
  105.           li
  106.           dynt -all
  107.           rdc
  108.           nwc
  109.           &if ^ [null %compress%] &then ~
  110.           %compress%
  111.           map -undefined
  112.           file
  113.     &end
  114. /*
  115. &if ^ [null %como%] &then ~
  116.     como -e
  117. /*
  118. &stop
  119. /*
  120. &routine err
  121. /*
  122. type Error detected in Kermit build.
  123. /*
  124. &if ^ [null %como%] &then ~
  125.     como -e
  126. /*
  127. &stop
  128. /*
  129. &routine print_help
  130. /*
  131. type
  132. ~type ' Usage : CPL KERMIT.BUILD  [-Compile [path_name]]  [-Load]  [-Rebuild]'
  133. ~type '                           [-COMO [como_file]]  [-NO_Compress] [-Help]'
  134. type
  135. type '         Where "path_name" is a Kermit source file path name which'
  136. type '         defaults to "*>SOURCE>@.PLP", and "como_file" is a COMO path'
  137. type '         name which defaults to "*>KERMIT.BUILD.COMO".'
  138. type
  139. /*
  140. &return
  141. -------------------------------------------------------------------------------
  142.  
  143. /* COMMON.INS.PLP -- Variables held in common storage for Kermit. */
  144.  
  145. %nolist;
  146.  
  147. %Replace max_msg by 100,
  148.          max_msg_less1 by 99,
  149.          max_matches by 100,
  150.          max_rem_pad_chrs by 255,
  151.          ibuffer_size by 1024,
  152.          ibuffer_size_wds by 512,
  153.          max_take_level by 25;
  154.  
  155.                      /* Message variables. */
  156.  
  157. Dcl snd_msg char (max_msg) var external,
  158.     msg_number fixed bin external,
  159.  
  160.     rec_msg char (max_msg) var external,
  161.     rec_pkt_type char (1) aligned external,   /* Type of message received. */
  162.     rec_seq fixed bin external,
  163.     rec_length fixed bin external,
  164.  
  165.     rec_file_size fixed bin (31) external,    /* Received file attributes. */
  166.     rec_file_dtc fixed bin (31) external,
  167.     rec_file_type fixed bin external,
  168.     use_attributes bit (1) aligned external,  /* Do we use the attributes ? */
  169.  
  170.     1 msg_table external,           /* Packet table for windowing. */
  171.       2 slot (0 : 63),
  172.         3 msg char (max_msg) var,
  173.         3 acked bit (1) aligned,
  174.         3 retries fixed bin,
  175.  
  176.     tab_first fixed bin external,       /* First msg in the table. */
  177.     tab_next fixed bin external;        /* Position of next msg. */
  178.  
  179.                /* File transfer status variables. */
  180.  
  181. Dcl state fixed bin external,              /* Current state. */
  182.     delay fixed bin external,              /* Amount of time to delay. */
  183.     num_retries fixed bin external,        /* Number of retries. */
  184.     max_retries fixed bin external,        /* Maximum number of retries. */
  185.     quote8_char char (1) external,         /* 8-bit quoting character. */
  186.     file_type fixed bin external,          /* File storage type. */
  187.     explicit_ft_set bit (1) aligned external, /* File type has been set. */
  188.     first_write bit (1) aligned external,  /* First write of the data. */
  189.     filename_warning bit (1) aligned external, /* File re-naming warning. */
  190.     do_repeats bit (1) aligned external,   /* TRUE if repeat processing. */
  191.     do_transparent bit (1) aligned external, /* TRUE when transparent. */
  192.     do_flush bit (1) aligned external,     /* Flush rcv buffer when sending. */
  193.     do_8bit_chks bit (1) aligned external, /* TRUE for none parity. */
  194.     auto_sum bit (1) aligned external,     /* Try 7 and 8-bit checksums. */
  195.     packet_log_opened bit (1) aligned external,  /* Packet log file opened. */
  196.     packet_log_unit fixed bin external,          /* Packet log file unit. */
  197.     packet_log_pathname char (128) var external,  /* Packet log pathname. */
  198.     session_log_opened bit (1) aligned external, /* Session log file opened. */
  199.     session_log_unit fixed bin external,         /* Session log file unit. */
  200.     session_log_pathname char (128) var external,  /* Session log pathname. */
  201.     session_log_save_line char (256) var external, /* Session log data. */
  202.     window_size fixed bin external,        /* Transmission window size. */
  203.     errmsg char (128) var external,        /* Error message buffer. */
  204.  
  205.     timeout label external,                /* Return point on timeout. */
  206.     brk_lbl label external,                /* Return point on break. */
  207.     ren_lbl label external,                /* Return point on re-enter. */
  208.  
  209.     take_level fixed bin external,         /* Number of TAKE files open. */
  210.     take_unit (max_take_level) fixed bin external; /* TAKE file units used. */
  211.  
  212.                      /* Local parameters. */
  213.  
  214. Dcl loc_pkt_size fixed bin external,        /* Receive packet size. */
  215.     loc_npad fixed bin external,            /* Padding length. */
  216.     loc_padchar char (1) external,          /* Padding character. */
  217.     loc_timeout fixed bin external,         /* Time out. */
  218.     loc_eol char (1) external,              /* Eol character. */
  219.     loc_quote_chr char (1) external,        /* Quote character. */
  220.     loc_8quote_chr char (1) external,       /* 8-bit quoting character. */
  221.     loc_chk_type char (1) external,         /* Checksum type. */
  222.     loc_rep_chr char (1) external,          /* Repeat character. */
  223.     loc_capas1 fixed bin external,          /* Capabilities byte 1. */
  224.     loc_file_attrib bit (1) aligned external, /* Ability to rcv attributes. */
  225.     loc_max_wsize fixed bin external;       /* Max window size. */
  226.  
  227.                     /* Remote parameters. */
  228.  
  229. Dcl rem_pkt_size fixed bin external,        /* Send packet size. */
  230.     rem_npad fixed bin external,            /* Padding length. */
  231.     rem_padchar char (1) external,          /* Padding character. */
  232.     rem_pad_chars char (max_rem_pad_chrs) external,
  233.                                             /* String of padding characters. */
  234.     rem_timeout fixed bin external,         /* Time out. */
  235.     rem_eol char (1) external,              /* Eol character. */
  236.     rem_quote_chr char (1) external,        /* Quote character. */
  237.     rem_8quote_chr char (1) external,       /* 8-bit quoting character. */
  238.     rem_chk_type char (1) external,         /* Checksum type. */
  239.     rem_rep_chr char (1) external,          /* Repeat character. */
  240.     rem_capas1 fixed bin external,          /* Capabilities byte 1. */
  241.     rem_file_attrib bit (1) aligned external, /* Ability to rcv attributes. */
  242.     rem_windowing bit (1) aligned external, /* Ability to do windowing. */
  243.     rem_max_wsize fixed bin external;       /* Max window size. */
  244.  
  245.                     /* User Interface. */
  246.  
  247. Dcl kversion char (32) var external,        /* Kermit version number. */
  248.     kprompt char (32) var external,         /* Kermit command prompt. */
  249.     kprompt_len fixed bin external,         /* Kermit prompt length. */
  250.     in_init_file bit (1) aligned external,  /* In the initialization file. */
  251.     kermit_init_file char (128) var external,
  252.     uppercase char (26) static external init ('ABCDEFGHIJKLMNOPQRSTUVWXYZ'),
  253.     lowercase char (26) static external init ('abcdefghijklmnopqrstuvwxyz');
  254.  
  255.                     /* File Variables. */
  256.  
  257. Dcl path_name char (128) var external,       /* Current path name. */
  258.     dir_name char (128) var external,        /* Current directory name. */
  259.     non_null_dir bit (1) aligned external,   /* Directory name is not null ? */
  260.     file_name char (32) var external,        /* Current file name. */
  261.     alternate_fname char (32) var external,  /* Alternate file name. */
  262.     file_unit fixed bin external,            /* File unit. */
  263.     file_opened bit (1) aligned external,    /* Flag for open files. */
  264.     file_len fixed bin (31) external,        /* File length (bytes). */
  265.     file_pos fixed bin (31) external,        /* File position (bytes). */
  266.     space_count fixed bin external,          /* Space compression count. */
  267.     ignore_next bit (1) aligned external,    /* Ignore next char after LF. */
  268.     next_is_lf bit (1) aligned external,     /* Next char must be LF. */
  269.     saved_msg char (6) var external,         /* Saved part of packet. */
  270.     saved_char char (1) var external,        /* Saved last char from buffer. */
  271.  
  272.     matches(max_matches) char (128) var external, /* Pathname list. */
  273.     num_matches fixed bin external,          /* Number matches found. */
  274.     file_idx fixed bin external,             /* Index into matches. */
  275.  
  276.     del_incomplete bit (1) aligned external, /* Delete incomplete files. */
  277.     ibuffer char (ibuffer_size) external,    /* Intermediate file buffer. */
  278.     ibuffer_ptr ptr external,                /* Pointer to int_buffer. */
  279.     ibuflen fixed bin external,              /* Length of int_buffer. */
  280.     ibuf_ptr fixed bin external,             /* Pointer into int_buffer. */
  281.     char2 (2) char (1) unal external,        /* Two character buffer. */
  282.     char2_ptr ptr external,                  /* And its pointer. */
  283.     pound_conversion bit (1) aligned external, /* Convert DOS pound signs. */
  284.     explicit_pound_set bit (1) aligned external, /* True if SET POUND used. */
  285.     trans_char (0 : 255) char (3) var external; /* Translation table. */
  286.  
  287.                       /* User Environment. */
  288.  
  289. Dcl my_msg_state fixed bin external,
  290.     my_duplex bit (16) aligned external,
  291.     my_half_duplex bit (16) aligned external,
  292.     my_user_number fixed bin external,
  293.     my_erase char (2) external,
  294.     my_kill char (2) external,
  295.     my_new_erase char (2) external,
  296.     my_new_kill char (2) external;
  297.  
  298.                        /* Character codes. */
  299.  
  300. Dcl nul_7bit_asc char (1) external,
  301.     nul_8bit_asc char (1) external,
  302.     ctrl_a_7bit_asc char (1) external,
  303.     ctrl_a_8bit_asc char (1) external,
  304.     bs_7bit_asc char (1) external,
  305.     bs_8bit_asc char (1) external,
  306.     cr_7bit_asc char (1) external,
  307.     cr_8bit_asc char (1) external,
  308.     lf_7bit_asc char (1) external,
  309.     lf_8bit_asc char (1) external,
  310.     ff_7bit_asc char (1) external,
  311.     dc1_8bit_asc char (1) external,
  312.     ctrl_z_7bit_asc char (1) external,
  313.     ctrl_z_8bit_asc char (1) external,
  314.     space_7bit_asc char (1) external,
  315.     query_7bit_asc char (1) external,
  316.     grave_7bit_asc char (1) external,
  317.     del_8bit_asc char (1) external;
  318.  
  319.                        /* Assigned line variables. */
  320.  
  321. Dcl use_amlc_line bit (1) aligned external,
  322.     escape_char char (1) external,
  323.     abort_char char (1) external,
  324.     break_char char (1) external,
  325.     saved_amlc_chrs char (128) var external,
  326.     amlc_line fixed bin external,
  327.     baud_rate fixed bin (31) external,
  328.     baud_rate_index fixed bin external;
  329.  
  330. %list;
  331.  
  332. /* End of COMMON.INS.PLP */
  333. -------------------------------------------------------------------------------
  334.  
  335. /* CONSTANTS.INS.PLP -- Constant values used by KERMIT. */
  336.  
  337. %nolist;
  338.  
  339. %Replace                                 /* Protocol states. */
  340.  
  341.     state_s by 1,                        /* Send init state. */
  342.     state_sf by 2,                       /* Send file header. */
  343.     state_sd by 3,                       /* Send file data packet. */
  344.     state_sz by 4,                       /* Send EOF packet. */
  345.     state_sb by 5,                       /* Send break. */
  346.     state_r by 6,                        /* Receive send_init. */
  347.     state_rf by 7,                       /* Receive file header packet. */
  348.     state_rd by 8,                       /* Receive file data packet. */
  349.     state_x by 9,                        /* Text send init. */
  350.     state_xf by 10,                      /* Text header. */
  351.     state_c by 11,                       /* Send complete. */
  352.     state_a by 12,                       /* Abort. */
  353.     state_ra by 13,                      /* Receive attributes. */
  354.     state_sa by 14,                      /* Send attributes. */
  355.     state_rdw by 15,                     /* Rec data windowing. */
  356.     state_sdw by 16;                     /* Send data windowing. */
  357.  
  358. %Replace                                 /* Status codes. */
  359.  
  360.     ker_normal by 0,
  361.     ker_internalerr by 1,
  362.     ker_eof by 2,
  363.     ker_nomorfiles by 3,
  364.     ker_illfiltyp by 4,
  365.     ker_exit by 5,
  366.     ker_unimplgen by 6,
  367.     ker_protoerr by 7;
  368.  
  369. %Replace                                 /* Message constants. */
  370.  
  371.     pkt_count by 2,                      /* <CHAR(Count)> */
  372.     pkt_seq by 3,                        /* <CHAR(Seq)> */
  373.     pkt_type by 4,                       /* <Message type> */
  374.     pkt_msg by 5,                        /* <MESSAGE-DEPENDENT INFORMATION> */
  375.  
  376.     pkt_ovr_head by 3,                   /* Overhead added to data length. */
  377.     pkt_tot_ovr_head by 6;               /* Total overhead of the message. */
  378.  
  379. %Replace                                 /* Message types. */
  380.  
  381.     msg_data by 'D',                     /* Data packet. */
  382.     msg_attrib by 'A',                   /* File attributes. */
  383.     msg_ack by 'Y',                      /* Acknowledgement. */
  384.     msg_nak by 'N',                      /* Negative acknowledgement. */
  385.     msg_snd_init by 'S',                 /* Send initiate. */
  386.     msg_break by 'B',                    /* Break transmission. */
  387.     msg_file by 'F',                     /* File header. */
  388.     msg_eof by 'Z',                      /* End of file (EOF). */
  389.     msg_error by 'E',                    /* Error. */
  390.     msg_rcv_init by 'R',                 /* Receive initiate. */
  391.     msg_host_command by 'C',             /* Host command. */
  392.     msg_text by 'X',                     /* Plain Text. */
  393.     msg_init_info by 'I',                /* Initialize parameters. */
  394.     msg_kermit by 'K',                   /* Interactive KERMIT command. */
  395.     msg_kermit_generic by 'G',           /* Generic KERMIT command. */
  396.     msg_timeout by 'T',                  /* Timeout. */
  397.     msg_check_err by 'Q';                /* Checksum error. */
  398.  
  399. %Replace                                 /* Generic commands. */
  400.  
  401.     msg_gen_login by 'I',                /* Login. */
  402.     msg_gen_finish by 'F',               /* Finish (exit to OS). */
  403.     msg_gen_cwd by 'C',                  /* Change Working Directory. */
  404.     msg_gen_logout by 'L',               /* Logout. */
  405.     msg_gen_directory by 'D',            /* List the directory. */
  406.     msg_gen_disk_usage by 'U',           /* Disk usage. */
  407.     msg_gen_delete by 'E',               /* Delete a file. */
  408.     msg_gen_type by 'T',                 /* Type a file. */
  409.     msg_gen_rename by 'R',               /* Rename file. */
  410.     msg_gen_copy by 'K',                 /* Copy file. */
  411.     msg_gen_program by 'P',              /* Program invocation. */
  412.     msg_gen_who by 'W',                  /* Who's logged in. */
  413.     msg_gen_send by 'M',                 /* Send a message to a user. */
  414.     msg_gen_help by 'H',                 /* Help. */
  415.     msg_gen_query by 'Q',                /* Query status. */
  416.     msg_gen_journal by 'J',              /* Transaction Journal. */
  417.     msg_gen_variable by 'V';             /* Set/Read Variables. */
  418.  
  419. /*
  420.  *                    INITIALIZATION PACKET FORMAT.
  421.  *
  422.  *           The following describes the send initiate packet.
  423.  *           All fields in the message data area are optional.
  424.  *
  425.  * <"S"><CHAR(Bufsiz)><CHAR(Timeout)><CHAR(npad)><CTL(pad)><CHAR(Eol)><Quote>
  426.  *       <8-bit-quote><Repeat><Reserved><Reserved><Reserved>
  427.  *
  428.  * Bufsiz
  429.  *    Sending Kermit's maximum buffer size.
  430.  *
  431.  * Timeout
  432.  *    Number of seconds after which the sending Kermit wishes to be timed out.
  433.  *
  434.  * Npad
  435.  *    Number of padding characters the sending Kermit needs before each packet.
  436.  *
  437.  * PAD
  438.  *    Padding character.
  439.  *
  440.  * EOL
  441.  *    A line terminator required on all packets set by the receiving Kermit.
  442.  *
  443.  * Quote
  444.  *    The printable ASCII character the sending Kermit will use when quoting
  445.  *    the control characters. Default is "#".
  446.  *
  447.  * 8-bit-quote
  448.  *    Specify quoting mechanism for 8-bit quantities. A quoting mechanism is
  449.  *    necessary when sending to hosts which prevent the use of the 8th bit for
  450.  *    data. When elected, the quoting mechanism will be used by both hosts,
  451.  *    and the quote character must be in the range of 41-76 or 140-176 octal,
  452.  *    but different from the control-quoting character. This field is
  453.  *    interpreted as follows :
  454.  *
  455.  *       "Y" - I agree to 8-bit quoting if you request it,
  456.  *       "N" - I will not do 8-bit quoting,
  457.  *       "&" - (or any other character in the range of 41-76 or 140-176) I want
  458.  *             to do 8-bit quoting using this character (it will be done if the
  459.  *             other Kermit puts a "Y" in this field),
  460.  *       Anything else : Quoting will not be done.
  461.  *
  462.  * Repeat
  463.  *    A printable ASCII character for compressing repeated characters.
  464.  *    The default is "~". A " " means no repeat character processing, also
  465.  *    it will only be done if both sides request it with the same character.
  466.  */
  467.  
  468. %Replace                                 /* Positions within the packet. */
  469.  
  470.     p_si_bufsiz by 0,                    /* Buffer size. */
  471.     p_si_timout by 1,                    /* Time out. */
  472.     p_si_npad by 2,                      /* Number of padding characters. */
  473.     p_si_pad by 3,                       /* Padding character. */
  474.     p_si_eol by 4,                       /* End of line character. */
  475.     p_si_quote by 5,                     /* Quoting character. */
  476.     p_si_8quote by 6,                    /* 8-bit quoting character. */
  477.     p_si_chk by 7,                       /* Checksum type. */
  478.     p_si_rep by 8,                       /* Repeat character. */
  479.     p_si_capas by 9;                     /* Capabilities. */
  480.  
  481. %Replace                                 /* Default initialization values. */
  482.  
  483.     my_pkt_size by 94,                   /* My packet size. */
  484.     my_timeout by 15,                    /* My time out. */
  485.     my_npad by 0,                        /* Amount of padding I require. */
  486.     my_pad_chr by '00'b4,                /* My pad character. */
  487.     my_eol_chr by '8D'b4,                /* My EOL character. <CR> */
  488.     my_quote_chr by '#',                 /* My quoting character. */
  489.     my_8quote_chr by '&',                /* My 8-bit quote character. */
  490.     my_chk_type by '1',                  /* My checksum type => single char. */
  491.     my_rep_chr by '~',                   /* My repeat character prefix. */
  492.     my_capas1 by '0C'b4,                 /* My capabilities => attr+windows. */
  493.     my_max_wsize by 6;                   /* My default window size. */
  494.  
  495. %Replace                                 /* File types. */
  496.  
  497.     automatic_ft by -1,                  /* AUTOMATIC file type detection. */
  498.     illegal_ft by 0,                     /* An ILLEGAL file type. */
  499.     ascii_ft by 1,                       /* ASCII/TEXT files. */
  500.     binary_ft by 2;                      /* BINARY/IMAGE files. */
  501.  
  502. %Replace                                 /* Miscellaneous values. */
  503.  
  504.     true by '1'b,                        /* Logical .TRUE. */
  505.     false by '0'b,                       /* Logical .FALSE. */
  506.     default_delay by 5,                  /* Initial delay time. */
  507.     default_max_retries by 5,            /* Maximum number of retries. */
  508.     bignum by 2147483647,                /* The biggest fixed bin number. */
  509.     current_attach_point by -1,          /* File unit of current a.p. */
  510.     default_lword by 'E000'b4,           /* Default async lword. */
  511.     default_config by '04CB'b4,          /* Default async line configuration. */
  512.     default_packet_log by '*>PACKET.LOG',   /* Default packet log path name. */
  513.     default_session_log by '*>SESSION.LOG', /* Default session log path name. */
  514.     default_kermit_init_fname by '*>PRIME_KERMIT.INIT', /* Default init file. */
  515.  
  516.     ctrl_a_7bit_dec by '01'b4,           /* Control-A */
  517.     ctrl_a_8bit_dec by '81'b4,
  518.     cr_7bit_dec by '0D'b4,               /* Carriage Return */
  519.     cr_8bit_dec by '8D'b4,
  520.     lf_7bit_dec by '0A'b4,               /* Line Feed */
  521.     lf_8bit_dec by '8A'b4,
  522.  
  523.     space_8bit_asc by ' ',
  524.     query_8bit_asc by '?',
  525.     grave_8bit_asc by '`',
  526.  
  527.     packet_log by 1,
  528.     session_log by 2,
  529.  
  530.     enc110 by '000'b,                    /* Baud rate encryption bits. */
  531.     enc134 by '001'b,                    /* Actually 134.5 bps. */
  532.     enc300 by '010'b,
  533.     enc1200 by '011'b,
  534.     enc_clock by '100'b,                 /* Default 9600 */
  535.     enc_j1 by '101'b,                    /* Default 75 */
  536.     enc_j2 by '110'b,                    /* Default 150 */
  537.     enc_j3 by '111'b;                    /* Default 1800 */
  538.  
  539. %list;
  540.  
  541. /* End of CONSTANTS.INS.PLP */
  542. -------------------------------------------------------------------------------
  543.  
  544. /* KERMIT.INS.PLP -- Kermit declarations. */
  545.  
  546. /* This insert file contains all the declarations for the Kermit
  547.    subroutines and functions. It also contains some based variables. */
  548.  
  549. %nolist;
  550.  
  551. Dcl ack_send_init entry,
  552.     assign entry (fixed bin, fixed bin, fixed bin),
  553.     bk_hndlr entry (ptr),
  554.     change_dir entry (char (128) var, fixed bin),
  555.     chks entry (fixed bin, char (*) var) returns (fixed bin),
  556.     close_input entry,
  557.     close_output entry returns (fixed bin),
  558.     comnd entry,
  559.     connect entry (fixed bin),
  560.     convert_file entry returns (fixed bin),
  561.     discard_output entry (fixed bin),
  562.     generic_cmd entry returns (fixed bin),
  563.     get_attr entry,
  564.     get_dtc entry returns (char (32) var),
  565.     get_error_msg entry (fixed bin),
  566.     get_len entry (bit (1) aligned) returns (fixed bin),
  567.     get_response entry returns (bit (1) aligned),
  568.     get_user_info entry,
  569.     input entry (char (*) var, fixed bin) returns (bit (1) aligned),
  570.     log_info entry (fixed bin, char (256) var),
  571.     log_packet entry (char (1), fixed bin, char (*) var),
  572.     match_file entry returns (fixed bin),
  573.     kermit_init entry,
  574.     next_file entry returns (fixed bin),
  575.     open_input entry returns (fixed bin),
  576.     open_log entry (fixed bin, char (128) var) returns (fixed bin),
  577.     open_output entry returns (fixed bin),
  578.     prs_send_init entry,
  579.     read_input entry (fixed bin) returns (fixed bin),
  580.     rec_amlc entry (fixed bin, char (*), fixed bin, fixed bin) returns
  581.                    (fixed bin),
  582.     rec_packet entry,
  583.     rec_switch entry,
  584.     ren_hndlr entry (ptr),
  585.     send_amlc entry (fixed bin, char (*), fixed bin) returns (fixed bin),
  586.     send_packet entry (char (1), fixed bin, fixed bin),
  587.     send_switch entry,
  588.     server entry,
  589.     set_params entry,
  590.     set_path entry (char (128) var),
  591.     setup_trans_char entry,
  592.     timeout_hndlr entry (ptr),
  593.     write_ibuf entry (fixed bin, fixed bin),
  594.     write_output entry returns (fixed bin),
  595.     xfer_mode entry (fixed bin, fixed bin);
  596.  
  597.                     /* Kermit utilities. */
  598.  
  599. Dcl between entry (fixed bin, fixed bin, fixed bin) returns (bit (1) aligned),
  600.     clr8 entry (char (1)) returns (char (1)),
  601.     clr8str entry (char (*) var) returns (char (1024) var),
  602.     ctl entry (char (1)) returns (char (1)),
  603.     ctl_trans entry (bit (1) aligned, char (*) var) returns (char (128) var),
  604.     knum entry (char (1)) returns (fixed bin),
  605.     more entry returns (bit (1) aligned),
  606.     set8 entry (char (1)) returns (char (1)),
  607.     set8str entry (char (*) var) returns (char (1024) var);
  608.  
  609.                     /* Based variables. */
  610.  
  611. Dcl fb15_based fixed bin (15) based,
  612.     fb31_based fixed bin (31) based,
  613.     char1_based char (1) based,
  614.     char2_based char (2) based,
  615.     bit8_based bit (8) aligned based,
  616.     bit16_based bit (16) aligned based,
  617.  
  618.     1 capas based,                     /* Capability structure. */
  619.       2 rsv2 bit (12),
  620.       2 file_attributes bit (1),
  621.       2 windowing bit (1),
  622.       2 rsv1 bit (1),
  623.       2 continues bit (1);
  624.  
  625. %list;
  626.  
  627. /* End of KERMIT.INS.PLP */
  628. -------------------------------------------------------------------------------
  629.  
  630. /* PRIMOS.INS.PLP -- PRIMOS declarations. */
  631.  
  632. /* This insert file contains all the PRIMOS subroutine and function
  633.    declarations. It also contains the directory entries structure. */
  634.  
  635. %nolist;
  636.  
  637. Dcl asnln$ entry (fixed bin, fixed bin, char (6), bit (16) aligned, fixed bin,
  638.                   fixed bin),
  639.     as$set entry (fixed bin, fixed bin, fixed bin, ptr, ptr, fixed bin,
  640.                   fixed bin, fixed bin),
  641.     at$ entry (fixed bin, char (*) var, fixed bin),
  642.     at$hom entry (fixed bin),
  643.     at$or entry (fixed bin, fixed bin),
  644.     c1in entry ((2) char (1) unal),
  645.     cl$get entry (char (*) var, fixed bin, fixed bin),
  646.     cl$pix entry (bit (16) aligned, char (*) var, ptr, fixed bin, char (*) var,
  647.                   ptr, fixed bin, fixed bin, fixed bin),
  648.     clo$fu entry (fixed bin, fixed bin),
  649.     cnam$$ entry (char (*), fixed bin, char (*), fixed bin, fixed bin,
  650.                   fixed bin),
  651.     cnin$ entry (char (*), fixed bin, fixed bin),
  652.     comi$$ entry (char (*), fixed bin, fixed bin, fixed bin),
  653.     comlv$ entry,
  654.     cv$dtb entry (char (*) var, fixed bin (31), fixed bin),
  655.     cv$fda entry (fixed bin (31), fixed bin, char (21)),
  656.     date$ entry returns (fixed bin (31)),
  657.     dir$rd entry (fixed bin, fixed bin, ptr, fixed bin, fixed bin),
  658.     ds$avl entry (ptr, fixed bin, fixed bin),
  659.     duplx$ entry (bit (16) aligned) returns (bit (16) aligned),
  660.     ent$rd entry (fixed bin, char (*) var, ptr, fixed bin, fixed bin),
  661.     erkl$$ entry (fixed bin, char (2), char (2), fixed bin),
  662.     ertxt$ entry (fixed bin, char (*) var),
  663.     fil$dl entry (char (*) var, fixed bin),
  664.     finfo$ entry (fixed bin, ptr, fixed bin),
  665.     fnchk$ entry (fixed bin, char (*) var) returns (bit (1) aligned),
  666.     gpath$ entry (fixed bin, fixed bin, char (128), fixed bin, fixed bin,
  667.                   fixed bin),
  668.     ioa$ entry options (variable),
  669.     ioa$rs entry options (variable),
  670.     limit$ entry (fixed bin, fixed bin (31), fixed bin, fixed bin),
  671.     logo$$ entry (fixed bin, fixed bin, char (*), fixed bin, fixed bin (31),
  672.                   fixed bin),
  673.     mgset$ entry (fixed bin, fixed bin),
  674.     mkonu$ entry (char (*) var, entry) options (shortcall (20)),
  675.     msg$st entry (fixed bin, fixed bin, char (*), fixed bin, char (*),
  676.                   fixed bin, fixed bin),
  677.     pri$rv entry (char (*) var),
  678.     prwf$$ entry (fixed bin, fixed bin, ptr options (short), fixed bin,
  679.                   fixed bin (31), fixed bin, fixed bin),
  680.     q$read entry (char (*) var, (4) fixed bin (31), fixed bin, fixed bin,
  681.                   fixed bin),
  682.     satr$$ entry (fixed bin, char (*), fixed bin, fixed bin (31), fixed bin),
  683.     sleep$ entry (fixed bin (31)),
  684.     smsg$ entry (fixed bin, char (32), fixed bin, fixed bin, char (*),
  685.                  fixed bin, char (*), fixed bin, (4) fixed bin),
  686.     srch$$ entry (fixed bin, char (*), fixed bin, fixed bin, fixed bin,
  687.                   fixed bin),
  688.     srsfx$ entry (fixed bin, char (*) var, fixed bin, fixed bin, fixed bin,
  689.                   char (*) var, char (*) var, fixed bin, fixed bin),
  690.     t$amlc entry (fixed bin, ptr options (short), fixed bin, fixed bin,
  691.                   (2) fixed bin, fixed bin, fixed bin),
  692.     timdat entry (1, fixed bin),
  693.     tnchk$ entry (fixed bin, char (*) var) returns (bit (1) aligned),
  694.     tnou entry (char (*), fixed bin),
  695.     tnoua entry (char (*), fixed bin),
  696.     tonl entry,
  697.     tty$in entry returns (bit (1) aligned),
  698.     tty$rs entry (fixed bin, fixed bin),
  699.     uid$bt entry (char (6) aligned),
  700.     uid$ch entry (char (6) aligned, char (13)),
  701.     user$ entry (fixed bin, fixed bin),
  702.     wild$ entry (char (*) var, char (*) var, fixed bin) returns
  703.                 (bit (1) aligned),
  704.     wtlin$ entry (fixed bin, char (*), fixed bin, fixed bin);
  705.  
  706. Dcl old_primos_revision bit (1) aligned external;  /* True if Pre-rev 22. */
  707.  
  708. %Replace dir_entry_size by 37;   /* Correct size at PRIMOS revision 22.1.1b. */
  709.  
  710. Dcl dir_entry_ptr ptr external;  /* Pointer to the following structure. */
  711.  
  712. Dcl 1 dir_entry external,        /* PRIMOS directory entry structure. */
  713.       2 ecw,
  714.         3 type bit (8),
  715.         3 len bit (8),
  716.       2 entryname char (32),
  717.       2 pw_protection bit (16) aligned,
  718.       2 non_dflt_protection bit (1) aligned,
  719.       2 file_inf,
  720.         3 (long_rat_hdr, dumped, dos_mod, special) bit (1),
  721.         3 rwlock bit (2),
  722.         3 pad1 bit (2),
  723.         3 type bit (8),
  724.       2 dtm fixed bin (31),
  725.       2 spare (2) fixed bin,
  726.       2 trunc bit (1) aligned,
  727.       2 (dtb, dtc, dta) fixed bin (31),
  728.       2 bra fixed bin (31),
  729.       2 fileid char (8);
  730.  
  731. Dcl file_info_ptr ptr external;  /* Pointer to the following structure. */
  732.  
  733. Dcl 1 file_info external,        /* PRIMOS file information structure. */
  734.       2 version fixed bin,
  735.       2 status_and_mode bit (16) aligned,
  736.       2 file_information (4) fixed bin,
  737.       2 system_name char (32) var,
  738.       2 ldevno fixed bin,
  739.       2 diskname char (32) var;
  740.  
  741. %list;
  742.  
  743. /* End of PRIMOS.INS.PLP */
  744. -------------------------------------------------------------------------------
  745.  
  746. /* ACK_SEND_INIT -- Setup our SND_INIT packet to send to other Kermit. */
  747.  
  748. Ack_send_init : proc;
  749.  
  750. $Insert *>insert>common.ins.plp
  751. $Insert *>insert>kermit.ins.plp
  752. $Insert *>insert>constants.ins.plp
  753.  
  754. Dcl (eol_bin, temp) fixed bin,
  755.     eol char (1),
  756.     capa_ptr ptr;
  757.  
  758. /* ************************************************************************* */
  759.  
  760.    call prs_send_init;       /* Extract the fields from the init packet. */
  761.  
  762.    capa_ptr = addr (loc_capas1);      /* Set parameters for file transfer. */
  763.    loc_file_attrib = capa_ptr -> capas.file_attributes;
  764.  
  765.    call set_params;
  766.  
  767.    /* Build our ACK packet, and set the printable bit. */
  768.  
  769.    char2(1) = nul_7bit_asc;
  770.    char2(2) = loc_eol;
  771.    char2_ptr -> fb15_based = char2_ptr -> fb15_based + 32;
  772.  
  773.    eol = char2(2);
  774.  
  775.    eol_bin = loc_pkt_size + 32;
  776.    temp = loc_timeout + 32;
  777.  
  778.    snd_msg = substr (addr (eol_bin) -> char2_based, 2, 1) ||
  779.              substr (addr (temp) -> char2_based, 2, 1);
  780.  
  781.    eol_bin = loc_npad + 32;
  782.    temp = loc_capas1 + 32;
  783.  
  784.    snd_msg = snd_msg || substr (addr (eol_bin) -> char2_based, 2, 1) ||
  785.              ctl (loc_padchar) || eol || loc_quote_chr ||
  786.              quote8_char || loc_chk_type || loc_rep_chr ||
  787.              substr (addr (temp) -> char2_based, 2, 1);
  788.  
  789.    temp = loc_max_wsize + 32;
  790.    snd_msg = snd_msg || substr (addr (temp) -> char2_based, 2, 1);
  791.  
  792.    call send_packet (msg_ack, length (snd_msg), rec_seq); /* Send the packet. */
  793.  
  794.    return;
  795.  
  796.    end;       /* Ack_send_init */
  797. -------------------------------------------------------------------------------
  798.  
  799. /* ASSIGN -- Assign an asynchronous line according to various flag settings. */
  800.  
  801. Assign : proc (action, linex, code);
  802.  
  803. Dcl (action, linex, code) fixed bin;
  804.  
  805. $Insert *>insert>common.ins.plp
  806. $Insert *>insert>kermit.ins.plp
  807. $Insert *>insert>primos.ins.plp
  808. $Insert *>insert>constants.ins.plp
  809. $Insert syscom>errd.ins.pl1
  810.  
  811. Dcl (line, list_len, errcount) fixed bin,
  812.     line_data (2, 2) fixed bin,
  813.     errors (2, 2) fixed bin,
  814.     config bit (16) aligned,
  815.     baud_change bit (3);
  816.  
  817. %Replace k$plst by 1;
  818.  
  819. /* ************************************************************************* */
  820.  
  821.    code = 0;
  822.    line = linex;          /* At the moment AS$SET changes the line argument. */
  823.    config = default_config;
  824.  
  825.    if action ^= 0 then
  826.       do;
  827.          select (baud_rate);
  828.  
  829.             when (110)
  830.                do;
  831.                   baud_change = enc110;
  832.                   substr (config, 12, 1) = '1'b; /* Set 2 stop bits as well. */
  833.                end;
  834.  
  835.             when (134)
  836.                baud_change = enc134;
  837.  
  838.             when (300)
  839.                baud_change = enc300;
  840.  
  841.             when (1200)
  842.                baud_change = enc1200;
  843.  
  844.             when (0)
  845.                baud_change = enc_clock;
  846.  
  847.             when (-1)
  848.                baud_change = enc_j1;
  849.  
  850.             when (-2)
  851.                baud_change = enc_j2;
  852.  
  853.             when (-3)
  854.                baud_change = enc_j3;
  855.  
  856.             otherwise
  857.                if ^old_primos_revision then
  858.                   baud_change = enc1200;           /* We MUST set this. */
  859.                else
  860.                   do;
  861.                      code = e$inre;         /* Invalid baud rate given. */
  862.                      return;
  863.                   end;
  864.          end;
  865.  
  866.          substr (config, 8, 3) = baud_change;
  867.  
  868.       end;
  869.  
  870.    call asnln$ (action, line, 'TRAN  ', config, default_lword, code);
  871.  
  872.    if action = 0 then
  873.       if code = e$nass then     /* Not really an error. */
  874.          code = 0;
  875.       else
  876.          ;
  877.    else
  878.       if ^old_primos_revision & baud_rate > 0 & (baud_rate ^= 110 &
  879.                                 baud_rate ^= 134 & baud_rate ^= 300 &
  880.                                 baud_rate ^= 1200) then
  881.          do;
  882.             list_len = 2;
  883.             line_data(1, 1) = 11;
  884.             line_data(1, 2) = baud_rate_index;
  885.             line_data(2, 1) = 51;
  886.  
  887.             if baud_rate <= 110 then         /* Set the number of stop bits. */
  888.                line_data(2,2) = 2;
  889.             else
  890.                line_data(2,2) = 1;
  891.  
  892.             call as$set (line, k$plst, 1, addr (line_data), addr (errors),
  893.                          list_len, errcount, code);
  894.  
  895.             if code ^= 0 then
  896.                do;
  897.                   baud_rate = 1200;
  898.                   baud_rate_index = 3;
  899.                end;
  900.          end;
  901.  
  902.    return;
  903.  
  904.    end;       /* Assign */
  905. -------------------------------------------------------------------------------
  906.  
  907. /* BK_HNDLR -- Break handler for Kermit. */
  908.  
  909. Bk_hndlr : proc (point);
  910.  
  911. Dcl point ptr;
  912.  
  913. $Insert *>insert>common.ins.plp
  914. $Insert *>insert>kermit.ins.plp
  915. $Insert *>insert>primos.ins.plp
  916. $Insert *>insert>constants.ins.plp
  917.  
  918. Dcl code fixed bin;
  919.  
  920. /* ************************************************************************* */
  921.  
  922.    call limit$ ('0702'b4, 0, 0, code);    /* Turn off watchdog timer. */
  923.  
  924.    call log_info (packet_log, '.BREAK. received!');    /* Log the break. */
  925.  
  926.    call xfer_mode (0, code);            /* Reset the user's environment. */
  927.  
  928.    call ioa$('%/QUIT.%/Leaving Kermit...Returning to Primos.%.', 99);
  929.  
  930.    goto brk_lbl;
  931.  
  932.    end;      /* Bk_hndlr */
  933. -------------------------------------------------------------------------------
  934.  
  935. /* CHANGE_DIR -- Change current directory. */
  936.  
  937. Change_dir : proc (treename, code);
  938.  
  939. Dcl treename char (128) var,
  940.     code fixed bin;
  941.  
  942. $Insert *>insert>common.ins.plp
  943. $Insert *>insert>primos.ins.plp
  944. $Insert *>insert>constants.ins.plp
  945. $Insert syscom>keys.ins.pl1
  946.  
  947. Dcl pathlen fixed bin,
  948.     new_dir char (128);
  949.  
  950. /* ************************************************************************* */
  951.  
  952.    code = 0;
  953.  
  954.    if length (treename) = 0 then  /* Attach to origin if no treename given. */
  955.       do;
  956.          call at$or (k$seth, code);
  957.          if code = 0 then
  958.             snd_msg = 'Now in your origin directory.';
  959.       end;
  960.    else
  961.       do;
  962.          call at$ (k$seth, treename, code);  /* Don't forget we may have had */
  963.          if code = 0 then            /* passwords, so we can't use SET_PATH. */
  964.             do;
  965.                if substr (treename, 1, 2) = '*>' then
  966.                   do;                   /* Find out where we are! */
  967.                      call gpath$ (k$homa, 0, new_dir, 128, pathlen, code);
  968.                      if code = 0 then
  969.                         treename = substr (new_dir, 1, pathlen);
  970.                      else
  971.                         code = 0;          /* We do this for later. */
  972.                   end;
  973.  
  974.                snd_msg = 'Now in directory ' ||
  975.                           before (treename, space_8bit_asc) || '.';
  976.             end;
  977.       end;
  978.  
  979.    return;
  980.  
  981.    end;       /* Change_dir */
  982. -------------------------------------------------------------------------------
  983.  
  984. /* CHKS -- Subroutine to compute Kermit checksum. */
  985.  
  986. Chks : proc (key, str) returns (fixed bin);
  987.  
  988. Dcl key fixed bin,
  989.     str char (96) var;
  990.  
  991. $Insert *>insert>constants.ins.plp
  992.  
  993. Dcl topbyte bit (1) aligned,
  994.     str_ptr ptr,
  995.     (i, str_len, total, word_index) fixed bin;
  996.  
  997. Dcl 1 non_trans_data (1) based,
  998.       2 a1skip bit (1),
  999.       2 a1 bit (7),
  1000.       2 a2skip bit (1),
  1001.       2 a2 bit (7);
  1002.  
  1003. Dcl 1 trans_data (1) based,
  1004.       2 a1 bit (8),
  1005.       2 a2 bit (8);
  1006.  
  1007. Dcl 1 checksum_format based,
  1008.       2 s1 bit (8),
  1009.       2 s2 bit (2),
  1010.       2 s3 bit (6);
  1011.  
  1012. /* ************************************************************************* */
  1013.  
  1014.    topbyte = false;   /* Skip first char (mark), take low order byte. */
  1015.    word_index = 2;    /* Word index into char var string (skip length). */
  1016.    total = 0;
  1017.    str_len = length (str);
  1018.    str_ptr = addr (str);
  1019.  
  1020.    do i = 2 to str_len;
  1021.  
  1022.       if topbyte then
  1023.          do;
  1024.             word_index = word_index + 1;
  1025.  
  1026.             if key = 1 then   /* Parity NONE, 8 bit data, transparent mode. */
  1027.                total = total + str_ptr -> trans_data(word_index).a1;
  1028.             else              /* 7 bit data, non-transparent mode. */
  1029.                total = total + str_ptr -> non_trans_data(word_index).a1;
  1030.          end;
  1031.       else
  1032.          if key = 1 then
  1033.             total = total + str_ptr -> trans_data(word_index).a2;
  1034.          else
  1035.             total = total + str_ptr -> non_trans_data(word_index).a2;
  1036.  
  1037.       topbyte = ^topbyte;
  1038.  
  1039.    end;
  1040.  
  1041.    /* Compute checksum from total of character values,
  1042.       (Add bits 6 - 7 to bits 0 - 5 then return 6-bit value). */
  1043.  
  1044.    total = total + addr (total) -> checksum_format.s2;
  1045.    total = addr (total) -> checksum_format.s3;
  1046.  
  1047.    return (total);
  1048.  
  1049.    end;         /* Chks */
  1050. -------------------------------------------------------------------------------
  1051.  
  1052. /* CLOSE_INPUT -- Close an input file. */
  1053.  
  1054. Close_input : proc;
  1055.  
  1056. $Insert *>insert>common.ins.plp
  1057. $Insert *>insert>kermit.ins.plp
  1058. $Insert *>insert>primos.ins.plp
  1059. $Insert *>insert>constants.ins.plp
  1060. $Insert syscom>errd.ins.pl1
  1061.  
  1062. Dcl code fixed bin;
  1063.  
  1064. /* ************************************************************************* */
  1065.  
  1066.    if ^explicit_ft_set then
  1067.       file_type = automatic_ft;  /* Now we have finished, reset this. */
  1068.  
  1069.    if ^explicit_pound_set then   /* This may have changed for BINARY files. */
  1070.       pound_conversion = true;
  1071.  
  1072.    if file_opened then
  1073.       do;
  1074.          call clo$fu (file_unit, code);
  1075.          if code ^= 0 & code ^= e$unop then
  1076.             do;
  1077.                call get_error_msg (code);
  1078.                snd_msg = 'Unable to close the input file on remote system. ' ||
  1079.                          errmsg;
  1080.                call send_packet (msg_error, length (snd_msg), msg_number);
  1081.             end;
  1082.  
  1083.          file_opened = false;
  1084.  
  1085.       end;
  1086.  
  1087.    return;
  1088.  
  1089.    end;       /* Close_input */
  1090. -------------------------------------------------------------------------------
  1091.  
  1092. /* CLOSE_OUTPUT -- Close an output file. */
  1093.  
  1094. Close_output : proc returns (fixed bin);
  1095.  
  1096. $Insert *>insert>common.ins.plp
  1097. $Insert *>insert>kermit.ins.plp
  1098. $Insert *>insert>primos.ins.plp
  1099. $Insert *>insert>constants.ins.plp
  1100. $Insert syscom>keys.ins.pl1
  1101. $Insert syscom>errd.ins.pl1
  1102.  
  1103. Dcl (code, code2) fixed bin;
  1104.  
  1105. /* ************************************************************************* */
  1106.  
  1107.    code = 0;
  1108.  
  1109.    if ^file_opened then
  1110.       do;
  1111.          rec_file_type = automatic_ft;
  1112.          if ^explicit_ft_set then
  1113.             file_type = automatic_ft;
  1114.  
  1115.          return (code);
  1116.       end;
  1117.  
  1118.    call write_ibuf (1, code);        /* Write the buffer to the file first. */
  1119.  
  1120.    rec_file_type = automatic_ft;     /* We MUST do this before returning. */
  1121.    if ^explicit_ft_set then
  1122.       file_type = automatic_ft;
  1123.  
  1124.    if code ^= 0 then
  1125.       return (code);
  1126.  
  1127.    call clo$fu (file_unit, code);
  1128.  
  1129.    if code = e$unop then
  1130.       code = 0;
  1131.  
  1132.    if use_attributes & (rec_file_dtc ^= 0 & rec_file_dtc ^= -1) & code = 0 then
  1133.       do;
  1134.          code2 = 0;
  1135.  
  1136.          if non_null_dir then
  1137.             call at$ (k$setc, dir_name, code2);
  1138.  
  1139.       /* We set the files' DTM as well as the DTC since
  1140.          this seems to be more meaningful to most users. */
  1141.  
  1142.          if code2 = 0 then
  1143.             do;
  1144.                call satr$$ (k$dtc, (file_name), length (file_name),
  1145.                             rec_file_dtc, code2);
  1146.  
  1147.                call satr$$ (k$dtim, (file_name), length (file_name),
  1148.                             rec_file_dtc, code2);
  1149.             end;
  1150.  
  1151.          if non_null_dir then
  1152.             call at$hom (code2);
  1153.  
  1154.       end;
  1155.  
  1156.    file_opened = false;
  1157.  
  1158.    call set_path ('');
  1159.  
  1160.    return (code);
  1161.  
  1162.    end;       /* Close_output */
  1163. -------------------------------------------------------------------------------
  1164.  
  1165. /* COMND -- Kermit command level processor. */
  1166.  
  1167. Comnd : proc;
  1168.  
  1169. $Insert *>insert>common.ins.plp
  1170. $Insert *>insert>kermit.ins.plp
  1171. $Insert *>insert>primos.ins.plp
  1172. $Insert *>insert>constants.ins.plp
  1173. $Insert syscom>keys.ins.pl1
  1174. $Insert syscom>errd.ins.pl1
  1175.  
  1176. %Replace num_tokens by 3;
  1177.  
  1178. Dcl token (num_tokens) char (128) var,
  1179.     (num_tok, command, i, code, code2) fixed bin,
  1180.     statv (2) fixed bin,
  1181.     new_baud_rate fixed bin (31),
  1182.     (from_comi_hndlr, ok) bit (1) aligned,
  1183.     kermit_state_ptr ptr,
  1184.     (reenter, comi_eof) char (10) var,
  1185.     cmd_option char (128) var,
  1186.     (cmd_buf, cmd_data) char (160) var,
  1187.     tempstr char (256) var;
  1188.  
  1189. Dcl 1 fs,
  1190.       2 date_today fixed bin,
  1191.       2 qsecs fixed bin;
  1192.  
  1193. %Replace kermit_len by 24,
  1194.          ambiguous_cmd by -1;
  1195.  
  1196. Dcl kermit_state (kermit_len) char (16) var static init (
  1197.           'EXIT',
  1198.           'HELP',
  1199.           'QUIT',
  1200.           'RECEIVE',
  1201.           'SET',
  1202.           'SEND',
  1203.           'SERVER',
  1204.           'SHOW',
  1205.           'TAKE',
  1206.           'VERSION',
  1207.           'CONVERT',
  1208.           'LOG',
  1209.           'CLOSE',
  1210.           'PUSH',
  1211.           'STOP',
  1212.           'POP',
  1213.           'CONNECT',
  1214.           'FINISH',
  1215.           'BYE',
  1216.           'GET',
  1217.           'INPUT',
  1218.           'OUTPUT',
  1219.           'PAUSE',
  1220.           'CLEAR');
  1221.  
  1222. %Replace cmd_exit by 1,
  1223.          cmd_help by 2,
  1224.          cmd_quit by 3,
  1225.          cmd_receive by 4,
  1226.          cmd_set by 5,
  1227.          cmd_send by 6,
  1228.          cmd_server by 7,
  1229.          cmd_show by 8,
  1230.          cmd_take by 9,
  1231.          cmd_version by 10,
  1232.          cmd_convert by 11,
  1233.          cmd_log by 12,
  1234.          cmd_close by 13,
  1235.          cmd_push by 14,
  1236.          cmd_stop by 15,
  1237.          cmd_pop by 16,
  1238.          cmd_connect by 17,
  1239.          cmd_finish by 18,
  1240.          cmd_bye by 19,
  1241.          cmd_get by 20,
  1242.          cmd_input by 21,
  1243.          cmd_output by 22,
  1244.          cmd_pause by 23,
  1245.          cmd_clear by 24;
  1246.  
  1247. %Replace show_len by 18;
  1248.  
  1249. Dcl show_state (show_len) char (16) var static init (
  1250.           'ALL',
  1251.           'DELAY',
  1252.           'RETRIES',
  1253.           'TIMEOUT',
  1254.           'PARITY',
  1255.           'QUOTE',
  1256.           '8QUOTE',
  1257.           'REPEAT',
  1258.           'WINDOW',
  1259.           'FILE_TYPE',
  1260.           'INCOMPLETE',
  1261.           'POUND',
  1262.           'ATTRIBUTES',
  1263.           'WARNING',
  1264.           'LOG',
  1265.           'LINE',
  1266.           'ESCAPE',
  1267.           'BAUD');
  1268.  
  1269. %Replace show_all by 1,
  1270.          show_delay by 2,
  1271.          show_retries by 3,
  1272.          show_timeout by 4,
  1273.          show_parity by 5,
  1274.          show_quote by 6,
  1275.          show_8quote by 7,
  1276.          show_repeat by 8,
  1277.          show_wsize by 9,
  1278.          show_store by 10,
  1279.          show_incomplete by 11,
  1280.          show_pound by 12,
  1281.          show_attributes by 13,
  1282.          show_warning by 14,
  1283.          show_log by 15,
  1284.          show_amlc by 16,
  1285.          show_escape by 17,
  1286.          show_baud by 18;
  1287.  
  1288. /* ************************************************************************* */
  1289.  
  1290.    code = 0;
  1291.    from_comi_hndlr = false;
  1292.    kermit_state_ptr = addr (kermit_state);
  1293.  
  1294.    reenter = 'REENTER$';
  1295.    ren_lbl = ren_point;
  1296.    call mkonu$ (reenter, ren_hndlr);
  1297.  
  1298.    comi_eof = 'COMI_EOF$';
  1299.    call mkonu$ (comi_eof, comi_hndlr);
  1300.  
  1301.    if in_init_file then
  1302.       if length (kermit_init_file) = 0 then
  1303.          do;
  1304.             in_init_file = false;
  1305.             go to comi_restart;
  1306.          end;
  1307.       else
  1308.          do;
  1309.             num_tok = 2;
  1310.             command = cmd_take;
  1311.             cmd_option = kermit_init_file;
  1312.             go to next_command;
  1313.          end;
  1314.  
  1315. Ren_point :
  1316.  
  1317.    do while (true);
  1318.  
  1319.       do until (((length (cmd_buf) > 0) & substr (cmd_buf, 1, 1) ^=
  1320.                  ctrl_a_8bit_asc) | (code ^= 0));
  1321.          call tnoua ((kprompt), kprompt_len);
  1322.  
  1323. Comi_restart :
  1324.  
  1325.          call cl$get (cmd_buf, 160, code);
  1326.       end;
  1327.  
  1328.       if code ^= 0 then
  1329.          do;
  1330.             call get_error_msg (code);
  1331.             call ioa$ ('Error reading the command line. %v%.', 99, errmsg);
  1332.             return;
  1333.          end;
  1334.  
  1335.       call tokenize (cmd_buf);
  1336.       command = type (token(1), kermit_state_ptr, kermit_len);
  1337.       cmd_option = token(2);
  1338.  
  1339. Next_command :
  1340.  
  1341.       select (command);        /* Now process the command. */
  1342.  
  1343.          when (cmd_take)       /* TAKE input from a file. */
  1344.             if num_tok < 2 then
  1345.                call tnou ('No pathname given for TAKE command.', 35);
  1346.             else
  1347.                if length (cmd_option) <= 8 &
  1348.                   (cmd_option = 'TTY' | cmd_option = 'PAUSE' | cmd_option =
  1349.                      substr ('CONTINUE', 1, length (cmd_option))) then
  1350.                   do;
  1351.                      if in_init_file & take_level = 0 then
  1352.                         tempstr = 'INIT option';
  1353.                      else
  1354.                         tempstr = 'TAKE command';
  1355.  
  1356.                      call ioa$ (
  1357.                    'The filename "%v" is NOT allowed for the %v. %.', 99,
  1358.                                 cmd_option, tempstr);
  1359.                      if in_init_file & take_level = 0 then
  1360.                         do;
  1361.                            in_init_file = false;
  1362.                            return;
  1363.                         end;
  1364.                   end;
  1365.                else
  1366.                   if take_level + 1 > max_take_level then
  1367.                      call ioa$ (
  1368.             'You have reached the maximum number (%d) of nested TAKE files.%.',
  1369.                                 99, max_take_level);
  1370.                   else
  1371.                      do;
  1372.                         i = get_unit (code);
  1373.                         if i > 0 then
  1374.                            do;
  1375.                               code = 0;
  1376.                               call set_path (cmd_option);
  1377.                               if non_null_dir then
  1378.                                  call at$ (k$setc, dir_name, code);
  1379.  
  1380.                               if code = 0 then
  1381.                                  call comi$$ ((file_name), length (file_name),
  1382.                                               i, code);
  1383.  
  1384.                               if non_null_dir then
  1385.                                  call at$hom (code2);
  1386.                            end;
  1387.  
  1388.                         if code = 0 then
  1389.                            do;
  1390.                               take_level = take_level + 1;
  1391.                               take_unit(take_level) = i;
  1392.                            end;
  1393.                         else
  1394.                            do;
  1395.                               call get_error_msg (code);
  1396.                               call ioa$ ('Error opening file %v. %v%.', 99,
  1397.                                          cmd_option, errmsg);
  1398.  
  1399.                               if in_init_file & take_level = 0 then
  1400.                                  do;
  1401.                                     in_init_file = false;
  1402.                                     return;
  1403.                                  end;
  1404.                            end;
  1405.                      end;
  1406.  
  1407.          when (cmd_version)          /* Display the current VERSION number. */
  1408.             call tnou ((kversion), length (kversion));
  1409.  
  1410.          when (cmd_help)                /* Display HELP information. */
  1411.             call comnd_help;
  1412.  
  1413.          when (cmd_set)                 /* SET option. */
  1414.             if num_tok < 2 then
  1415.                call tnou ('No SET option specified.', 24);
  1416.             else
  1417.                call comnd_set;
  1418.  
  1419.          when (cmd_show)                /* SHOW option. */
  1420.             do;
  1421.                if num_tok < 2 then
  1422.                   cmd_option = 'ALL';
  1423.  
  1424.                if cmd_option = 'FT' then
  1425.                   cmd_option = 'FILE_TYPE';
  1426.  
  1427.                if cmd_option = 'RETRY' then
  1428.                   cmd_option = 'RETRIES';
  1429.  
  1430.                call tonl;
  1431.                call comnd_show (type (cmd_option, addr (show_state), show_len));
  1432.                call tonl;
  1433.             end;
  1434.  
  1435.          when (cmd_server)               /* SERVER. */
  1436.             if take_level = 0 then
  1437.                do;
  1438.                   call xfer_mode (1, code);
  1439.                   call tnou ('Kermit server started.', 22);
  1440.                   call server;
  1441.                   call xfer_mode (0, code);
  1442.                   return;
  1443.                end;
  1444.             else
  1445.                call tnou ('SERVER command not allowed.', 27);
  1446.  
  1447.          when (cmd_send)                 /* SEND. */
  1448.             if take_level = 0 then
  1449.                if num_tok < 2 then
  1450.                   call tnou ('No pathname(s) given for SEND command.', 38);
  1451.                else
  1452.                   if tnchk$ (k$uprc + k$wldc, cmd_option) then
  1453.                      do;
  1454.                         call set_path (cmd_option);
  1455.                         state = state_s;
  1456.                         call xfer_mode (1, code);
  1457.                         call tnou ('Kermit send started.', 20);
  1458.                         call send_switch;
  1459.                         call xfer_mode (0, code);
  1460.                      end;
  1461.                   else
  1462.                      call ioa$ ('Invalid SEND pathname(s) "%v".%.', 99,
  1463.                                 cmd_option);
  1464.             else
  1465.                call tnou ('SEND command not allowed.', 25);
  1466.  
  1467.          when (cmd_receive)              /* RECEIVE. */
  1468.             if take_level = 0 then
  1469.                do;
  1470.                   state = state_r;
  1471.                   call set_path (cmd_option);
  1472.                   call xfer_mode (1, code);
  1473.                   call tnou ('Kermit receive started.', 23);
  1474.                   call rec_switch;
  1475.                   call xfer_mode (0, code);
  1476.                end;
  1477.             else
  1478.                call tnou ('RECEIVE command not allowed.', 28);
  1479.  
  1480.          when (cmd_convert)              /* CONVERT a file. */
  1481.             if num_tok < 2 then
  1482.                call tnou ('No pathname given for CONVERT command.', 38);
  1483.             else
  1484.                do;
  1485.                   call set_path (cmd_option);
  1486.                   code = convert_file ();
  1487.                   if code ^= 0 then
  1488.                      do;
  1489.                         call get_error_msg (code);
  1490.                         call ioa$ ('%v%v%.', 99, snd_msg, errmsg);
  1491.                      end;
  1492.                   else
  1493.                      call ioa$ ('Conversion of file %v successful.%.', 99,
  1494.                                 cmd_option);
  1495.                end;
  1496.  
  1497.          when (cmd_log)                  /* LOG command. */
  1498.             do;
  1499.                i = 0;
  1500.  
  1501.                if index ('SESSION', cmd_option) = 1 then
  1502.                   if session_log_opened then
  1503.                      call tnou ('Session log file already open.', 30);
  1504.                   else
  1505.                      i = session_log;
  1506.                else
  1507.                   if index ('PACKETS', cmd_option) = 1 then
  1508.                      if packet_log_opened then
  1509.                         call tnou ('Packet log file already open.', 29);
  1510.                      else
  1511.                         i = packet_log;
  1512.                   else
  1513.                      if length (cmd_option) = 0 then
  1514.                         call tnou ('No PACKET or SESSION log type specified.',
  1515.                                    40);
  1516.                      else
  1517.                         call ioa$ ('Invalid log type specified. "%v"%.', 99,
  1518.                                    cmd_option);
  1519.  
  1520.                if i > 0 then
  1521.                   do;
  1522.                      code = open_log (i, token(3));
  1523.                      if code ^= 0 then
  1524.                         do;
  1525.                            call get_error_msg (code);
  1526.                            call ioa$ ('Error opening log file. %v%.', 99,
  1527.                                       errmsg);
  1528.                         end;
  1529.                      else
  1530.                         if i = session_log then
  1531.                            call tnou ('Session log file opened.', 24);
  1532.                         else
  1533.                            call tnou ('Packet log file opened.', 23);
  1534.                   end;
  1535.             end;
  1536.  
  1537.          when (cmd_close)                /* CLOSE the log file. */
  1538.             do;
  1539.                i = 0;
  1540.  
  1541.                if length (cmd_option) = 0 & ^(session_log_opened &
  1542.                                               packet_log_opened) then
  1543.                   if packet_log_opened then
  1544.                      cmd_option = 'P';
  1545.                   else
  1546.                      if session_log_opened then
  1547.                         cmd_option = 'S';
  1548.  
  1549.                if index ('SESSION', cmd_option) = 1 then
  1550.                   if session_log_opened then
  1551.                      do;
  1552.                         i = session_log;
  1553.                         session_log_opened = false;
  1554.                         call clo$fu (session_log_unit, code);
  1555.                      end;
  1556.                   else
  1557.                      call tnou ('Session log file not open.', 26);
  1558.                else
  1559.                   if index ('PACKETS', cmd_option) = 1 then
  1560.                      if packet_log_opened then
  1561.                         do;
  1562.                            i = packet_log;
  1563.                            packet_log_opened = false;
  1564.                            call clo$fu (packet_log_unit, code);
  1565.                         end;
  1566.                      else
  1567.                         call tnou ('Packet log file not open.', 25);
  1568.                   else
  1569.                      if length (cmd_option) = 0 then
  1570.                         if ^(session_log_opened | packet_log_opened) then
  1571.                            call tnou ('No log files currently open.', 28);
  1572.                         else
  1573.                            call tnou (
  1574.                                     'No PACKET or SESSION log type specified.',
  1575.                                       40);
  1576.                      else
  1577.                         call ioa$ ('Invalid log type specified. "%v"%.', 99,
  1578.                                    cmd_option);
  1579.  
  1580.                if i > 0 then
  1581.                   if code ^= 0 & code ^= e$unop then
  1582.                      do;
  1583.                         call get_error_msg (code);
  1584.                         call ioa$ ('Error closing the log file. %v%.', 99,
  1585.                                    errmsg);
  1586.                      end;
  1587.                   else
  1588.                      if i = session_log then
  1589.                         call tnou ('Session log file closed.', 24);
  1590.                      else
  1591.                         call tnou ('Packet log file closed.', 23);
  1592.             end;
  1593.  
  1594.          when (cmd_push)                 /* PUSH to a new command level. */
  1595.             call comlv$;
  1596.  
  1597.          when (cmd_pop)                  /* POP back a level. */
  1598.             if take_level > 0 then
  1599.                do;
  1600. Comi_point :
  1601.                   call comi$$ ('TTY', 3, take_unit(take_level), code);
  1602.  
  1603.                   take_unit(take_level) = 0;
  1604.                   take_level = take_level - 1;
  1605.  
  1606.                   if code = 0 then
  1607.                      if take_level > 0 then
  1608.                         do;
  1609.                            call comi$$ ('CONTINUE', 8, take_unit(take_level),
  1610.                                         code);
  1611.                            if code ^= 0 then
  1612.                               do;
  1613.                                  call get_error_msg (code);
  1614.                                  call ioa$ (
  1615.                              'Unable to continue the previous TAKE file. %v%.',
  1616.                                             99, errmsg);
  1617.                                  go to comi_point;
  1618.                               end;
  1619.                         end;
  1620.                      else
  1621.                         ;
  1622.                   else
  1623.                      do;
  1624.                         call get_error_msg (code);
  1625.                         call ioa$ ('Error closing the current TAKE file. %v%.',
  1626.                                    errmsg);
  1627.                      end;
  1628.  
  1629.                   if from_comi_hndlr then
  1630.                      do;
  1631.                         from_comi_hndlr = false;
  1632.                         if in_init_file & take_level = 0 then
  1633.                            return;
  1634.                         else
  1635.                            go to comi_restart;
  1636.                      end;
  1637.                   else
  1638.                      if in_init_file & take_level = 0 then
  1639.                         do;
  1640.                            in_init_file = false;
  1641.                            return;
  1642.                         end;
  1643.                end;
  1644.  
  1645.          when (cmd_stop)                 /* STOP (suddenly) all TAKE files. */
  1646.             if take_level > 0 then
  1647.                do;
  1648.                   /* If this call fails then the on-unit should catch EOF. */
  1649.  
  1650.                   call comi$$ ('TTY', 3, take_unit(take_level), code);
  1651.                   take_unit(take_level) = 0;
  1652.  
  1653.                   take_level = take_level - 1;
  1654.                   do i = 1 to take_level;
  1655.                      call clo$fu (take_unit(i), code);
  1656.                      take_unit(i) = 0;
  1657.                   end;
  1658.  
  1659.                   take_level = 0;
  1660.                   if in_init_file then
  1661.                      do;
  1662.                         in_init_file = false;
  1663.                         return;
  1664.                      end;
  1665.                end;
  1666.  
  1667.          when (cmd_connect)              /* CONNECT using an async line. */
  1668.             if use_amlc_line then
  1669.                call connect (amlc_line);
  1670.             else
  1671.                call tnou ('No asynchronous line has been SET for use.', 42);
  1672.  
  1673.          when (cmd_finish)               /* FINISH (end) the connection. */
  1674.             if ^use_amlc_line then
  1675.                call tnou ('Remote server not started.', 26);
  1676.             else
  1677.                do;
  1678.                   call xfer_mode (1, code);
  1679.  
  1680.                   msg_number = 0;
  1681.                   snd_msg = msg_gen_finish;
  1682.                   call send_packet (msg_kermit_generic, 1, 0);
  1683.                   if ^get_response () then
  1684.                     call tnou ('No remote response received to FINISH command.',
  1685.                                 46);
  1686.  
  1687.                   call xfer_mode (0, code);
  1688.                end;
  1689.  
  1690.          when (cmd_bye)                  /* Logout remote server. */
  1691.             if ^use_amlc_line then
  1692.                call tnou ('Remote server not started.', 26);
  1693.             else
  1694.                do;
  1695.                   call xfer_mode (1, code);
  1696.  
  1697.                   msg_number = 0;
  1698.                   snd_msg = msg_gen_logout;
  1699.                   call send_packet (msg_kermit_generic, 1, 0);
  1700.                   if ^get_response () then
  1701.                      call tnou ('No remote response received to BYE command.',
  1702.                                 43);
  1703.  
  1704.                   call xfer_mode (0, code);
  1705.                end;
  1706.  
  1707.          when (cmd_get)                  /* GET wildcarded file(s). */
  1708.             if length (cmd_option) > 0 then
  1709.                do;
  1710.                   call xfer_mode (1, code);
  1711.  
  1712.                   msg_number = 0;
  1713.                   snd_msg = cmd_option;
  1714.                   call send_packet (msg_rcv_init, length (snd_msg), 0);
  1715.  
  1716.                   cmd_option = '';
  1717.                   call set_path (cmd_option);
  1718.                   state = state_r;
  1719.                   call tnou ('In receive mode.', 16);
  1720.                   call rec_switch;
  1721.  
  1722.                   call xfer_mode (0, code);
  1723.                end;
  1724.             else
  1725.                call tnou ('No filename given for GET command.', 34);
  1726.  
  1727.          when (cmd_input)                /* INPUT command. */
  1728.             do;
  1729.                ok = false;
  1730.  
  1731.                if ^use_amlc_line then
  1732.                   call tnou ('No CONNECTion currently started.', 32);
  1733.                else
  1734.                   if length (cmd_option) = 0 then
  1735.                      call tnou ('No INPUT string specified.', 26);
  1736.                   else
  1737.                      if length (token(3)) ^= 0 then
  1738.                         if verify (cmd_option, '0123456789') ^= 0 then
  1739.                            call ioa$ ('Invalid INPUT wait time "%v".%.', 99,
  1740.                                       cmd_option);
  1741.                         else
  1742.                            ok = input (trim (after (cmd_data, space_8bit_asc),
  1743.                                              '11'b), bin (cmd_option, 15));
  1744.                      else
  1745.                         ok = input (cmd_data, 0);
  1746.  
  1747.                if ^ok & take_level > 0 then
  1748.                   do;           /* Abort any current TAKE file on errors. */
  1749.                      cmd_option = '';
  1750.                      command = cmd_pop;
  1751.                      goto next_command;
  1752.                   end;
  1753.             end;
  1754.  
  1755.          when (cmd_output)               /* OUTPUT command. */
  1756.             if ^use_amlc_line then
  1757.                call tnou ('No CONNECTion currently started.', 32);
  1758.             else
  1759.                do;
  1760.                   tempstr = ctl_trans (ok, cmd_data);
  1761.                   if length (tempstr) > 0 then
  1762.                      do;
  1763.                         code = send_amlc (amlc_line, (tempstr),
  1764.                                           length (tempstr));
  1765.                         if code ^= 0 then
  1766.                            call tnou ('Unable to send OUTPUT data.', 27);
  1767.                      end;
  1768.                   else
  1769.                      if ok then
  1770.                         call tnou ('No OUTPUT string specified.', 27);
  1771.                      else
  1772.                         call ioa$ ('Invalid OUTPUT string given. "%v"%.', 99,
  1773.                                    cmd_data);
  1774.                end;
  1775.  
  1776.          when (cmd_pause)                /* PAUSE for a while. */
  1777.             if length (cmd_option) > 0 then
  1778.                if verify (cmd_option, '0123456789') = 0 then
  1779.                   call sleep$ (bin (cmd_option, 31) * 1000);
  1780.                else
  1781.                   do;                   /*  Check 24-hour clock time. */
  1782.                      addr (fs) -> fb31_based = date$ ();
  1783.                      i = fs.qsecs;      /* Number of quadseconds so far. */
  1784.  
  1785.                      call cv$dtb (cmd_option, addr (fs) -> fb31_based, code);
  1786.                      if code ^= 0 then
  1787.                         call ioa$ ('Invalid PAUSE time given. "%v"%.', 99,
  1788.                                    cmd_option);
  1789.                      else
  1790.                         if fs.qsecs <= i then
  1791.                            call tnou ('Already past the specified PAUSE time.',
  1792.                                       38);
  1793.                         else
  1794.                            call sleep$ ((fs.qsecs - i) * 4000);
  1795.                   end;
  1796.             else
  1797.                call tnou ('No PAUSE time specified.', 24);
  1798.  
  1799.          when (cmd_clear)                /* CLEAR the connection. */
  1800.             if ^use_amlc_line then
  1801.                call tnou ('No CONNECTion currently started.', 32);
  1802.             else
  1803.                do;
  1804.                   code = send_amlc (amlc_line, ctl ('Q'), 1);
  1805.                   call t$amlc (amlc_line, addr (i), 0, 10, statv, 1, code);
  1806.                   saved_amlc_chrs = '';
  1807.                   if code ^= 0 then
  1808.                      call tnou ('Unable to CLEAR the I/O buffers.', 32);
  1809.                end;
  1810.  
  1811.          when (cmd_quit, cmd_exit)   /* EXIT to PRIMOS. */
  1812.             return;
  1813.  
  1814.          when (ambiguous_cmd)
  1815.             call ioa$ (
  1816.                  'Ambiguous command "%v". Type HELP for a list of commands.%.',
  1817.                        99, token(1));
  1818.  
  1819.          otherwise
  1820.             call ioa$ (
  1821.               'Unrecognized command "%v". Type HELP for a list of commands.%.',
  1822.                        99, token(1));
  1823.  
  1824.       end;        /* select */
  1825.  
  1826.    end;        /* do while */
  1827.  
  1828.    return;
  1829.  
  1830. /* ******************************* Comnd_help ****************************** */
  1831.  
  1832. Comnd_help : proc;
  1833.  
  1834. /* ************************************************************************* */
  1835.  
  1836.    call ioa$ ('%/Interactive mode commands : %/%.', 99);
  1837.    call ioa$ ('Commands may be abbreviated to those letters in uppercase.%/%.',
  1838.               99);
  1839.    call ioa$ ('  Receive [pathname]%17xUpload a file.%.', 99);
  1840.    call ioa$ ('  SENd wildcard%22xDownload file(s) using wildcards.%.', 99);
  1841.    call ioa$ ('  SERver%29xStart Kermit server.%/%.', 99);
  1842.  
  1843.    call ioa$ ('  Bye%32xLogout the remote server.%.', 99);
  1844.    call ioa$ ('  CLEar%30xFlush the asynchronous line I/O buffers.%.', 99);
  1845.    call ioa$ (
  1846.    '  CLOse {PACKET | SESSION}%11xClose the specified type of log file.%.', 99);
  1847.    call ioa$ ('  CONNect%28xConnect to the Prime with an assigned line.%.',
  1848.               99);
  1849.    call ioa$ ('  CONVert pathname%19xConverts a file to PRIME ASCII.%.', 99);
  1850.    call ioa$ ('  Exit or Quit%23xLeave Kermit.%.', 99);
  1851.    call ioa$ ('  Finish%29xShutdown the remote server.%.', 99);
  1852.    call ioa$ ('  Get wildcard%23xGet file(s) using wildcards.%.', 99);
  1853.    call ioa$ ('  Help%31xDisplay this message.%.', 99);
  1854.    call ioa$ ('  Input [time] string%16xMonitor assigned line for a time.%.',
  1855.               99);
  1856.    call ioa$ ('  Log {PACKET | SESSION} [pathname]  Start log file. %$', 99);
  1857.    call tnou ('Default is type dependant.', 26);
  1858.    call ioa$ ('  Output string%22xSend string along an assigned line.%.', 99);
  1859.    call ioa$ (
  1860.          '  PAuse {time | hh:mm:ss}%12xWait for a specified time (seconds).%.',
  1861.               99);
  1862.    call ioa$ ('  POp%32xClose the current TAKE file.%.', 99);
  1863.  
  1864.    if ^more () then
  1865.       return;
  1866.  
  1867.    call ioa$ ('  PUsh%31xReturn to PRIMOS, and may re-enter Kermit.%.', 99);
  1868.    call ioa$ ('  SHow [{option | ALL}]%14xDisplay the required option.%.', 99);
  1869.    call ioa$ ('  STop%31xClose all TAKE files, and return to Kermit.%.', 99);
  1870.    call ioa$ ('  Take pathname%22xExecute commands from a file.%.', 99);
  1871.    call ioa$ ('  Version%28xDisplay the current version number.%/%.', 99);
  1872.  
  1873.    call ioa$ ('%/  SET option%25xSet one of the following options :%.', 99);
  1874.    call ioa$ (
  1875.          '%6xAttributes {ON | OFF}%13xUse the received file attributes. DTC%.',
  1876.               99);
  1877.    call ioa$ ('%40xand file type are used. Default is ON.%.', 99);
  1878.    call ioa$ ('%6xBaud n%28xBaud rate to use for the assigned line.%.', 99);
  1879.    call ioa$ ('%40xDefault is 1200.%.', 99);
  1880.    call ioa$ ('%6xDelay n%27xDelay time in seconds before sending a%.', 99);
  1881.    call ioa$ ('%40xfile. Default is %d seconds.%.', 99, default_delay);
  1882.    call ioa$ ('%6xEscape char%23xEscape character to use for Connect%.', 99);
  1883.    call ioa$ ('%40xexits and breaks. Default is ^]%.', 99);
  1884.    call ioa$ (
  1885. '%6xFile_Type {AUTO | TEXT | BINARY}  Set the type of file(s) to be sent or%.',
  1886.               99);
  1887.    call ioa$ ('%40xreceived. Default is AUTO.%.', 99);
  1888.    call ioa$ (
  1889.       '%6xIncomplete {SAVE | DELETE}%8xKeep or delete incompletely received%.',
  1890.               99);
  1891.    call ioa$ ('%40xfiles. Default is DELETE.%.', 99);
  1892.    call ioa$ ('%6xLine [n]%26xAsync line number (decimal) to use. No%.', 99);
  1893.    call ioa$ ('%40xline number unassigns the current line.%.', 99);
  1894.  
  1895.    if ^more () then
  1896.       return;
  1897.  
  1898.    call ioa$ ('%6xPArity {MARK | NONE}%14xSet the character parity type.%.',
  1899.               99);
  1900.    call ioa$ ('%40xDefault parity is MARK.%.', 99);
  1901.    call ioa$ ('%6xPOUnd {ON | OFF}%18xSets the conversion of DOS pound%.', 99);
  1902.    call ioa$ ('%40xsigns. Default is ON.%.', 99);
  1903.    call ioa$ ('%6xQuote char%24xControl quoting character to use.%.', 99);
  1904.    call ioa$ ('%40x("char" = ASCII printable character).%.', 99);
  1905.    call ioa$ ('%6x8Quote char%23x8-bit quoting character to use.%.', 99);
  1906.    call ioa$ ('%40x("char" = ASCII grammatical character).%.', 99);
  1907.    call ioa$ ('%6xREPeat char%23xRepeat character prefix to use.%.', 99);
  1908.    call ioa$ ('%40x("char" = ASCII printable character).%.', 99);
  1909.    call ioa$ ('%6xRETries n%25xMaximum number of send and receive%.', 99);
  1910.    call ioa$ ('%40xpacket retries. Default is %d.%.', 99, default_max_retries);
  1911.    call ioa$ ('%6xTimeout n%25xSend packet timeout in seconds. Default%.', 99);
  1912.    call ioa$ ('%40xtimeout is %d seconds.%.', 99, my_timeout);
  1913.    call ioa$ (
  1914.              '%6xWArning {ON | OFF}%16xFile name collision warning. Prevents%.'
  1915.               , 99);
  1916.    call ioa$ ('%40xoverwriting of files. Default is ON.%.', 99);
  1917.    call ioa$ ('%6xWIndow n%26xFile transfer window size.%.', 99);
  1918.    call ioa$ ('%40x(1 <= "n" <= 31).%.', 99);
  1919.  
  1920.    call tonl;
  1921.  
  1922.    return;
  1923.  
  1924.    end;      /* Comnd_help */
  1925.  
  1926. /* ******************************* Comnd_show ****************************** */
  1927.  
  1928. Comnd_show : proc (option);
  1929.  
  1930. Dcl option fixed bin;
  1931.  
  1932. /* ************************************************************************* */
  1933.  
  1934.    select (option);
  1935.  
  1936.       when (show_all)
  1937.          do i = 2 to show_len;
  1938.             call comnd_show (i);
  1939.          end;
  1940.  
  1941.       when (show_delay)
  1942.          call ioa$ ('Time delay before sending a file is %d seconds.%.', 99,
  1943.                     delay);
  1944.  
  1945.       when (show_retries)
  1946.          call ioa$ (
  1947.                 'Maximum number of packet retries is %d (Send and Receive).%.',
  1948.                     99, max_retries);
  1949.  
  1950.       when (show_timeout)
  1951.          call ioa$ (
  1952.               'Timeouts are %#(.%) Send = %d seconds, Receive = %d seconds.%.',
  1953.                     99, 24, loc_timeout, rem_timeout);
  1954.  
  1955.       when (show_parity)
  1956.          do;
  1957.             call tnoua ('Character parity I will use ......... ', 38);
  1958.             if do_transparent then
  1959.                call tnou ('NONE', 4);
  1960.             else
  1961.                call tnou ('MARK', 4);
  1962.          end;
  1963.  
  1964.       when (show_quote)
  1965.          call ioa$ ('Quoting character I will use ........ "%c"%.', 99,
  1966.                     loc_quote_chr, 1);
  1967.  
  1968.       when (show_8quote)
  1969.          do;
  1970.             call ioa$ ('8-Bit quoting character I want to use "%c"%$', 99,
  1971.                        loc_8quote_chr, 1);
  1972.             if loc_8quote_chr = 'N' then
  1973.                call tnou ('   (No 8-bit quoting).', 22);
  1974.             else
  1975.                call tonl;
  1976.          end;
  1977.  
  1978.       when (show_repeat)
  1979.          do;
  1980.             call ioa$ ('Repeat character prefix I want to use "%c"%$', 99,
  1981.                        loc_rep_chr, 1);
  1982.             if loc_rep_chr = space_8bit_asc then
  1983.                call tnou ('   (No repeat character processing).', 36);
  1984.             else
  1985.                call tonl;
  1986.          end;
  1987.  
  1988.       when (show_wsize)
  1989.          call ioa$ ('Window size I want to use ........... %d%.', 99,
  1990.                     loc_max_wsize);
  1991.  
  1992.       when (show_store)
  1993.          do;
  1994.             call tnoua ('File storage type is ................ ', 38);
  1995.  
  1996.             select (file_type);
  1997.                when (automatic_ft)
  1998.                   call tnou ('AUTOMATIC', 9);
  1999.  
  2000.                when (ascii_ft)
  2001.                   call tnou ('TEXT', 4);
  2002.  
  2003.                when (binary_ft)
  2004.                   call tnou ('BINARY', 6);
  2005.  
  2006.                otherwise
  2007.                   call tnou ('ILLEGAL', 7);
  2008.             end;
  2009.          end;
  2010.  
  2011.       when (show_incomplete)
  2012.          do;
  2013.             call tnoua ('Incomplete files are ................ ', 38);
  2014.             if del_incomplete then
  2015.                call tnou ('DELETED', 7);
  2016.             else
  2017.                call tnou ('SAVED', 5);
  2018.          end;
  2019.  
  2020.       when (show_pound)
  2021.          do;
  2022.             call tnoua ('DOS pound sign conversion is ........ ', 38);
  2023.             if pound_conversion then
  2024.                call tnou ('ON', 2);
  2025.             else
  2026.                call tnou ('OFF', 3);
  2027.          end;
  2028.  
  2029.       when (show_attributes)
  2030.          do;
  2031.             call tnoua ('Use of the file attributes is ....... ', 38);
  2032.             if use_attributes then
  2033.                call tnou ('ON', 2);
  2034.             else
  2035.                call tnou ('OFF', 3);
  2036.          end;
  2037.  
  2038.       when (show_warning)
  2039.          do;
  2040.             call tnoua ('File name collision warning is ...... ', 38);
  2041.             if filename_warning then
  2042.                call tnou ('ON', 2);
  2043.             else
  2044.                call tnou ('OFF', 3);
  2045.          end;
  2046.  
  2047.       when (show_log)
  2048.          do;
  2049.             call tnoua ('Packet logging is ................... ', 38);
  2050.             if packet_log_opened then
  2051.                do;
  2052.                   call tnoua ('ON', 2);
  2053.                   if length (packet_log_pathname) > 15 then
  2054.                      call tonl;
  2055.                   call ioa$ ('    (Log pathname is "%v").%.', 99,
  2056.                              packet_log_pathname);
  2057.                end;
  2058.             else
  2059.                call tnou ('OFF', 3);
  2060.  
  2061.             call tnoua ('Session logging is .................. ', 38);
  2062.             if session_log_opened then
  2063.                do;
  2064.                   call tnoua ('ON', 2);
  2065.                   if length (session_log_pathname) > 15 then
  2066.                      call tonl;
  2067.                   call ioa$ ('    (Log pathname is "%v").%.', 99,
  2068.                              session_log_pathname);
  2069.                end;
  2070.             else
  2071.                call tnou ('OFF', 3);
  2072.          end;
  2073.  
  2074.       when (show_amlc)
  2075.          do;
  2076.             call tnoua ('Asynchronous line to use ............ ', 38);
  2077.             if use_amlc_line then
  2078.                call ioa$ ('%d (decimal)%.', 99, amlc_line);
  2079.             else
  2080.                call tnou ('NONE', 4);
  2081.          end;
  2082.  
  2083.       when (show_escape)
  2084.          do;
  2085.             call tnoua ('Escape character is ................. "', 39);
  2086.             if clr8 (escape_char) < space_7bit_asc then
  2087.                call tnoua ('^' || ctl (escape_char), 2);
  2088.             else
  2089.                call tnoua (escape_char, 1);
  2090.             call tnou ('"', 1);
  2091.          end;
  2092.  
  2093.       when (show_baud)
  2094.          do;
  2095.             call tnoua ('Baud rate to use is ................. ', 38);
  2096.  
  2097.             select (baud_rate);
  2098.                when (0)
  2099.                   call tnou ('CLOCK (Default = 9600).', 23);
  2100.  
  2101.                when (-1)
  2102.                   call tnou ('JUMPER_1 (Default = 75).', 24);
  2103.  
  2104.                when (-2)
  2105.                   call tnou ('JUMPER_2 (Default = 150).', 25);
  2106.  
  2107.                when (-3)
  2108.                   call tnou ('JUMPER_3 (Default = 1800).', 26);
  2109.  
  2110.                otherwise
  2111.                   call ioa$ ('%:2d%.', 99, baud_rate);
  2112.             end;
  2113.          end;
  2114.  
  2115.       when (ambiguous_cmd)
  2116.          call ioa$ (
  2117.               'Ambiguous SHOW option "%v". Type HELP for a list of options.%.',
  2118.                     99, cmd_option);
  2119.  
  2120.       otherwise
  2121.          call ioa$ (
  2122.            'Unrecognized SHOW option "%v". Type HELP for a list of options.%.',
  2123.                     99, cmd_option);
  2124.  
  2125.    end;      /* select */
  2126.  
  2127.    return;
  2128.  
  2129.    end;    /* Comnd_show */
  2130.  
  2131. /* ******************************* Comnd_set ******************************* */
  2132.  
  2133. Comnd_set : proc;
  2134.  
  2135. Dcl baud_table (0 : 31) fixed bin (31) static init (110, 134, 300, 1200, 600,
  2136.                75, 150, 1800, 200, 100, 50, -1, 2400, 4800, 9600, 19200, 48000,
  2137.                56000, 64000, -1 ,-1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 3600,
  2138.                7200);
  2139.  
  2140. %Replace set_len by 16;
  2141.  
  2142. Dcl set_state (set_len) char (16) var static init (
  2143.           'DELAY',
  2144.           'RETRIES',
  2145.           'TIMEOUT',
  2146.           'PARITY',
  2147.           'QUOTE',
  2148.           '8QUOTE',
  2149.           'WINDOW',
  2150.           'FILE_TYPE',
  2151.           'POUND',
  2152.           'INCOMPLETE',
  2153.           'ATTRIBUTES',
  2154.           'REPEAT',
  2155.           'WARNING',
  2156.           'LINE',
  2157.           'ESCAPE',
  2158.           'BAUD');
  2159.  
  2160. %Replace set_delay by 1,
  2161.          set_retries by 2,
  2162.          set_timeout by 3,
  2163.          set_parity by 4,
  2164.          set_quote by 5,
  2165.          set_8quote by 6,
  2166.          set_wsize by 7,
  2167.          set_store by 8,
  2168.          set_pound by 9,
  2169.          set_incomplete by 10,
  2170.          set_attributes by 11,
  2171.          set_repeat by 12,
  2172.          set_warning by 13,
  2173.          set_amlc by 14,
  2174.          set_escape by 15,
  2175.          set_baud by 16;
  2176.  
  2177. /* ************************************************************************* */
  2178.  
  2179.    if cmd_option = 'FT' then
  2180.       cmd_option = 'FILE_TYPE';
  2181.  
  2182.    if cmd_option = 'RETRY' then
  2183.       cmd_option = 'RETRIES';
  2184.  
  2185.    command = type (cmd_option, addr (set_state), set_len);
  2186.    cmd_option = token(3);
  2187.  
  2188.    select (command);
  2189.  
  2190.       when (set_delay)
  2191.          if num_tok < 3 then
  2192.             call ioa$ (
  2193.    'No DELAY time given, the current value of %d seconds will be unchanged.%.',
  2194.                        99, delay);
  2195.          else
  2196.             if verify (cmd_option, '0123456789') ^= 0 then
  2197.                call ioa$ ('Invalid DELAY time given "%v".%.', 99, cmd_option);
  2198.             else                 /* Everything is okay at this point. */
  2199.                do;
  2200.                   delay = bin (cmd_option, 15);
  2201.                   call comnd_show (show_delay);
  2202.                end;
  2203.  
  2204.       when (set_retries)
  2205.          if num_tok < 3 then
  2206.             do;
  2207.                call tnou (
  2208.                  'No RETRIES count given, the current value will be unchanged.',
  2209.                           60);
  2210.                call comnd_show (show_retries);
  2211.             end;
  2212.          else
  2213.             if verify (cmd_option, '0123456789') ^= 0 then
  2214.               call ioa$ ('Invalid RETRIES count given "%v".%.', 99, cmd_option);
  2215.             else
  2216.                do;
  2217.                   i = bin (cmd_option, 15);
  2218.                   if i = 0 then
  2219.                      call tnou (
  2220.          'Specified RETRIES value is out of range. It must be greater than 0.',
  2221.                                 67);
  2222.                   else
  2223.                      do;
  2224.                         max_retries = i;
  2225.                         call comnd_show (show_retries);
  2226.                      end;
  2227.                end;
  2228.  
  2229.       when (set_timeout)
  2230.          if num_tok < 3 then
  2231.             do;
  2232.                call tnou (
  2233.                  'No TIMEOUT given, the current value will be unchanged.', 54);
  2234.                call comnd_show (show_timeout);
  2235.             end;
  2236.          else
  2237.             if verify (cmd_option, '0123456789') ^= 0 then
  2238.               call ioa$ ('Invalid TIMEOUT given "%v".%.', 99, cmd_option);
  2239.             else
  2240.                do;
  2241.                   i = bin (cmd_option, 15);
  2242.                   if i > 94 then
  2243.                      call tnou (
  2244.       'Specified TIMEOUT is out of range. It must be between 0 and 94 seconds.',
  2245.                                 71);
  2246.                   else
  2247.                      do;
  2248.                         loc_timeout = i;
  2249.                         call comnd_show (show_timeout);
  2250.                      end;
  2251.                end;
  2252.  
  2253.       when (set_parity)
  2254.          do;
  2255.             ok = false;
  2256.  
  2257.             if cmd_option = 'M' | cmd_option = 'MARK' then
  2258.                do;
  2259.                   ok = true;
  2260.                   do_transparent = false;
  2261.                   do_8bit_chks = false;
  2262.                   if loc_8quote_chr = 'Y' | loc_8quote_chr = 'N' then
  2263.                      do;
  2264.                         call tnoua ('WARNING : 8-bit quoting MUST be used', 36);
  2265.                         call tnoua (' with MARK parity for binary', 28);
  2266.                         call tnou (' file transfers.', 16);
  2267.                         call comnd_show (show_8quote);
  2268.                      end;
  2269.                   call comnd_show (show_parity);
  2270.                end;
  2271.             else
  2272.                if cmd_option = 'N' | cmd_option = 'NONE' then
  2273.                   do;
  2274.                      ok = true;
  2275.                      do_transparent = true;
  2276.                      do_8bit_chks = true;
  2277.                      call comnd_show (show_parity);
  2278.                   end;
  2279.                else
  2280.                   if length (cmd_option) = 0 then
  2281.                      do;
  2282.                         call tnou (
  2283.          'No PARITY option given. The current setting will be unchanged.', 62);
  2284.                         call comnd_show (show_parity);
  2285.                      end;
  2286.                   else
  2287.                      call ioa$ ('Invalid PARITY option given "%v".%.', 99,
  2288.                                 cmd_option);
  2289.  
  2290.             if ok & use_amlc_line then
  2291.                do;
  2292.                   call assign (0, amlc_line, code);
  2293.                   if code = 0 then
  2294.                      call assign (1, amlc_line, code);
  2295.  
  2296.                   if code > 0 then
  2297.                      do;
  2298.                         amlc_line = -1;
  2299.                         use_amlc_line = false;
  2300.                         call get_error_msg (code);
  2301.                         call ioa$ (
  2302.                              'Unable to change the parity on the line.%.',
  2303.                                    99, errmsg);
  2304.                         call tnou ('No asynchronous line currently set.', 35);
  2305.                      end;
  2306.                end;
  2307.          end;
  2308.  
  2309.       when (set_quote)
  2310.          if length (cmd_option) > 1 then
  2311.             do;
  2312.                call ioa$ ('Invalid control quoting character given "%v".%.',
  2313.                           99, cmd_option);
  2314.                call tnou ('Only one character may be specified.', 36);
  2315.             end;
  2316.          else
  2317.             select (cmd_option);
  2318.  
  2319.                when ('')
  2320.                   do;
  2321.                      call tnou (
  2322.   'No control quoting character given. The current setting will be unchanged.',
  2323.                                 74);
  2324.                      call comnd_show (show_quote);
  2325.                   end;
  2326.  
  2327.                when (loc_8quote_chr)
  2328.                   do;
  2329.                      call ioa$ (
  2330.                              'Invalid control quoting character given "%v".%.',
  2331.                                 99, cmd_option);
  2332.                      call tnou (
  2333.                        'It is the same as the 8-bit quoting character.%.', 46);
  2334.                   end;
  2335.  
  2336.                when (loc_rep_chr)
  2337.                   do;
  2338.                      call ioa$ (
  2339.                              'Invalid control quoting character given "%v".%.',
  2340.                                 99, cmd_option);
  2341.                      call tnou (
  2342.                          'It is the same as the repeat character prefix.', 46);
  2343.                   end;
  2344.  
  2345.                otherwise
  2346.                   if cmd_option < space_8bit_asc | cmd_option > '~' then
  2347.                      do;
  2348.                         call tnoua ('Invalid control quoting character given.',
  2349.                                     40);
  2350.                         call tnou (' It must be a printable ASCII character.',
  2351.                                    40);
  2352.                      end;
  2353.                   else
  2354.                      do;
  2355.                         loc_quote_chr = cmd_option;
  2356.                         call comnd_show (show_quote);
  2357.                      end;
  2358.             end;
  2359.  
  2360.       when (set_8quote)
  2361.          if length (cmd_option) > 1 then
  2362.             do;
  2363.                call ioa$ ('Invalid 8-bit quoting character given "%v".%.', 99,
  2364.                           cmd_option);
  2365.                call tnou ('Only one character may be specified.', 36);
  2366.             end;
  2367.          else
  2368.             select (cmd_option);
  2369.  
  2370.                when ('')
  2371.                   do;
  2372.                      call tnou (
  2373. 'No 8-bit quoting character given. The current setting will be unchanged.', 72);
  2374.                      call comnd_show (show_8quote);
  2375.                   end;
  2376.  
  2377.                when (loc_quote_chr)
  2378.                   do;
  2379.                      call ioa$ ('Invalid 8-bit quoting character given "%v".%.'
  2380.                                 , 99, cmd_option);
  2381.                      call tnou (
  2382.                         'It is the same as the control quoting character.',
  2383.                                 48);
  2384.                   end;
  2385.  
  2386.                when (loc_rep_chr)
  2387.                   do;
  2388.                      call ioa$ ('Invalid 8-bit quoting character given "%v".%.'
  2389.                                 , 99, cmd_option);
  2390.                      call tnou (
  2391.                          'It is the same as the repeat character prefix.', 46);
  2392.                   end;
  2393.  
  2394.                otherwise
  2395.                   do;
  2396.                      loc_8quote_chr = cmd_option;
  2397.                      if ^do_transparent &
  2398.                         (cmd_option <= space_8bit_asc |
  2399.                         (cmd_option > '>' & cmd_option < grave_8bit_asc) |
  2400.                         cmd_option > '~') then
  2401.                         do;
  2402.                            call tnoua ('WARNING : 8-bit quoting MUST be ', 32);
  2403.                            call tnou (
  2404.                        'used with MARK parity for binary file transfers.', 48);
  2405.                            call comnd_show (show_parity);
  2406.                         end;
  2407.                      call comnd_show (show_8quote);
  2408.                   end;
  2409.             end;
  2410.  
  2411.       when (set_repeat)
  2412.          if length (cmd_option) > 1 then
  2413.             do;
  2414.                call ioa$ ('Invalid repeat character prefix given "%v".%.',
  2415.                           99, cmd_option);
  2416.                call tnou ('Only one character may be specified.', 36);
  2417.             end;
  2418.          else
  2419.             select (cmd_option);
  2420.  
  2421.                when (loc_quote_chr)
  2422.                   do;
  2423.                      call ioa$ ('Invalid repeat character prefix given "%v".%.'
  2424.                                 , 99, cmd_option);
  2425.                      call tnou (
  2426.                        'It is the same as the control quoting character.', 48);
  2427.                   end;
  2428.  
  2429.                when (loc_8quote_chr)
  2430.                   do;
  2431.                      call ioa$ ('Invalid repeat character prefix given "%v".%.'
  2432.                                 , 99, cmd_option);
  2433.                      call tnou (
  2434.                          'It is the same as the 8-bit quoting character.', 46);
  2435.                   end;
  2436.  
  2437.                otherwise
  2438.                   if (cmd_option  < space_8bit_asc
  2439.                       | (cmd_option > '>' & cmd_option < grave_8bit_asc)
  2440.                       | cmd_option > '~') & length (cmd_option) ^= 0 then
  2441.                      do;
  2442.                         call tnoua ('Invalid repeat character prefix given.',
  2443.                                    38);
  2444.                         call tnou (' It must be a printable ASCII character.',
  2445.                                    40);
  2446.                      end;
  2447.                   else
  2448.                      do;
  2449.                         if length (cmd_option) = 0 then
  2450.                            cmd_option = space_8bit_asc;
  2451.  
  2452.                         loc_rep_chr = cmd_option;
  2453.                         call comnd_show (show_repeat);
  2454.                      end;
  2455.             end;
  2456.  
  2457.       when (set_wsize)
  2458.          if num_tok < 3 then
  2459.             do;
  2460.                call tnou (
  2461.                   'No WINDOW size given, the current value will be unchanged.',
  2462.                           58);
  2463.                call comnd_show (show_wsize);
  2464.             end;
  2465.          else
  2466.             if verify (cmd_option, '0123456789') ^= 0 then
  2467.                call ioa$ ('Invalid WINDOW size given "%v".%.', 99, cmd_option);
  2468.             else
  2469.                do;
  2470.                   i = bin (cmd_option, 15);
  2471.                   if i = 0 | i > 31 then
  2472.                      call tnou (
  2473.    'Specified WINDOW size out of range. It must be between 1 and 31 inclusive.',
  2474.                                 74);
  2475.                   else
  2476.                      do;
  2477.                         loc_max_wsize = i;
  2478.                         call comnd_show (show_wsize);
  2479.                      end;
  2480.                end;
  2481.  
  2482.       when (set_store)
  2483.          select (cmd_option);
  2484.  
  2485.             when ('AU', 'AUTO', 'AUTOMATIC')
  2486.                do;
  2487.                   file_type = automatic_ft;
  2488.                   explicit_ft_set = false;
  2489.                   if ^explicit_pound_set then   /* Reset this in case it got */
  2490.                      pound_conversion = true;   /* set before. */
  2491.                   call comnd_show (show_store);
  2492.                end;
  2493.  
  2494.             when ('AS', 'ASC', 'ASCII', 'T', 'TEXT')
  2495.                do;
  2496.                   file_type = ascii_ft;
  2497.                   explicit_ft_set = true;
  2498.                   if ^explicit_pound_set then
  2499.                      pound_conversion = true;
  2500.                   call comnd_show (show_store);
  2501.                end;
  2502.  
  2503.             when ('B', 'BIN', 'BINARY', 'I', 'IMAGE')
  2504.                do;
  2505.                   file_type = binary_ft;
  2506.                   explicit_ft_set = true;
  2507.                   if ^explicit_pound_set then
  2508.                      pound_conversion = false;
  2509.                   call comnd_show (show_store);
  2510.                end;
  2511.  
  2512.             when ('')
  2513.                do;
  2514.                   call tnou (
  2515.              'No file type given. The current setting will be unchanged.', 58);
  2516.                   call comnd_show (show_store);
  2517.                end;
  2518.  
  2519.             otherwise
  2520.                call ioa$ ('Invalid file type "%v".%.', 99, cmd_option);
  2521.  
  2522.          end;
  2523.  
  2524.       when (set_pound)
  2525.          select (cmd_option);
  2526.  
  2527.             when ('ON', 'Y', 'YES')
  2528.                do;
  2529.                   pound_conversion = true;
  2530.                   explicit_pound_set = true;
  2531.                   call comnd_show (show_pound);
  2532.                end;
  2533.  
  2534.             when ('OFF', 'N', 'NO')
  2535.                do;
  2536.                   pound_conversion = false;
  2537.                   explicit_pound_set = true;
  2538.                   call comnd_show (show_pound);
  2539.                end;
  2540.  
  2541.             when ('')
  2542.                do;
  2543.                   call tnou (
  2544.           'No POUND option given. The current setting will be unchanged.', 61);
  2545.                   call comnd_show (show_pound);
  2546.                end;
  2547.  
  2548.             otherwise
  2549.                call ioa$ ('Invalid POUND option "%v".%.', 99, cmd_option);
  2550.  
  2551.          end;
  2552.  
  2553.       when (set_incomplete)
  2554.          select (cmd_option);
  2555.  
  2556.             when ('D', 'DEL', 'DELETE', 'DISCARD')
  2557.                do;
  2558.                   del_incomplete = true;
  2559.                   call comnd_show (show_incomplete);
  2560.                end;
  2561.  
  2562.             when ('S', 'SAVE', 'KEEP')
  2563.                do;
  2564.                   del_incomplete = false;
  2565.                   call comnd_show (show_incomplete);
  2566.                end;
  2567.  
  2568.             when ('')
  2569.                do;
  2570.                   call tnou (
  2571.       'No INCOMPLETE option given, the current setting will be unchanged.', 66);
  2572.                   call comnd_show (show_incomplete);
  2573.                end;
  2574.  
  2575.             otherwise
  2576.                call ioa$ ('Invalid INCOMPLETE option "%v".%.', 99, cmd_option);
  2577.  
  2578.          end;
  2579.  
  2580.       when (set_attributes)
  2581.          select (cmd_option);
  2582.  
  2583.             when ('ON', 'Y', 'YES')
  2584.                use_attributes = true;
  2585.  
  2586.             when ('OFF', 'N', 'NO')
  2587.                use_attributes = false;
  2588.  
  2589.             when ('')
  2590.                do;
  2591.                   call tnou (
  2592.       'No ATTRIBUTES option given, the current setting will be unchanged.', 66);
  2593.                   call comnd_show (show_attributes);
  2594.                end;
  2595.  
  2596.             otherwise
  2597.                call ioa$ ('Invalid ATTRIBUTES option "%v".%.', 99, cmd_option);
  2598.  
  2599.          end;
  2600.  
  2601.       when (set_warning)
  2602.          select (cmd_option);
  2603.  
  2604.             when ('ON', 'Y', 'YES')
  2605.                filename_warning = true;
  2606.  
  2607.             when ('OFF', 'N', 'NO')
  2608.                filename_warning = false;
  2609.  
  2610.             when ('')
  2611.                do;
  2612.                   call tnou (
  2613.    'No file name WARNING option given, the current setting will be unchanged.',
  2614.                              73);
  2615.                   call comnd_show (show_warning);
  2616.                end;
  2617.  
  2618.             otherwise
  2619.                call ioa$ ('Invalid file name WARNING option "%v".%.', 99,
  2620.                           cmd_option);
  2621.  
  2622.          end;
  2623.  
  2624.       when (set_amlc)
  2625.          if verify (cmd_option, '0123456789') ^= 0 then
  2626.             call ioa$ ('Invalid line number specified "%v".%.', 99, cmd_option);
  2627.          else
  2628.             do;
  2629.                if use_amlc_line then    /* Unassign any lines first. */
  2630.                   do;
  2631.                      use_amlc_line = false;
  2632.                      call assign (0, amlc_line, code);
  2633.                      if code > 0 then
  2634.                         do;
  2635.                            call get_error_msg (code);
  2636.                            call ioa$ ('Unable to unassign line %d. %v%.',
  2637.                                       99, amlc_line, errmsg);
  2638.                         end;
  2639.  
  2640.                      amlc_line = -1;
  2641.                   end;
  2642.  
  2643.                if length (cmd_option) > 0 then
  2644.                   do;                    /* Now assign our new line. */
  2645.                      amlc_line = bin (cmd_option, 15);
  2646.  
  2647.                      call assign (1, amlc_line, code);
  2648.                      if code > 0 then
  2649.                         do;
  2650.                            call get_error_msg (code);
  2651.                            call ioa$ ('Unable to assign line %d. %v%.',
  2652.                                       99, amlc_line, errmsg);
  2653.                            amlc_line = -1;
  2654.                         end;
  2655.  
  2656.                      use_amlc_line = (amlc_line >= 0);
  2657.                   end;
  2658.  
  2659.                call comnd_show (show_amlc);
  2660.             end;
  2661.  
  2662.       when (set_escape)
  2663.          if length (cmd_option) = 0 then
  2664.             do;
  2665.                call tnou (
  2666.      'No ESCAPE character given. The current setting will be unchanged.', 65);
  2667.                call comnd_show (show_escape);
  2668.             end;
  2669.          else
  2670.             do;
  2671.                tempstr = ctl_trans (ok, cmd_option);
  2672.                if length (tempstr) ^= 1 then
  2673.                   do;
  2674.                      if ^ok then
  2675.                         call ioa$ ('Invalid ESCAPE character(s) given "%v".%.',
  2676.                                    cmd_option);
  2677.                      else
  2678.                         call tnoua ('More than one ESCAPE character given. ',
  2679.                                     38);
  2680.  
  2681.                      call tnou ('The current setting will be unchanged.', 38);
  2682.                      call comnd_show (show_escape);
  2683.                   end;
  2684.                else
  2685.                   do;
  2686.                      escape_char = set8 (substr (tempstr, 1, 1));
  2687.                      call comnd_show (show_escape);
  2688.                   end;
  2689.             end;
  2690.  
  2691.       when (set_baud)
  2692.          if length (cmd_option) = 0 then
  2693.             do;
  2694.                call tnou (
  2695.                'No BAUD rate given. The current value will be unchanged.', 56);
  2696.                call comnd_show (show_baud);
  2697.             end;
  2698.          else
  2699.             do;
  2700.                code = 0;
  2701.  
  2702.                select (cmd_option);
  2703.  
  2704.                   when ('134', '134.5')
  2705.                      do;
  2706.                         baud_rate = 134;
  2707.                         baud_rate_index = 1;
  2708.                      end;
  2709.  
  2710.                   when ('CLOCK')
  2711.                      baud_rate = 0;
  2712.  
  2713.                   when ('J1', 'JUMPER_1', 'JUMPER1')
  2714.                      baud_rate = -1;
  2715.  
  2716.                   when ('J2', 'JUMPER_2', 'JUMPER2')
  2717.                      baud_rate = -2;
  2718.  
  2719.                   when ('J3', 'JUMPER_3', 'JUMPER3')
  2720.                      baud_rate = -3;
  2721.  
  2722.                   otherwise
  2723.                      if verify (cmd_option, '0123456789') ^= 0 then
  2724.                         do;
  2725.                            code = e$barg;
  2726.                            call ioa$ ('Invalid BAUD rate given "%v".%.', 99,
  2727.                                       cmd_option);
  2728.                         end;
  2729.                      else
  2730.                         do;
  2731.                            new_baud_rate = bin (cmd_option, 31);
  2732.  
  2733.                            ok = false;
  2734.                            do baud_rate_index = 0 to 31 until (ok);
  2735.                               ok = (baud_table(baud_rate_index) =new_baud_rate);
  2736.                            end;
  2737.  
  2738.                            if ok then
  2739.                               baud_rate = new_baud_rate;
  2740.                            else
  2741.                               do;
  2742.                                  code = e$vnfc;
  2743.  
  2744.                                  call tnou (
  2745.            'Unsupported BAUD rate. The current setting will be unchanged.', 61);
  2746.                                  if old_primos_revision then
  2747.                                     do;
  2748.                                        call tnoua (
  2749.           'Supported values are 110, 134, 300, 1200, CLOCK (Default = ', 59);
  2750.                                        call ioa$ (
  2751.           '9600), %/%21xJUMPER_1 (Default = 75), JUMPER_2 (Default = %$', 99);
  2752.                                        call ioa$ (
  2753.           '150),%/%21xand JUMPER_3 (Default = 1800).%.', 99);
  2754.                                     end;
  2755.  
  2756.                                  call comnd_show (show_baud);
  2757.                               end;
  2758.                         end;
  2759.                end;
  2760.  
  2761.                if code = 0 then
  2762.                   do;
  2763.                      if use_amlc_line then
  2764.                         do;
  2765.                            call assign (0, amlc_line, code);
  2766.                            if code = 0 then
  2767.                               call assign (1, amlc_line, code);
  2768.  
  2769.                            if code > 0 then
  2770.                               do;
  2771.                                  amlc_line = -1;
  2772.                                  use_amlc_line = false;
  2773.                                  call get_error_msg (code);
  2774.                                  call ioa$ (
  2775.                                         'Unable to change the baud rate. %v%.',
  2776.                                          99, errmsg);
  2777.                                  call tnou (
  2778.                                     'No asynchronous line currently set.', 35);
  2779.                               end;
  2780.                         end;
  2781.  
  2782.                      if code = 0 then
  2783.                         call comnd_show (show_baud);
  2784.                   end;
  2785.             end;
  2786.  
  2787.       when (ambiguous_cmd)
  2788.          do;
  2789.             call ioa$ ('Ambiguous SET option "%v". %$', 99, token(2));
  2790.             call tnou ('Type HELP for a list of options.', 32);
  2791.          end;
  2792.  
  2793.       otherwise
  2794.          do;
  2795.             call ioa$ ('Unrecognized SET option "%v". %$', 99, token(2));
  2796.             call tnou ('Type HELP for a list of options.', 32);
  2797.          end;
  2798.  
  2799.    end;     /* select */
  2800.  
  2801.    return;
  2802.  
  2803.    end;   /* Comnd_set */
  2804.  
  2805. /* ********************************* Type ********************************** */
  2806.  
  2807. /* TYPE -- determine command type from a list of possibilities. */
  2808.  
  2809. Type : proc (str, table_ptr, table_len) returns (fixed bin);
  2810.  
  2811. Dcl str char (128) var,
  2812.     table_ptr ptr,
  2813.     table_len fixed bin;
  2814.  
  2815. Dcl (str_len, entry_found, i) fixed bin,
  2816.     table_entry char (16) var,
  2817.     table (1) char (16) var based;
  2818.  
  2819. /* ************************************************************************* */
  2820.  
  2821.    entry_found = 0;
  2822.    str_len = length (str);
  2823.  
  2824.    do i = 1 to table_len;
  2825.       table_entry = table_ptr -> table(i);
  2826.  
  2827.       if length (table_entry) >= str_len then
  2828.          if substr (table_entry, 1, str_len) = str then
  2829.             if entry_found ^= 0 then
  2830.                return (ambiguous_cmd);   /* More than one match found! */
  2831.             else
  2832.                entry_found = i;
  2833.    end;
  2834.  
  2835.    return (entry_found);
  2836.  
  2837.    end;          /* Type */
  2838.  
  2839. /* ******************************* Tokenize ******************************** */
  2840.  
  2841. Tokenize : proc (buff);
  2842.  
  2843. Dcl buff char (160) var;
  2844.  
  2845. /* ************************************************************************* */
  2846.  
  2847.    /* A command line is passed back split up into tokens. The code only
  2848.       expects and handles 3 options, any others are ignored. The rest of
  2849.       the line after the command is also stored intact since it is used
  2850.       by some commands.                                                   */
  2851.  
  2852.    do num_tok = 1 to num_tokens;
  2853.       token(num_tok) = '';
  2854.    end;
  2855.  
  2856.    cmd_data = trim (after (buff, space_8bit_asc), '11'b);
  2857.  
  2858.    buff = translate (buff, uppercase || space_8bit_asc, lowercase || ',');
  2859.  
  2860.    buff = trim (buff, '11'b);
  2861.  
  2862.    do num_tok = 1 to num_tokens while (length (buff) ^= 0);
  2863.       token(num_tok) = before (buff, space_8bit_asc);
  2864.       buff = trim (after (buff, space_8bit_asc), '11'b);
  2865.    end;
  2866.  
  2867.    num_tok = num_tok - 1;
  2868.  
  2869.    return;
  2870.  
  2871.    end;           /* Tokenize */
  2872.  
  2873. /* ****************************** Comi_hndlr ******************************* */
  2874.  
  2875. Comi_hndlr : proc (point);
  2876.  
  2877. Dcl point ptr;
  2878.  
  2879. /* ************************************************************************* */
  2880.  
  2881.    /* This on-unit for the condition COMI_EOF$ makes life easier by treating
  2882.       the condition just as if the user had issued a POP command. We must
  2883.       remember that we were here though, so that the prompts come out okay.
  2884.    */
  2885.  
  2886.    from_comi_hndlr = true;
  2887.  
  2888.    go to comi_point;
  2889.  
  2890.    end;        /* Comi_hndlr */
  2891.  
  2892. /* ******************************* Get_unit ******************************** */
  2893.  
  2894. Get_unit : proc (code) returns (fixed bin);
  2895.  
  2896. Dcl code fixed bin;
  2897.  
  2898. Dcl (unit, rnw) fixed bin,
  2899.     pos fixed bin (31);
  2900.  
  2901. /* ************************************************************************* */
  2902.  
  2903.    code = 0;
  2904.    unit = 0;
  2905.  
  2906.    /* We start the file unit numbers at 7 to allow the lower ones to be used
  2907.       by other programs and, if the user PUSHes, commands like LISTING and
  2908.       BINARY (which use units 2 and 3) may also be used. The upper limit can,
  2909.       at the moment, only be guessed at. To allow a "decent" number of TAKE's
  2910.       to be nested we have used the figure of 127. This may need to be
  2911.       changed by other sites.
  2912.    */
  2913.  
  2914.    do unit = 7 to 127 until (code = e$unop);
  2915.       call prwf$$ (k$rpos, unit, null (), 0, pos, rnw, code);
  2916.    end;
  2917.  
  2918.    if code = 0 | code = e$dire | code = e$bunt then
  2919.       code = e$fuiu;
  2920.  
  2921.    if code = e$unop then
  2922.       code = 0;
  2923.    else
  2924.       unit = 0;
  2925.  
  2926.    return (unit);
  2927.  
  2928.    end;        /* Get_unit */
  2929.  
  2930.    end;      /* Comnd */
  2931. -------------------------------------------------------------------------------
  2932.  
  2933. /* CONNECT -- Connect to a remote system in transparent mode. */
  2934.  
  2935. Connect : proc (newline);
  2936.  
  2937. Dcl newline fixed bin;
  2938.  
  2939. $Insert *>insert>common.ins.plp
  2940. $Insert *>insert>kermit.ins.plp
  2941. $Insert *>insert>primos.ins.plp
  2942. $Insert *>insert>constants.ins.plp
  2943. $Insert syscom>errd.ins.pl1
  2944.  
  2945. Dcl (tty, code, temp, i) fixed bin,
  2946.     statv (2) fixed bin,
  2947.     (exit, escape_seen) bit (1) aligned,
  2948.     (chr, tempchr, ctrl_p) char,
  2949.     tempbuffer char (256) var,
  2950.     bufferfrom char (256),
  2951.     bufferfrom_ptr ptr;
  2952.  
  2953. %Replace sleep_interval by 100;
  2954.  
  2955. /* ************************************************************************* */
  2956.  
  2957.    exit = false;
  2958.    escape_seen = false;
  2959.    bufferfrom_ptr = addr (bufferfrom);
  2960.    ctrl_p = ctl ('P');
  2961.    tty = duplx$ (my_half_duplex);
  2962.  
  2963.    call ioa$ ('%/Starting connection to remote system...%/Press <%$', 99);
  2964.  
  2965.    if clr8 (escape_char) < space_7bit_asc then
  2966.       call tnoua ('^' || ctl (escape_char), 2);
  2967.    else
  2968.       call tnoua (escape_char, 1);
  2969.  
  2970.    if clr8 (abort_char) < space_7bit_asc then
  2971.       call tnoua ('^' || ctl (abort_char), 2);
  2972.    else
  2973.       call tnoua (abort_char, 1);
  2974.  
  2975.    call ioa$ ('> to return to command mode.%/%.', 99);
  2976.  
  2977.    if newline ^= amlc_line then      /* See if we are using another line. */
  2978.       do;
  2979.          call assign (1, newline, code);
  2980.          if code ^= 0 then
  2981.             do;
  2982.                tty = duplx$ (my_duplex);
  2983.                call get_error_msg (code);
  2984.                call ioa$ ('Unable to assign line %d. %v%.', 99,
  2985.                           newline, errmsg);
  2986.                return;
  2987.             end;
  2988.       end;
  2989.  
  2990.    if length (saved_amlc_chrs) > 0 then
  2991.       do;
  2992.          call tnoua ((saved_amlc_chrs), length (saved_amlc_chrs));
  2993.          saved_amlc_chrs = '';
  2994.       end;
  2995.  
  2996.    do while (^exit);
  2997.  
  2998.       do while (tty$in ());             /* Handle terminal input. */
  2999.          call c1in (char2);
  3000.          chr = char2(2);
  3001.          tempchr = translate (chr, uppercase, lowercase);
  3002.  
  3003.          if escape_seen then            /* Handle escape sequences. */
  3004.             select (tempchr);
  3005.  
  3006.                when (abort_char)        /* Close the connection. */
  3007.                   exit = true;
  3008.  
  3009.                when (break_char)        /* Send a break character. */
  3010.                   do;
  3011.                      escape_seen = false;
  3012.                      code = send_amlc (newline, ctrl_p, 1);
  3013.                      if code ^= 0 then
  3014.                         do;
  3015.                            exit = true;
  3016.                            call tnou ('Unable to send break character.', 31);
  3017.                         end;
  3018.                   end;
  3019.  
  3020.                when (escape_char)       /* Send the escape character itself. */
  3021.                   do;
  3022.                      escape_seen = false;
  3023.                      code = send_amlc (newline, escape_char, 1);
  3024.                      if code ^= 0 then
  3025.                         do;
  3026.                            exit = true;
  3027.                            call tnou ('Unable to send escape character.', 32);
  3028.                         end;
  3029.                   end;
  3030.  
  3031.                when ('0')               /* Send a NUL character. */
  3032.                   do;
  3033.                      escape_seen = false;
  3034.                      code = send_amlc (newline, nul_8bit_asc, 1);
  3035.                      if code ^= 0 then
  3036.                         do;
  3037.                            exit = true;
  3038.                            call tnou ('Unable to send NUL character.', 29);
  3039.                         end;
  3040.                   end;
  3041.  
  3042.                otherwise
  3043.                   escape_seen = false;
  3044.  
  3045.             end;      /* Select */
  3046.          else
  3047.             if tempchr = escape_char then
  3048.                escape_seen = true;
  3049.             else
  3050.                do;
  3051.                   if clr8 (chr) = lf_7bit_asc then
  3052.                      chr = cr_7bit_asc;
  3053.  
  3054.                   code = send_amlc (newline, chr, 1);
  3055.                   if code ^= 0 then
  3056.                      do;
  3057.                         exit = true;
  3058.                         call tnou ('Unable to send data.', 20);
  3059.                      end;
  3060.                end;
  3061.       end;   /* Do while */
  3062.  
  3063.    /* Handle input coming up the line. */
  3064.  
  3065.       call t$amlc (newline, bufferfrom_ptr, 256, 6, statv, 1, code);
  3066.       if code ^= 0 then
  3067.          do;
  3068.             exit = true;
  3069.             call tnou ('Unable to receive data on assigned line.', 40);
  3070.          end;
  3071.  
  3072.       do while (statv(1) > 0);
  3073.  
  3074.          call tnoua (bufferfrom, statv(1));
  3075.  
  3076.          if session_log_opened then
  3077.             do;
  3078.                tempbuffer = '';
  3079.                char2(1) = nul_7bit_asc;
  3080.  
  3081.                do i = 1 to statv(1);
  3082.                   char2(2) = set8 (substr (bufferfrom, i, 1));
  3083.                   temp = char2_ptr -> fb15_based;
  3084.                   if temp ^= 128 then
  3085.                      if temp < 160 & temp ^= cr_8bit_dec &
  3086.                                      temp ^= lf_8bit_dec then
  3087.                         tempbuffer = tempbuffer || '^' || ctl (char2(2));
  3088.                      else
  3089.                         tempbuffer = tempbuffer || char2(2);
  3090.                end;
  3091.  
  3092.                call log_info (session_log, tempbuffer);
  3093.             end;
  3094.  
  3095.          call t$amlc (newline, bufferfrom_ptr, 256, 6, statv, 1, code);
  3096.          if code ^= 0 then
  3097.             do;
  3098.                exit = true;
  3099.                call tnou ('Unable to receive data on assigned line.', 40);
  3100.             end;
  3101.  
  3102.       end;    /* Do while */
  3103.  
  3104.       call sleep$ (sleep_interval);        /* Wait awhile. */
  3105.  
  3106.    end;    /* Do while */
  3107.  
  3108.    if newline ^= amlc_line then
  3109.       do;
  3110.          call assign (0, newline, code);
  3111.          if code ^= 0 then
  3112.             do;
  3113.                call get_error_msg (code);
  3114.                call ioa$ ('Unable to unassign line %d. %v%.', 99,
  3115.                           newline, errmsg);
  3116.             end;
  3117.       end;
  3118.  
  3119.    tty = duplx$ (my_duplex);
  3120.  
  3121.    call ioa$ ('%/Returning to command mode...%/%.', 99);
  3122.  
  3123.    return;
  3124.  
  3125.    end;       /* Connect */
  3126. -------------------------------------------------------------------------------
  3127.  
  3128. /* CONVERT_FILE -- Convert uploaded file to Primos text file. */
  3129.  
  3130. Convert_file : proc returns (fixed bin);
  3131.  
  3132. $Insert *>insert>common.ins.plp
  3133. $Insert *>insert>kermit.ins.plp
  3134. $Insert *>insert>primos.ins.plp
  3135. $Insert *>insert>constants.ins.plp
  3136. $Insert syscom>keys.ins.pl1
  3137. $Insert syscom>errd.ins.pl1
  3138.  
  3139. Dcl temp_pathname char (128) var,
  3140.     buffer char (1026) var,      /* This MUST be at least IBUFFER_SIZE + 2. */
  3141.     (temp_filename, basename) char (32) var,
  3142.     (code, type, nw, i, unit2, rnw, sufusd) fixed bin,
  3143.     fn char (13),
  3144.     unique_bits char (6) aligned,
  3145.     (char_ptr, buff_ptr) ptr,
  3146.     (character, last_char) char (1);
  3147.  
  3148. Dcl 1 bit_char based,
  3149.       2 high_bit bit (1),
  3150.       2 next_bits bit (7);
  3151.  
  3152. /* ************************************************************************* */
  3153.  
  3154.    buffer = '';
  3155.    snd_msg = '';
  3156.    last_char = '';
  3157.    char_ptr = addr (character);
  3158.    buff_ptr = addr (buffer);
  3159.    buff_ptr = addrel (buff_ptr, 1);
  3160.  
  3161.    call srsfx$ (k$read + k$getu, path_name, file_unit, type, 0, '', basename,
  3162.                 sufusd, code);
  3163.    if type > 1 & type ^= 7 then
  3164.       do;
  3165.          call clo$fu (file_unit, rnw);
  3166.          if code = 0 then
  3167.             code = e$wft;
  3168.       end;
  3169.  
  3170.    file_opened = (code = 0);
  3171.  
  3172.    if code ^= 0 then
  3173.       do;
  3174.          snd_msg = 'Error opening file to convert. ';
  3175.          return (code);
  3176.       end;
  3177.  
  3178.    call uid$bt (unique_bits);
  3179.    call uid$ch (unique_bits, fn);
  3180.    temp_filename = fn || '.KERMIT.CONV';
  3181.  
  3182.    if ^non_null_dir then
  3183.       temp_pathname = temp_filename;
  3184.    else
  3185.       temp_pathname = dir_name || '>' || temp_filename;
  3186.  
  3187.    i = k$writ + k$getu;
  3188.    if type = 1 then
  3189.       i = i + k$ndam;
  3190.    else
  3191.       if type = 7 then
  3192.          i = i + k$ncam;
  3193.  
  3194.    call srsfx$ (i, temp_pathname, unit2, type, 0, '', basename, sufusd, code);
  3195.    if code ^= 0 then
  3196.       do;
  3197.          file_opened = false;
  3198.          call clo$fu (file_unit, rnw);
  3199.          snd_msg = 'Error opening temporary output file. ';
  3200.          return (code);
  3201.       end;
  3202.  
  3203.    do until (code ^= 0);
  3204.  
  3205.       call prwf$$ (k$read, file_unit, ibuffer_ptr, ibuffer_size_wds, 0, rnw,
  3206.                    code);
  3207.       if code = e$eof & rnw = 0 & last_char ^= '' then
  3208.          do;               /* This takes care of any last odd character. */
  3209.             rnw = 1;
  3210.             buffer = '';
  3211.             if last_char = lf_8bit_asc then
  3212.                last_char = space_8bit_asc;
  3213.  
  3214.             substr (ibuffer, 1, 2) = last_char || lf_8bit_asc;
  3215.          end;
  3216.  
  3217.       if rnw > 0 then   /* This assumes that rnw > 0 for code = 0 or e$eof. */
  3218.          do;            /* And rnw = 0 for any error. */
  3219.             ibuflen = 2 * rnw;
  3220.  
  3221.             call convert_to_ascii;
  3222.             if code ^= 0 then
  3223.                snd_msg = 'Error converting the file. ';
  3224.          end;
  3225.       else
  3226.          snd_msg = 'Error reading from the file. ';
  3227.    end;
  3228.  
  3229.    file_opened = false;
  3230.  
  3231.    call clo$fu (file_unit, rnw);
  3232.  
  3233.    call clo$fu (unit2, rnw);
  3234.  
  3235.    if code = e$eof then
  3236.       do;
  3237.          code = 0;
  3238.          snd_msg = '';
  3239.       end;
  3240.  
  3241.    if code ^= 0 then
  3242.       do;
  3243.          call fil$dl (temp_pathname, rnw);
  3244.          return (code);
  3245.       end;
  3246.    else
  3247.       do;
  3248.          code = rnw;
  3249.          if code ^= 0 then
  3250.             do;
  3251.                snd_msg = 'Unable to close the output file. ';
  3252.                return (code);
  3253.             end;
  3254.       end;
  3255.  
  3256.    if non_null_dir then
  3257.       do;
  3258.          call at$ (k$setc, dir_name, code);
  3259.          if code ^= 0 then
  3260.             do;
  3261.                call fil$dl (temp_pathname, rnw);
  3262.                snd_msg = 'Error attaching to upload directory. ';
  3263.                return (code);
  3264.             end;
  3265.       end;
  3266.  
  3267.    call fil$dl (file_name, code);
  3268.    if code ^= 0 then
  3269.       do;
  3270.          if non_null_dir then
  3271.             call at$hom (rnw);
  3272.          snd_msg = 'Unable to delete the original file. ';
  3273.          return (code);
  3274.       end;
  3275.  
  3276.    rnw = 0;
  3277.    if length (temp_filename) = length (file_name) then
  3278.       sufusd = 1;
  3279.    else
  3280.       sufusd = 0;
  3281.  
  3282.    call cnam$$ ((temp_filename), length (temp_filename),
  3283.                 (file_name), length (file_name), code, sufusd);
  3284.    if code ^= 0 then
  3285.       snd_msg = 'Error trying to rename the temporary file. ';
  3286.  
  3287.    if non_null_dir then
  3288.       call at$hom (rnw);
  3289.  
  3290.    if code = 0 then
  3291.       code = rnw;
  3292.  
  3293.    return (code);
  3294.  
  3295. /* **************************** Convert_to_ascii *************************** */
  3296.  
  3297. Convert_to_ascii : proc;
  3298.  
  3299. /* ************************************************************************* */
  3300.  
  3301.    do i = 1 to ibuflen;
  3302.  
  3303.       character = substr (ibuffer, i, 1);
  3304.       char_ptr -> bit_char.high_bit = '1'b;
  3305.  
  3306.       if character ^= cr_8bit_asc then
  3307.          buffer = buffer || character;
  3308.  
  3309.       if character = lf_8bit_asc then
  3310.          if mod (length (buffer), 2) ^= 0 then
  3311.             buffer = buffer || nul_7bit_asc;
  3312.    end;
  3313.  
  3314.    last_char = '';
  3315.    sufusd = length (buffer);
  3316.  
  3317.    if mod (sufusd, 2) ^= 0 then
  3318.       if code = e$eof then
  3319.          do;
  3320.             sufusd = sufusd + 1;
  3321.             buffer = buffer || lf_8bit_asc;
  3322.          end;
  3323.       else
  3324.          last_char = substr (buffer, sufusd, 1);
  3325.  
  3326.    call prwf$$ (k$writ, unit2, buff_ptr, divide (sufusd, 2, 15), 0, rnw, code);
  3327.    buffer = last_char;
  3328.  
  3329.    return;
  3330.  
  3331.    end;       /* Convert_to_ascii */
  3332.  
  3333.    end;      /* Convert_file */
  3334. -------------------------------------------------------------------------------
  3335.  
  3336. /* DISCARD_OUTPUT -- Discard an output file. */
  3337.  
  3338. Discard_output : proc (code);
  3339.  
  3340. Dcl code fixed bin;
  3341.  
  3342. $Insert *>insert>common.ins.plp
  3343. $Insert *>insert>kermit.ins.plp
  3344. $Insert *>insert>primos.ins.plp
  3345. $Insert *>insert>constants.ins.plp
  3346. $Insert syscom>errd.ins.pl1
  3347.  
  3348. /* ************************************************************************* */
  3349.  
  3350.    code = 0;
  3351.  
  3352.    rec_file_type = automatic_ft;
  3353.    if ^explicit_ft_set then
  3354.       file_type = automatic_ft;
  3355.  
  3356.    if file_opened then
  3357.       do;
  3358.          call clo$fu (file_unit, code);
  3359.          if code = e$unop then
  3360.             code = 0;
  3361.  
  3362.          if code = 0 & del_incomplete then
  3363.             call fil$dl (path_name, code);
  3364.  
  3365.          if code = e$fntf | code = e$ninf then
  3366.             code = 0;               /* Possible if the unit wasn't open. */
  3367.  
  3368.          file_opened = false;
  3369.       end;
  3370.  
  3371.    return;
  3372.  
  3373.    end;      /* Discard_output */
  3374. -------------------------------------------------------------------------------
  3375.  
  3376. /* GENERIC_CMD -- Generic server command process. */
  3377.  
  3378. Generic_cmd : proc returns (fixed bin);
  3379.  
  3380. $Insert *>insert>common.ins.plp
  3381. $Insert *>insert>kermit.ins.plp
  3382. $Insert *>insert>primos.ins.plp
  3383. $Insert *>insert>constants.ins.plp
  3384. $Insert syscom>keys.ins.pl1
  3385. $Insert syscom>errd.ins.pl1
  3386.  
  3387. %Replace maxargs by 3,
  3388.          maxalen by 96;
  3389.  
  3390. Dcl (args, nargs) char (maxalen) var,
  3391.     arg (maxargs) char (maxalen) var;
  3392.  
  3393. Dcl (treename, line) char (128) var,
  3394.     basename char (32) var,
  3395.     fn char (13),
  3396.     unique_bits char (6) aligned,
  3397.     (print_header, continue) bit (1) aligned,
  3398.     (code, rnw, funit, type, dir_type, dir_unit, code2, sufusd, key) fixed bin,
  3399.     (to_user_num, to_name_len) fixed bin,
  3400.     errvec (4) fixed bin,
  3401.     to_name char (32);
  3402.  
  3403. Dcl 1 disk_info,
  3404.       2 version fixed bin,
  3405.       2 disk_name char (32) var,
  3406.       2 part_size fixed bin (31),
  3407.       2 avail fixed bin (31),
  3408.       2 dts fixed bin (31);
  3409.  
  3410. Dcl 1 quota_info,
  3411.       2 (record_size, dir_used, max_quota, quota_used) fixed bin (31),
  3412.       2 (duff1, duff2, duff3, duff4) fixed bin (31),
  3413.     inf_array (8) fixed bin (31) based;
  3414.  
  3415. /* ************************************************************************* */
  3416.  
  3417.    call parse_cmd;           /* Parse any arguments sent. */
  3418.  
  3419.    select (set8 (substr (rec_msg, pkt_msg, 1))); /* Process the message type. */
  3420.  
  3421.       when (msg_gen_cwd)          /* CWD - Change Working Directory. */
  3422.          do;
  3423.             treename = arg(1);
  3424.  
  3425.             if length (arg(2)) ^= 0 then       /* Do we have a password ? */
  3426.                treename = treename || space_8bit_asc || arg(2);
  3427.  
  3428.             call change_dir (treename, code);
  3429.  
  3430.             if code = 0 then
  3431.                call send_packet (msg_ack, length (snd_msg), rec_seq);
  3432.             else
  3433.                do;
  3434.                   call get_error_msg (code);
  3435.                   snd_msg = 'Error trying to change directory. ' || errmsg;
  3436.                   call send_packet (msg_error, length (snd_msg), msg_number);
  3437.                end;
  3438.          end;
  3439.  
  3440.       when (msg_gen_finish)          /* FINISH command. */
  3441.          do;
  3442.             call send_packet (msg_ack, 0, rec_seq);
  3443.             return (ker_exit);
  3444.          end;
  3445.  
  3446.       when (msg_gen_logout)           /* LOGOUT command. */
  3447.          do;
  3448.             call send_packet (msg_ack, 0, rec_seq);
  3449.             call logo$$ (0, 0, '', 0, 0, code);
  3450.          end;
  3451.  
  3452.       when (msg_gen_delete)           /* DELETE command. */
  3453.          do;
  3454.             treename = arg(1);
  3455.             call fil$dl (treename, code);
  3456.             if code = 0 then
  3457.                do;
  3458.                   snd_msg = 'File deleted.';
  3459.                   call send_packet (msg_ack, length (snd_msg), rec_seq);
  3460.                end;
  3461.             else
  3462.                do;
  3463.                   call get_error_msg (code);
  3464.                   snd_msg = 'Unable to delete the file. ' || errmsg;
  3465.                   call send_packet (msg_error, length (snd_msg), msg_number);
  3466.                end;
  3467.          end;
  3468.  
  3469.       when (msg_gen_directory)        /* DIRECTORY command. */
  3470.          do;
  3471.             call uid$bt (unique_bits);
  3472.             call uid$ch (unique_bits, fn);
  3473.  
  3474.             treename = arg(1);
  3475.  
  3476.             if length (treename) = 0 then
  3477.                treename = fn || '.KERMIT.DIR';
  3478.             else
  3479.                treename = treename || '>' || fn || '.KERMIT.DIR';
  3480.  
  3481.             call set_path (treename);
  3482.  
  3483.             call srch$$ (k$rdwr + k$getu, (file_name), length (file_name),
  3484.                          file_unit, type, code);
  3485.             if code ^= 0 then
  3486.                do;
  3487.                   call get_error_msg (code);
  3488.                   snd_msg = 'Error opening a temporary file. ' || errmsg;
  3489.                   call send_packet (msg_error, length (snd_msg), msg_number);
  3490.  
  3491.                   return (ker_normal);
  3492.                end;
  3493.  
  3494.             file_opened = true;
  3495.  
  3496.             call srsfx$ (k$read + k$getu, dir_name, dir_unit, dir_type, 0, '',
  3497.                          basename, sufusd, code);
  3498.             if code ^= 0 then
  3499.                do;
  3500.                   call get_error_msg (code);
  3501.                   snd_msg = 'Error opening the directory. ' || errmsg;
  3502.                   call send_packet (msg_error, length (snd_msg), msg_number);
  3503.  
  3504.                   file_opened = false;
  3505.                   call clo$fu (file_unit, code);
  3506.                   call fil$dl (file_name, code);
  3507.  
  3508.                   return (ker_normal);
  3509.                end;
  3510.  
  3511.             continue = false;
  3512.             print_header = true;
  3513.             call dir$rd (k$init, dir_unit, dir_entry_ptr, dir_entry_size, code);
  3514.  
  3515.             do until (code ^= 0);
  3516.                call dir$rd (k$read, dir_unit, dir_entry_ptr, dir_entry_size,
  3517.                             code);
  3518.                if code = 0 then
  3519.                   if trim (dir_entry.entryname, '01'b) ^= file_name then
  3520.                      do;
  3521.                         if print_header then
  3522.                            do;
  3523.                               print_header = false;
  3524.                               call wtlin$ (file_unit,
  3525.                              '*** Start of Directory Listing. *** ', 18, code);
  3526.                            end;
  3527.  
  3528.                         if ^continue then
  3529.                            line = dir_entry.entryname;
  3530.                         else
  3531.                            do;
  3532.                               line = line || '    ' || dir_entry.entryname ||
  3533.                                      '  ';
  3534.                               call wtlin$ (file_unit, (line),
  3535.                                            divide (length (line), 2, 15), code);
  3536.                            end;
  3537.  
  3538.                         if code = 0 then
  3539.                            continue = ^continue;
  3540.  
  3541.                      end;
  3542.             end;
  3543.  
  3544.             call clo$fu (dir_unit, code2);
  3545.  
  3546.             if code = e$eof then
  3547.                do;
  3548.                   code = 0;
  3549.                   if continue then
  3550.                      do;
  3551.                         line = line || '  ';
  3552.                         call wtlin$ (file_unit, (line),
  3553.                                      divide (length (line), 2, 15), code);
  3554.                      end;
  3555.                   else      /* We will be here if we had an empty directory. */
  3556.                      if print_header then
  3557.                         call wtlin$ (file_unit,
  3558.                 '*** There are NO file system objects in this directory. *** ',
  3559.                                      30, code);
  3560.                end;
  3561.  
  3562.             if code ^= 0 then
  3563.                do;
  3564.                   call get_error_msg (code);
  3565.                   snd_msg = 'Error listing the directory. ' || errmsg;
  3566.                   call send_packet (msg_error, length (snd_msg), msg_number);
  3567.  
  3568.                   file_opened = false;
  3569.                   call clo$fu (file_unit, code);
  3570.                   call fil$dl (file_name, code);
  3571.  
  3572.                   return (ker_normal);
  3573.                end;
  3574.  
  3575.             if ^print_header then
  3576.                call wtlin$ (file_unit, '*** End of Directory Listing. *** ', 17,
  3577.                             code);
  3578.  
  3579.             call xsend_file;
  3580.  
  3581.             file_opened = false;
  3582.  
  3583.             call clo$fu (file_unit, code);
  3584.             call fil$dl (file_name, code);
  3585.  
  3586.          end;
  3587.  
  3588.       when (msg_gen_type)             /* TYPE command. */
  3589.          do;
  3590.             treename = arg(1);
  3591.             call set_path (treename);
  3592.  
  3593.             code = open_input ();
  3594.             if code = 0 then
  3595.                do;
  3596.                   state = state_x;
  3597.                   call send_switch;
  3598.                end;
  3599.             else
  3600.                do;
  3601.                   call get_error_msg (code);
  3602.                   snd_msg = 'Error accessing the file. ' || errmsg;
  3603.                   call send_packet (msg_error, length (snd_msg), msg_number);
  3604.                end;
  3605.          end;
  3606.  
  3607.       when (msg_gen_disk_usage)              /* Disk Usage. */
  3608.          do;
  3609.             treename = arg(1); /* Anything sent will actually be a directory. */
  3610.             if length (treename) ^= 0 then
  3611.                treename = treename || '>DUMMY_FILE_NAME';
  3612.  
  3613.             call set_path (treename);
  3614.  
  3615.             call q$read (dir_name, addr (quota_info) -> inf_array, 4, type,
  3616.                          code);
  3617.             if code ^= 0 then
  3618.                do;
  3619.                   call get_error_msg (code);
  3620.                   snd_msg = 'Error reading the disk quota. ' || errmsg;
  3621.                   call send_packet (msg_error, length (snd_msg), msg_number);
  3622.                end;
  3623.             else
  3624.                do;
  3625.                   basename = trim (char (quota_info.quota_used), '10'b);
  3626.  
  3627.                   snd_msg = 'Records = ' || basename || ', ';
  3628.  
  3629.                   if type = 1 then
  3630.                      snd_msg = snd_msg || 'No Quota.';
  3631.                   else
  3632.                      snd_msg = snd_msg || 'Quota = ' ||
  3633.                                trim (char (quota_info.max_quota),'10'b) || '.';
  3634.  
  3635.                   if file_info.ldevno = -1 then
  3636.                      call finfo$ (current_attach_point, file_info_ptr, code);
  3637.  
  3638.                   if code = 0 then
  3639.                      do;
  3640.                         disk_info.version = 1;
  3641.                         call ds$avl (addr (disk_info), file_info.ldevno,
  3642.                                      code);
  3643.  
  3644.                         if code = 0 then
  3645.                            do;
  3646.                               basename = trim (char (disk_info.avail), '10'b);
  3647.                               snd_msg = snd_msg || '   (' || basename ||
  3648.                                         ' records available on disk).';
  3649.                            end;
  3650.                      end;
  3651.  
  3652.                   if code ^= 0 then
  3653.                      snd_msg = snd_msg ||
  3654.                                '   (Disk space information not available).';
  3655.  
  3656.                   call send_packet (msg_ack, length (snd_msg), rec_seq);
  3657.                end;
  3658.  
  3659.             file_info.ldevno = -1;      /* Reset this for next time. */
  3660.  
  3661.          end;
  3662.  
  3663.       when (msg_gen_rename)               /* RENAME command. */
  3664.          do;
  3665.             code = 0;
  3666.  
  3667.             treename = arg(1);
  3668.             call set_path (treename);
  3669.  
  3670.             if non_null_dir then
  3671.                call at$ (k$setc, dir_name, code);
  3672.  
  3673.             if code = 0 then
  3674.                do;
  3675.                   rnw = length (file_name);
  3676.                   type = length (arg(2));
  3677.  
  3678.                   if rnw = type then
  3679.                      sufusd = 1;
  3680.                   else
  3681.                      sufusd = 0;
  3682.  
  3683.                   call cnam$$ ((file_name), rnw, (arg(2)), type, code, sufusd);
  3684.  
  3685.                   if non_null_dir then
  3686.                      call at$hom (code2);
  3687.                end;
  3688.  
  3689.             if code ^= 0 then
  3690.                do;
  3691.                   call get_error_msg (code);
  3692.                   snd_msg = 'Error trying to change the file name. ' || errmsg;
  3693.                   call send_packet (msg_error, length (snd_msg), msg_number);
  3694.                end;
  3695.             else
  3696.                do;
  3697.                   snd_msg = 'File renamed.';
  3698.                   call send_packet (msg_ack, length (snd_msg), rec_seq);
  3699.                end;
  3700.  
  3701.          end;
  3702.  
  3703.       when (msg_gen_copy)             /* COPY command. */
  3704.          do;
  3705.             treename = arg(1);
  3706.             line = arg(2);
  3707.  
  3708.             call srsfx$ (k$read + k$getu, treename, file_unit, type, 0, '',
  3709.                          basename, sufusd, code);
  3710.             if type > 1 & type ^= 7 then
  3711.                do;
  3712.                   call clo$fu (file_unit, rnw);
  3713.                   if code = 0 then
  3714.                      code = e$wft;
  3715.                end;
  3716.  
  3717.             if code ^= 0 then
  3718.                do;
  3719.                   call get_error_msg (code);
  3720.                   snd_msg = 'Unable to open the file to copy from. ' || errmsg;
  3721.                   call send_packet (msg_error, length (snd_msg), msg_number);
  3722.                   return (ker_normal);
  3723.                end;
  3724.  
  3725.             key = k$writ + k$getu;
  3726.             if type = 1 then
  3727.                key = key + k$ndam;
  3728.             else
  3729.                if type = 7 then
  3730.                   key = key + k$ncam;
  3731.  
  3732.             call srsfx$ (key, line, funit, type, 0, '', basename, sufusd, code);
  3733.             if code ^= 0 then
  3734.                do;
  3735.                   call get_error_msg (code);
  3736.                   snd_msg = 'Unable to open the file to copy to. ' || errmsg;
  3737.                   call send_packet (msg_error, length (snd_msg), msg_number);
  3738.                   return (ker_normal);
  3739.                end;
  3740.  
  3741.             do until (code ^= 0);
  3742.                call prwf$$ (k$read, file_unit, ibuffer_ptr, ibuffer_size_wds,
  3743.                             0, rnw, code);
  3744.                if code = 0 | (code = e$eof & rnw ^= 0) then
  3745.                   call prwf$$ (k$writ, funit, ibuffer_ptr, rnw, 0, sufusd,
  3746.                                code);
  3747.             end;
  3748.  
  3749.             call clo$fu (file_unit, code2);
  3750.             call clo$fu (funit, code2);
  3751.  
  3752.             if code = e$eof then
  3753.                code = 0;
  3754.  
  3755.             if code ^= 0 then
  3756.                do;
  3757.                   call fil$dl (line, code2);
  3758.                   call get_error_msg (code);
  3759.                   snd_msg = 'Error copying the file. ' || errmsg;
  3760.                   call send_packet (msg_error, length (snd_msg), msg_number);
  3761.                end;
  3762.             else
  3763.                do;
  3764.                   snd_msg = 'File copied.';
  3765.                   call send_packet (msg_ack, length (snd_msg), rec_seq);
  3766.                end;
  3767.  
  3768.          end;
  3769.  
  3770.       when (msg_gen_send)             /* SEND command. */
  3771.          do;
  3772.             line = after (arg(1), space_8bit_asc);
  3773.             arg(1) = translate (trim (before (arg(1), space_8bit_asc), '11'b),
  3774.                                 uppercase, lowercase);
  3775.             if substr (arg(1), 1, 1) = '-' then
  3776.                arg(1) = substr (arg(1), 2);
  3777.  
  3778.             if verify (arg(1), '+-0123456789') = 0 then /* User number given. */
  3779.                do;
  3780.                   to_name = '';
  3781.                   to_name_len = 0;
  3782.                   to_user_num = bin (arg(1), 15);
  3783.                   if to_user_num <= 0 then
  3784.                      do;
  3785.                         snd_msg = 'Invalid user-number given.';
  3786.                         call send_packet (msg_error, length (snd_msg),
  3787.                                           msg_number);
  3788.                         return (ker_normal);
  3789.                      end;
  3790.                end;
  3791.             else
  3792.                do;
  3793.                   to_name = arg(1);
  3794.                   to_name_len = length (to_name);
  3795.                   to_user_num = 0;
  3796.                end;
  3797.  
  3798.             if length (line) > 80 then
  3799.                line = substr (line, 1, 80);
  3800.             rnw = length (line);
  3801.  
  3802.             errvec(2) = 1;
  3803.             call mgset$ (k$acpt, code);
  3804.  
  3805.             call smsg$ (1, to_name, to_name_len, to_user_num, '', 0, (line),
  3806.                         rnw, errvec);
  3807.  
  3808.             call mgset$ (my_msg_state, code);
  3809.             if errvec(1) = 0 then
  3810.                do;
  3811.                   snd_msg = 'Message sent.';
  3812.                   call send_packet (msg_ack, length (snd_msg), rec_seq);
  3813.                end;
  3814.             else
  3815.                do;
  3816.                   call get_error_msg (errvec(1));
  3817.                   snd_msg = 'Unable to send the message. ' || errmsg;
  3818.                   call send_packet (msg_error, length (snd_msg), msg_number);
  3819.                end;
  3820.  
  3821.          end;
  3822.  
  3823.       when (msg_gen_who)              /* WHO command. */
  3824.          do;
  3825.             if substr (arg(1), 1, 1) = '-' then
  3826.                arg(1) = substr (arg(1), 2);
  3827.  
  3828.             if length (arg(1)) = 0 then
  3829.                do;
  3830.                   snd_msg = 'No user-id given.';
  3831.                   call send_packet (msg_error, length (snd_msg), msg_number);
  3832.                   return (ker_normal);
  3833.                end;
  3834.  
  3835.             if verify (arg(1), '+-0123456789') = 0 then
  3836.                do;                         /* User number given. */
  3837.                   key = k$read;
  3838.                   to_name = '';
  3839.                   to_name_len = 32;
  3840.                   to_user_num = bin (arg(1), 15);
  3841.                   if to_user_num <= 0 then
  3842.                      do;
  3843.                         snd_msg = 'Invalid user-number given.';
  3844.                         call send_packet (msg_error, length (snd_msg),
  3845.                                           msg_number);
  3846.                         return (ker_normal);
  3847.                      end;
  3848.                end;
  3849.             else
  3850.                do;
  3851.                   key = 2;
  3852.                   to_name = arg(1);
  3853.                   to_name_len = length (to_name);
  3854.                   to_user_num = 0;
  3855.                end;
  3856.  
  3857.             call msg$st (key, to_user_num, '', 0, to_name, to_name_len, code);
  3858.             if code = k$none then
  3859.                do;
  3860.                   snd_msg = 'User ' || arg(1) || ' is not logged in.';
  3861.                   call send_packet (msg_error, length (snd_msg), msg_number);
  3862.                end;
  3863.             else
  3864.                do;
  3865.                   snd_msg = 'User ' || trim (to_name, '11'b) ||
  3866.                             ' is currently logged in as process number ' ||
  3867.                             trim (char (to_user_num), '11'b) || '.';
  3868.                   call send_packet (msg_ack, length (snd_msg), rec_seq);
  3869.                end;
  3870.  
  3871.          end;
  3872.  
  3873.       otherwise                       /* Unknown command. */
  3874.          do;
  3875.             snd_msg = 'Unimplemented generic command.';
  3876.             call send_packet (msg_error, length (snd_msg), msg_number);
  3877.             return (ker_unimplgen);
  3878.          end;
  3879.  
  3880.    end;     /* select */
  3881.  
  3882.    return (ker_normal);
  3883.  
  3884. /* ******************************* Parse_cmd ******************************* */
  3885.  
  3886. Parse_cmd : proc;
  3887.  
  3888. Dcl (arg_num, arg_len, i, temp, rep_count) fixed bin,
  3889.     do_trans bit (1) aligned,
  3890.     (chr, rem_quo) char (1);
  3891.  
  3892. /* ************************************************************************* */
  3893.  
  3894.    do_repeats = (loc_rep_chr = set8 (rem_rep_chr)) &
  3895.                 (loc_rep_chr ^= space_8bit_asc);
  3896.  
  3897.    do i = 1 to maxargs;
  3898.       arg(i) = '';
  3899.    end;
  3900.  
  3901.    if length (rec_msg) <= pkt_tot_ovr_head then
  3902.       return;
  3903.  
  3904.    args = set8str (substr (rec_msg, pkt_tot_ovr_head, length (rec_msg) -
  3905.                                                       pkt_tot_ovr_head));
  3906.  
  3907.    nargs = '';
  3908.    rem_quo = set8 (rem_quote_chr);   /* For local processing only. */
  3909.  
  3910.    i = 0;          /* Convert any quoted and repeated characters. */
  3911.    do while (i < length (args));
  3912.       i = i + 1;
  3913.       chr = substr (args, i, 1);
  3914.       rep_count = 1;
  3915.  
  3916.       if do_repeats then
  3917.          if chr = loc_rep_chr then
  3918.             do;
  3919.                i = i + 1;
  3920.                rep_count = knum (substr (args, i, 1));
  3921.  
  3922.                i = i + 1;
  3923.                chr = substr (args, i, 1);
  3924.             end;
  3925.  
  3926.       if chr = rem_quo then
  3927.          do;
  3928.             i = i + 1;
  3929.             chr = substr (args, i, 1);
  3930.             if chr >= query_8bit_asc & chr < grave_8bit_asc then
  3931.                chr = ctl (chr);
  3932.          end;
  3933.  
  3934.       do temp = 1 to rep_count;
  3935.          nargs = nargs || chr;
  3936.       end;
  3937.  
  3938.    end;
  3939.  
  3940.    i = 0;
  3941.    arg_num = 0;
  3942.    do_trans = (set8 (substr (rec_msg, pkt_msg, 1)) ^= msg_gen_send);
  3943.  
  3944.    do while (i < length (nargs));         /* Now fill in the argument list. */
  3945.       i = i + 1;
  3946.       arg_len = knum (substr (nargs, i, 1));
  3947.       arg_num = arg_num + 1;
  3948.       arg(arg_num) = substr (nargs, i + 1, arg_len);
  3949.       if do_trans then           /* Don't do this for the SEND command. */
  3950.          arg(arg_num) = translate (trim (arg(arg_num), '11'b), uppercase,
  3951.                                                                lowercase);
  3952.       i = i + arg_len;
  3953.    end;
  3954.  
  3955.    return;
  3956.  
  3957.    end;       /* Parse_cmd */
  3958.  
  3959. /* ******************************* Xsend_file ****************************** */
  3960.  
  3961. Xsend_file : proc;
  3962.  
  3963. /* ************************************************************************* */
  3964.  
  3965.    /* First we rewind the file to the beginning. */
  3966.  
  3967.    call prwf$$ (k$posn + k$prea, file_unit, null (), 0, 0, rnw, code);
  3968.    if code ^= 0 then
  3969.       do;
  3970.          call get_error_msg (code);
  3971.          snd_msg = 'Unable to position to the beginning of the file. ' ||
  3972.                    errmsg;
  3973.          call send_packet (msg_error, length (snd_msg), msg_number);
  3974.       end;
  3975.    else
  3976.       do;
  3977.          file_pos = 0;
  3978.          ibuflen = 0;
  3979.          ibuf_ptr = 1;
  3980.          key = file_type;     /* Keep this for later. */
  3981.          file_type = ascii_ft;
  3982.          if ^explicit_pound_set then
  3983.             pound_conversion = true;
  3984.          ibuffer = '';
  3985.  
  3986.          state = state_x;  /* Send the file as text to be typed to the user. */
  3987.          call send_switch;
  3988.  
  3989.          file_type = key;     /* Reset the file type. */
  3990.       end;
  3991.  
  3992.    return;
  3993.  
  3994.    end;       /* Xsend_file */
  3995.  
  3996.    end;    /* Generic_cmd */
  3997. -------------------------------------------------------------------------------
  3998.  
  3999. /* GET_ATTR -- Get file attributes and put them in SND_MSG. */
  4000.  
  4001. Get_attr : proc;
  4002.  
  4003. $Insert *>insert>kermit.ins.plp
  4004. $Insert *>insert>common.ins.plp
  4005. $Insert *>insert>constants.ins.plp
  4006.  
  4007. %Replace primos by 'G';
  4008.  
  4009. Dcl 1 a_sub_pkt,
  4010.       2  type char (1),
  4011.       2  pkt_len char (1),
  4012.       2  data char (32) var;
  4013.  
  4014. Dcl sub_pkt_ptr ptr;
  4015.  
  4016. /* ************************************************************************* */
  4017.  
  4018.    sub_pkt_ptr = addr (a_sub_pkt);
  4019.  
  4020.    a_sub_pkt.type = '.';              /* Set up machine/OS sub-packet. */
  4021.    char2_ptr -> fb15_based = 33;              /* i.e. 1 + 32 */
  4022.    a_sub_pkt.pkt_len = char2(2);
  4023.    a_sub_pkt.data = primos;
  4024.    snd_msg = sub_pkt_ptr -> char2_based || a_sub_pkt.data;
  4025.  
  4026.    a_sub_pkt.type = '!';              /* Set up kbyte length sub-packet. */
  4027.    a_sub_pkt.data = trim (char (divide (file_len + 1023, 1024, 31)), '11'b);
  4028.    char2_ptr -> fb15_based = length (a_sub_pkt.data) + 32;
  4029.    a_sub_pkt.pkt_len = char2(2);
  4030.    snd_msg = snd_msg || sub_pkt_ptr -> char2_based || a_sub_pkt.data;
  4031.  
  4032.    a_sub_pkt.data = get_dtc ();       /* Set up DTC sub-packet. */
  4033.    if length (a_sub_pkt.data) ^= 0 then
  4034.       do;
  4035.          a_sub_pkt.type = '#';
  4036.          char2_ptr -> fb15_based = length (a_sub_pkt.data) + 32;
  4037.          a_sub_pkt.pkt_len = char2(2);
  4038.          snd_msg = snd_msg || sub_pkt_ptr -> char2_based || a_sub_pkt.data;
  4039.       end;
  4040.  
  4041.    a_sub_pkt.type = '1';        /* Set up the byte file length sub-packet. */
  4042.    a_sub_pkt.data = trim (char (file_len), '11'b);
  4043.    char2_ptr -> fb15_based = length (a_sub_pkt.data) + 32;
  4044.    a_sub_pkt.pkt_len = char2(2);
  4045.    snd_msg = snd_msg || sub_pkt_ptr -> char2_based || a_sub_pkt.data;
  4046.  
  4047.    if file_type = ascii_ft | file_type = binary_ft then
  4048.       do;
  4049.          a_sub_pkt.type = '"';
  4050.  
  4051.          if file_type = ascii_ft then
  4052.             a_sub_pkt.data = 'A';
  4053.          else
  4054.             a_sub_pkt.data = 'B';
  4055.  
  4056.          char2_ptr -> fb15_based = 33;
  4057.          a_sub_pkt.pkt_len = char2(2);
  4058.  
  4059.          snd_msg = snd_msg || sub_pkt_ptr -> char2_based || a_sub_pkt.data;
  4060.       end;
  4061.  
  4062.    return;
  4063.  
  4064.    end;       /* Get_attr */
  4065. -------------------------------------------------------------------------------
  4066.  
  4067. /* GET_DTC -- Get the DTC of the file given by "path_name". */
  4068.  
  4069. Get_dtc : proc returns (char (32) var);
  4070.  
  4071. $Insert *>insert>common.ins.plp
  4072. $Insert *>insert>kermit.ins.plp
  4073. $Insert *>insert>primos.ins.plp
  4074. $Insert *>insert>constants.ins.plp
  4075. $Insert syscom>keys.ins.pl1
  4076.  
  4077. Dcl (type, code, dow, funit, sufusd) fixed bin,
  4078.     formatted_date char (21),
  4079.     (buffer, basename) char (32) var;
  4080.  
  4081. /* ************************************************************************* */
  4082.  
  4083.    buffer = '';
  4084.  
  4085.    call srsfx$ (k$read + k$getu, dir_name, funit, type, 0, '', basename,
  4086.                 sufusd, code);
  4087.    if code ^= 0 then
  4088.       do;
  4089.          call get_error_msg (code);
  4090.          call ioa$ ('Unable to open the directory %v. %v%.', 99, dir_name,
  4091.                     errmsg);
  4092.          return (buffer);
  4093.       end;
  4094.  
  4095.    call ent$rd (funit, file_name, dir_entry_ptr, dir_entry_size, code);
  4096.    call clo$fu (funit, sufusd);        /* We don't need this anymore. */
  4097.    if code ^= 0 then
  4098.       do;
  4099.          call get_error_msg (code);
  4100.          call ioa$ ('Unable to read the directory entry for file %v. %v%.', 99,
  4101.                     file_name, errmsg);
  4102.          return (buffer);
  4103.       end;
  4104.  
  4105.    /* We now use the files' Date/Time last modified attribute than its
  4106.       Date/Time of creation since this is of more use to most users. */
  4107.  
  4108.    call cv$fda (dir_entry.dtm, dow, formatted_date);
  4109.    if dow >= 0 then
  4110.       buffer = '19' || substr (formatted_date, 1, 2) ||
  4111.                        substr (formatted_date, 4, 2) ||
  4112.                        substr (formatted_date, 7, 2) || space_8bit_asc ||
  4113.                        substr (formatted_date, 10, 8);
  4114.  
  4115.    return (buffer);
  4116.  
  4117.    end;      /* Get_dtc */
  4118. -------------------------------------------------------------------------------
  4119.  
  4120. /* GET_ERROR_MSG -- Get the PRIMOS error message from the given code. */
  4121.  
  4122. Get_error_msg : proc (code);
  4123.  
  4124. Dcl code fixed bin;
  4125.  
  4126. $Insert *>insert>common.ins.plp
  4127. $Insert *>insert>primos.ins.plp
  4128.  
  4129. /* ************************************************************************* */
  4130.  
  4131.    call ertxt$ (code, errmsg);
  4132.  
  4133.    if length (errmsg) = 0 then
  4134.       errmsg = '(Code = ' || trim (char (code), '11'b) || ')';
  4135.  
  4136.    return;
  4137.  
  4138.    end;       /* Get_error_msg */
  4139. -------------------------------------------------------------------------------
  4140.  
  4141. /* GET_LEN -- Determine logical and physical length of file in bytes. */
  4142.  
  4143. Get_len : proc (exact) returns (fixed bin);
  4144.  
  4145. Dcl exact bit (1) aligned;
  4146.  
  4147. $Insert *>insert>common.ins.plp
  4148. $Insert *>insert>primos.ins.plp
  4149. $Insert *>insert>constants.ins.plp
  4150. $Insert syscom>keys.ins.pl1
  4151. $Insert syscom>errd.ins.pl1
  4152.  
  4153. Dcl (unit2, sufusd, type ,code, rnw) fixed bin,
  4154.     long_temp fixed bin (31),
  4155.     basename char (32) var;
  4156.  
  4157. /* ************************************************************************* */
  4158.  
  4159.    file_len = 0;
  4160.    file_pos = 0;
  4161.  
  4162.    /* The following call will work, but for large SAM files
  4163.       it may hold the file system lock for a time. */
  4164.  
  4165.    call prwf$$ (k$posn + k$prea, file_unit, null (), 0, bignum, rnw, code);
  4166.    if code = 0 then
  4167.       code = e$fitb;            /* The file is too big! */
  4168.  
  4169.    if code = e$eof then         /* Determine the EOF position. */
  4170.       call prwf$$ (k$rpos, file_unit, null (), 0, file_len, rnw, code);
  4171.  
  4172.    if code = e$eof then
  4173.       do;
  4174.          code = 0;              /* This will allow for empty files. */
  4175.          file_len = 0;
  4176.  
  4177.          return (code);
  4178.       end;
  4179.  
  4180.    if code ^= 0 then
  4181.       return (code);
  4182.  
  4183.    file_len = 2 * file_len;
  4184.    if exact then
  4185.       do;
  4186.          long_temp = exact_len ();
  4187.          if long_temp > 0 then
  4188.             file_len = long_temp;
  4189.       end;
  4190.  
  4191.    file_pos = file_len;
  4192.  
  4193.    /* PRIMOS keeps the file length in 2 byte words. The Kermit upload
  4194.       process will change the files read/write lock if the last byte is
  4195.       not significant. So we must now check the files read/write lock. */
  4196.  
  4197.    call srsfx$ (k$read + k$getu, dir_name, unit2, type, 0, '', basename,
  4198.                 sufusd, code);
  4199.    if code ^= 0 then
  4200.       return (code);
  4201.  
  4202.    call ent$rd (unit2, file_name, dir_entry_ptr, dir_entry_size, code);
  4203.    call clo$fu (unit2, sufusd);        /* We don't need this anymore. */
  4204.    if code ^= 0 then
  4205.       return (code);
  4206.  
  4207.    if dir_entry.file_inf.rwlock = k$none then
  4208.       file_len = file_len - 1;
  4209.  
  4210.    /* Now we can rewind the file to the beginning. */
  4211.  
  4212.    call prwf$$ (k$posn + k$prea, file_unit, null (), 0, 0, rnw, code);
  4213.    if code = 0 then
  4214.       file_pos = 0;
  4215.  
  4216.    return (code);
  4217.  
  4218. /* ******************************** Exact_len ****************************** */
  4219.  
  4220. Exact_len : proc returns (fixed bin (31));
  4221.  
  4222. Dcl (chr, ctrl_q, last_right) fixed bin,
  4223.     size fixed bin (31),
  4224.     left bit (1) aligned;
  4225.  
  4226. Dcl 1 buff (ibuffer_size_wds) based,
  4227.       2 left bit (8) unal,
  4228.       2 right bit (8) unal;
  4229.  
  4230. /* ************************************************************************* */
  4231.  
  4232.    chr = 0;
  4233.    code = 0;
  4234.    size = 0;
  4235.    last_right = 0;
  4236.    left = true;
  4237.    ctrl_q = 145;
  4238.  
  4239.    call prwf$$ (k$posn + k$prea, file_unit, null (), 0, 0, rnw, code);
  4240.  
  4241.    do until (rnw = 0);
  4242.       call prwf$$ (k$read, file_unit, ibuffer_ptr, ibuffer_size_wds, 0, rnw,
  4243.                    code);
  4244.  
  4245.       if rnw > 0 then
  4246.          do sufusd = 1 to rnw;
  4247.             if left then
  4248.                do;
  4249.                   chr = ibuffer_ptr -> buff(sufusd).left;
  4250.                   last_right = ibuffer_ptr -> buff(sufusd).right;
  4251.                end;
  4252.             else
  4253.                do;
  4254.                   sufusd = sufusd - 1;
  4255.                   chr = ibuffer_ptr -> buff(sufusd).right;
  4256.                end;
  4257.  
  4258.             if chr = ctrl_q then
  4259.                do;
  4260.                   if left then
  4261.                      chr = last_right;
  4262.                   else
  4263.                      do;
  4264.                         sufusd = sufusd + 1;
  4265.                         chr = ibuffer_ptr -> buff(sufusd).left;
  4266.                      end;
  4267.  
  4268.                   left = ^left;
  4269.                   size = size + chr;
  4270.                end;
  4271.             else
  4272.                size = size + 1;
  4273.  
  4274.             left = ^left;
  4275.          end;
  4276.    end;
  4277.  
  4278.    if code ^= e$eof then
  4279.       size = 0;
  4280.    else
  4281.       if last_right ^= 0 then
  4282.          size = size + 1;
  4283.  
  4284.    return (size);
  4285.  
  4286.    end;           /* Exact_len */
  4287.  
  4288.    end;       /* Get_len */
  4289. -------------------------------------------------------------------------------
  4290.  
  4291. /* GET_RESPONSE -- Try to get an ACK packet from the remote system. */
  4292.  
  4293. Get_response : proc returns (bit (1) aligned);
  4294.  
  4295. $Include *>insert>constants.ins.plp
  4296. $Include *>insert>kermit.ins.plp
  4297. $Include *>insert>common.ins.plp
  4298.  
  4299. Dcl fail bit (1) aligned;
  4300.  
  4301. /* ************************************************************************* */
  4302.  
  4303.    fail = false;
  4304.  
  4305.    call rec_packet;    /* Get a packet from the remote side. */
  4306.  
  4307.    select (rec_pkt_type);          /* Check the packet type. */
  4308.  
  4309.       when (msg_timeout, msg_check_err)        /* Timeout. */
  4310.          fail = true;
  4311.  
  4312.       when (msg_ack)                           /* ACK type. */
  4313.          if rec_seq ^= msg_number then
  4314.             fail = true;
  4315.  
  4316.       when (msg_nak)                           /* NAK type. */
  4317.  
  4318.               /* Treat an ACK to packet n+1 as an ACK of packet n.
  4319.                  This covers the case when the ACK to packet n is lost, and the
  4320.                  remote later sends a NAK. Any other NAKs cause a retransmit. */
  4321.  
  4322.          if rec_seq ^= mod (msg_number + 1, 64) then
  4323.             fail = true;
  4324.  
  4325.       when (msg_error)                         /* Error type. */
  4326.          do;
  4327.             state = state_a;
  4328.             return (false);
  4329.          end;
  4330.  
  4331.       otherwise
  4332.          do;
  4333.             snd_msg = 'Unexpected packet type "' || rec_pkt_type ||
  4334.                       '" received on remote system.';
  4335.             call send_packet (msg_error, length (snd_msg), msg_number);
  4336.             state = state_a;
  4337.             return (false);
  4338.          end;
  4339.    end;       /* Select */
  4340.  
  4341.    if ^fail then          /* A good response. */
  4342.       do;
  4343.          num_retries = 0;
  4344.          msg_number = mod (msg_number + 1, 64);
  4345.          return (true);
  4346.       end;
  4347.  
  4348.    if num_retries > max_retries then         /*  No response ? */
  4349.       do;
  4350.          num_retries = 0;
  4351.          snd_msg = 'Retry limit exceeded on remote system.';
  4352.          call send_packet (msg_error, length (snd_msg), msg_number);
  4353.          state = state_a;
  4354.       end;
  4355.    else
  4356.       num_retries = num_retries + 1;
  4357.  
  4358.    return (false);
  4359.  
  4360.    end;             /* Get_response */
  4361. -------------------------------------------------------------------------------
  4362.  
  4363. /* GET_USER_INFO -- Get the users PRIMOS environment variables. */
  4364.  
  4365. Get_user_info : proc;
  4366.  
  4367. Dcl code fixed bin,
  4368.     u_name char (32);
  4369.  
  4370. $Insert *>insert>common.ins.plp
  4371. $Insert *>insert>kermit.ins.plp
  4372. $Insert *>insert>primos.ins.plp
  4373. $Insert *>insert>constants.ins.plp
  4374. $Insert syscom>keys.ins.pl1
  4375.  
  4376. /* ************************************************************************* */
  4377.  
  4378.    call erkl$$ (k$read, my_erase, my_kill, code); /* Keep these for our user. */
  4379.    if code ^= 0 then
  4380.       do;
  4381.          my_erase = nul_7bit_asc || nul_7bit_asc;
  4382.          my_kill = my_erase;  /* Set these so that no "funnies" occur later. */
  4383.  
  4384.          call get_error_msg (code);
  4385.          call ioa$ ('Error getting erase and kill characters. %v%.', 99,
  4386.                     errmsg);
  4387.       end;
  4388.  
  4389.    my_duplex = duplx$ ('FFFF'b4);
  4390.    my_half_duplex = my_duplex | 'C000'b4;
  4391.  
  4392.    call msg$st (k$read, my_user_number, '', 0, u_name, 32, my_msg_state);
  4393.  
  4394.    return;
  4395.  
  4396.    end;       /* Get_user_info */
  4397. -------------------------------------------------------------------------------
  4398.  
  4399. /* INPUT -- Wait for a specified string for a specified time. */
  4400.  
  4401. Input : proc (string, wait_time) returns (bit (1) aligned);
  4402.  
  4403. Dcl string char (128) var,
  4404.     wait_time fixed bin;
  4405.  
  4406. $Insert *>insert>constants.ins.plp
  4407. $Insert *>insert>common.ins.plp
  4408. $Insert *>insert>kermit.ins.plp
  4409. $Insert *>insert>primos.ins.plp
  4410.  
  4411. Dcl (begin_min, begin_sec, idx, code, len) fixed bin,
  4412.     statv (2) fixed bin,
  4413.     esecs fixed bin (31),
  4414.     inbuffer_ptr ptr,
  4415.     (tempchr, ctrl_at) char,
  4416.     begin_day char (2),
  4417.     mainbuffer char (768) var,
  4418.     tempbuffer char (256) var,
  4419.     inbuffer char (256);
  4420.  
  4421. Dcl 1 time,
  4422.       2 (month, day, year) char (2),
  4423.       2 (minmidnt, seconds, ticks, cpusec, cputick, iosec, iotick,
  4424.          ticks_pre_sec, usernum) fixed bin,
  4425.       2 logname char (32);
  4426.  
  4427. /* ************************************************************************* */
  4428.  
  4429.    len = length (string) - 1;
  4430.    mainbuffer = saved_amlc_chrs;
  4431.    saved_amlc_chrs = '';
  4432.    inbuffer_ptr = addr (inbuffer);
  4433.  
  4434.    ctrl_at = ctl ('@');
  4435.    call timdat (time, 28);
  4436.    begin_day = time.day;
  4437.    begin_min = time.minmidnt;
  4438.    begin_sec = time.seconds;
  4439.  
  4440.    do while (true);
  4441.  
  4442.       idx = index (mainbuffer, string);   /* Test the buffer initially. */
  4443.       if idx > 0 then
  4444.          do;
  4445.             call tnou ((mainbuffer), idx + len);
  4446.             saved_amlc_chrs = after (mainbuffer, string);
  4447.             return (true);
  4448.          end;
  4449.       else
  4450.          do;            /* Output all but the last LEN characters. */
  4451.             idx = length (mainbuffer) - len;
  4452.             if idx > 0 then
  4453.                do;
  4454.                   call tnoua ((mainbuffer), idx);
  4455.                   if len > 0 then
  4456.                      mainbuffer = substr (mainbuffer, idx + 1, len);
  4457.                   else
  4458.                      mainbuffer = '';
  4459.                end;
  4460.          end;
  4461.  
  4462.       do until (statv(1) > 0);       /* Read until we get some characters. */
  4463.  
  4464.          if wait_time > 0 then             /* Check if it's time to go. */
  4465.             do;
  4466.                call timdat (time, 28);
  4467.                esecs = 0;
  4468.                if time.day ^= begin_day then
  4469.                   esecs = 86400;         /* Handle day boundaries. */
  4470.                esecs = esecs + (time.minmidnt - begin_min) * 60 +
  4471.                        (time.seconds - begin_sec);
  4472.                if esecs >= wait_time then        /* Time to go. */
  4473.                   do;
  4474.                      call tonl;
  4475.                      return (false);
  4476.                   end;
  4477.             end;
  4478.  
  4479.          call sleep$ (500);
  4480.  
  4481.          call t$amlc (amlc_line, inbuffer_ptr, 256, 6, statv, 1, code);
  4482.          if code ^= 0 then
  4483.             do;
  4484.                call tnou ('Unable to receive asynchronous data.', 36);
  4485.                return (false);
  4486.             end;
  4487.  
  4488.       end;    /* Do until */
  4489.  
  4490.       do idx = 1 to statv(1);
  4491.          tempchr = set8 (substr (inbuffer, idx, 1));
  4492.          if tempchr ^= ctrl_at then
  4493.             if tempchr < space_8bit_asc &
  4494.                tempchr ^= cr_8bit_asc & tempchr ^= lf_8bit_asc then
  4495.                mainbuffer = mainbuffer || '^' || ctl (tempchr);
  4496.             else
  4497.                mainbuffer = mainbuffer || tempchr;
  4498.       end;
  4499.  
  4500.       if session_log_opened then
  4501.          do;
  4502.             do while (length (mainbuffer) > 256);
  4503.                tempbuffer = substr (mainbuffer, 1, 256);
  4504.                call log_info (session_log, tempbuffer);
  4505.                mainbuffer = substr (mainbuffer, 257, length (mainbuffer) - 256);
  4506.             end;
  4507.  
  4508.             tempbuffer = mainbuffer;
  4509.             call log_info (session_log, tempbuffer);
  4510.          end;
  4511.  
  4512.    end;       /* Do while */
  4513.  
  4514.    return (false);
  4515.  
  4516.    end;       /* Input */
  4517. -------------------------------------------------------------------------------
  4518.  
  4519. /* KERMIT -- Main Kermit subroutine. */
  4520.  
  4521. Kermit : proc (cmd_line, code, com_name);
  4522.  
  4523. Dcl cmd_line char (256) var,
  4524.     com_name char (32) var,
  4525.     code fixed bin;
  4526.  
  4527. $Insert *>insert>common.ins.plp
  4528. $Insert *>insert>kermit.ins.plp
  4529. $Insert *>insert>primos.ins.plp
  4530. $Insert *>insert>constants.ins.plp
  4531. $Insert syscom>keys.ins.pl1
  4532. $Insert syscom>errd.ins.pl1
  4533.  
  4534. %Replace cl_width by 64;
  4535.  
  4536. Dcl cl_pic (12) char (cl_width) var static init (
  4537.     '-r, -rec, -receive tree;',
  4538.     '-s, -send tree;',
  4539.     '-a, -as, -alt, -alternate entry;',
  4540.     '-l, -log tree;',
  4541.     '-ft, -file, -file_type, -st, -store, -storage_type char;',
  4542.     '-init tree;',
  4543.     '-p, -par, -parity char;',
  4544.     '-h, -help;',
  4545.     '-u, -usage;',
  4546.     '-ser, -server;',
  4547.     '-pou, -pound char;',
  4548.     'end' );
  4549.  
  4550. Dcl 1 cl_struc external,
  4551.       2 rec_flag bit (1) aligned,
  4552.       2 rec_path char (128) var,
  4553.       2 send_flag bit (1) aligned,
  4554.       2 send_path char (128) var,
  4555.       2 alt_flag bit (1) aligned,
  4556.       2 alt_name char (32) var,
  4557.       2 log_flag bit (1) aligned,
  4558.       2 log_path char (128) var,
  4559.       2 storage_flag bit (1) aligned,
  4560.       2 storage_type char (80) var,
  4561.       2 kermit_init_flag bit (1) aligned,
  4562.       2 kinit_fname char (128) var,
  4563.       2 parity_flag bit (1) aligned,
  4564.       2 parity_type char (80) var,
  4565.       2 help_flag bit (1) aligned,
  4566.       2 usage_flag bit (1) aligned,
  4567.       2 ser_flag bit (1) aligned,
  4568.       2 pound_flag bit (1) aligned,
  4569.       2 pound_option char (80) var;
  4570.  
  4571. Dcl quit char (5) var,
  4572.     alarm char (6) var,
  4573.     basename char (32) var,
  4574.     (funit, type, sufusd, pix_index, bad_index) fixed bin;
  4575.  
  4576. /* ************************************************************************* */
  4577.  
  4578.    code = 0;
  4579.  
  4580.    call kermit_init;
  4581.  
  4582.    brk_lbl = done;
  4583.    quit = 'QUIT$';
  4584.    call mkonu$ (quit, bk_hndlr);          /* On-unit for quits. */
  4585.  
  4586.    alarm = 'ALARM$';
  4587.    call mkonu$ (alarm, timeout_hndlr);    /* On-unit for timeouts. */
  4588.  
  4589.    call cl$pix ('0002'b4, com_name, addr (cl_pic), cl_width, cmd_line,
  4590.                 addr (cl_struc), pix_index, bad_index, code);
  4591.    if code ^= 0 then
  4592.       return;
  4593.  
  4594.    if cl_struc.help_flag then
  4595.       do;
  4596.          call print_cl_help;
  4597.          return;
  4598.       end;
  4599.  
  4600.    if cl_struc.usage_flag then
  4601.       do;
  4602.          call print_cl_usage;
  4603.          return;
  4604.       end;
  4605.  
  4606.    if (cl_struc.rec_flag & (cl_struc.send_flag | cl_struc.ser_flag)) |
  4607.       (cl_struc.send_flag & cl_struc.ser_flag) then
  4608.       do;
  4609.          code = e$null;
  4610.          call tnou (
  4611.     'Incompatible options; only ONE of SEND, RECEIVE, or SERVER may be given.',
  4612.                     72);
  4613.          return;
  4614.       end;
  4615.  
  4616.    if cl_struc.alt_flag then
  4617.       if length (cl_struc.alt_name) = 0 then
  4618.          call tnou ('No ALTERNATE file name specified, none being used.', 50);
  4619.       else
  4620.          if fnchk$ (k$uprc, cl_struc.alt_name) then
  4621.             alternate_fname = cl_struc.alt_name;
  4622.          else
  4623.             do;
  4624.                code = e$bnam;
  4625.                call ioa$ ('Invalid ALTERNATE file name "%v".%.', 99,
  4626.                           cl_struc.alt_name);
  4627.                return;
  4628.             end;
  4629.  
  4630.    if cl_struc.log_flag then
  4631.       call start_log_file;
  4632.  
  4633.    in_init_file = cl_struc.kermit_init_flag;
  4634.  
  4635.    if ^in_init_file then
  4636.       do;
  4637.          call srsfx$ (k$exst, default_kermit_init_fname, funit, type, 0, '',
  4638.                       basename, sufusd, code);
  4639.          in_init_file = (code = 0 & (type <= 1 | type = 7));
  4640.          code = 0;
  4641.       end;
  4642.  
  4643.    if in_init_file then
  4644.       do;
  4645.          if length (cl_struc.kinit_fname) = 0 then
  4646.             kermit_init_file = default_kermit_init_fname;
  4647.          else
  4648.             kermit_init_file = cl_struc.kinit_fname;
  4649.  
  4650.          call comnd;
  4651.          kermit_init_file = '';
  4652.       end;
  4653.  
  4654.    if cl_struc.pound_flag then
  4655.       do;
  4656.          explicit_pound_set = true;
  4657.  
  4658.          select (cl_struc.pound_option);
  4659.  
  4660.             when ('OFF', 'N', 'NO')
  4661.                pound_conversion = false;
  4662.  
  4663.             when ('', 'ON', 'Y', 'YES')
  4664.                do;
  4665.                   pound_conversion = true;
  4666.                   if length (cl_struc.pound_option) = 0 then
  4667.                      call tnou (
  4668.           'No POUND option given, defaulting to ON for pound sign conversion.',
  4669.                                 66);
  4670.                end;
  4671.  
  4672.             otherwise
  4673.                do;
  4674.                   pound_conversion = true;
  4675.                   call ioa$ ('Unknown POUND option "%v", %$', 99,
  4676.                              cl_struc.pound_option);
  4677.                   call tnou ('defaulting to ON for pound sign conversion.', 43);
  4678.                end;
  4679.          end;
  4680.       end;
  4681.  
  4682.    if cl_struc.storage_flag then
  4683.       do;
  4684.          explicit_ft_set = true;
  4685.  
  4686.          select (cl_struc.storage_type);
  4687.  
  4688.             when ('AS', 'ASC', 'ASCII', 'T', 'TEXT')
  4689.                file_type = ascii_ft;
  4690.  
  4691.             when ('B', 'BIN', 'BINARY', 'I', 'IMAGE')
  4692.                do;
  4693.                   file_type = binary_ft;
  4694.                   if ^explicit_pound_set then       /* We DON'T want this! */
  4695.                      pound_conversion = false;
  4696.                end;
  4697.  
  4698.             when ('', 'AU', 'AUTO', 'AUTOMATIC')
  4699.                do;
  4700.                   file_type = automatic_ft;
  4701.                   explicit_ft_set = false;      /* Assume we haven't set it. */
  4702.                   if length (cl_struc.storage_type) = 0 then
  4703.                      call tnou (
  4704.                             'No FILE TYPE specified, defaulting to AUTOMATIC.',
  4705.                                 51);
  4706.                end;
  4707.  
  4708.             otherwise
  4709.                do;
  4710.                   file_type = automatic_ft;
  4711.                   explicit_ft_set = false;
  4712.                   call ioa$ (
  4713.                           'Unknown FILE TYPE "%v", defaulting to AUTOMATIC.%.',
  4714.                              99, cl_struc.storage_type);
  4715.                end;
  4716.          end;
  4717.       end;
  4718.  
  4719.    if cl_struc.parity_flag then
  4720.       select (cl_struc.parity_type);
  4721.  
  4722.          when ('', 'M', 'MARK')
  4723.             do;    /* No need to check 8-bit quoting, it hasn't changed yet. */
  4724.                do_transparent = false;
  4725.                do_8bit_chks = false;
  4726.  
  4727.                if length (cl_struc.parity_type) = 0 then
  4728.                   call tnou ('No PARITY type specified, defaulting to MARK.',
  4729.                              45);
  4730.             end;
  4731.  
  4732.          when ('N', 'NONE')
  4733.             do;
  4734.                do_transparent = true;
  4735.                do_8bit_chks = true;
  4736.                loc_8quote_chr = 'Y';
  4737.             end;
  4738.  
  4739.          otherwise
  4740.             do;
  4741.                do_transparent = false;
  4742.                do_8bit_chks = false;
  4743.                call ioa$ ('Unknown PARITY type "%v", defaulting to MARK.%.',
  4744.                           99, cl_struc.parity_type);
  4745.             end;
  4746.       end;
  4747.  
  4748.    if cl_struc.rec_flag then
  4749.       call rec_setup;
  4750.    else
  4751.       if cl_struc.send_flag then
  4752.          if length (cl_struc.send_path) = 0 then
  4753.             do;
  4754.                if in_init_file then
  4755.                   do;
  4756.                      call tonl;
  4757.                      in_init_file = false;
  4758.                   end;
  4759.  
  4760.                call tnou (
  4761.                  'No SEND pathname given; Interactive mode will be used.', 54);
  4762.                call comnd;
  4763.             end;
  4764.          else
  4765.             if tnchk$ (k$uprc + k$wldc, cl_struc.send_path) then
  4766.                call send_setup;
  4767.             else
  4768.                do;
  4769.                   code = e$itre;
  4770.                   call ioa$ ('Invalid SEND pathname(s) "%v".%.', 99,
  4771.                              cl_struc.send_path);
  4772.                end;
  4773.       else
  4774.          if cl_struc.ser_flag then
  4775.             call server_setup;
  4776.          else
  4777.             call comnd;
  4778.  
  4779. Done :      /* Return point for the QUIT$ on-unit. Since we
  4780.                are returning to PRIMOS we will close these files. */
  4781.  
  4782.    if take_level > 0 then
  4783.       do;
  4784.          call comi$$ ('TTY', 3, take_unit(take_level), bad_index);
  4785.  
  4786.          take_level = take_level - 1;
  4787.          do pix_index = 1 to take_level;
  4788.             call clo$fu (take_unit(pix_index), bad_index);
  4789.          end;
  4790.       end;
  4791.  
  4792.    if file_opened then
  4793.       call clo$fu (file_unit, bad_index);
  4794.  
  4795.    if packet_log_opened then
  4796.       call clo$fu (packet_log_unit, bad_index);
  4797.  
  4798.    if session_log_opened then
  4799.       call clo$fu (session_log_unit, bad_index);
  4800.  
  4801.    if use_amlc_line then
  4802.       call assign (0, amlc_line, bad_index);
  4803.  
  4804.    return;
  4805.  
  4806. /* ******************************* Rec_setup ******************************* */
  4807.  
  4808. /* REC_SETUP -- Setup to receive a file. */
  4809.  
  4810. Rec_setup : proc;
  4811.  
  4812. /* ************************************************************************* */
  4813.  
  4814.    call xfer_mode (1, code);            /* Switch to transfer mode. */
  4815.    if code ^= 0 then
  4816.       return;
  4817.  
  4818.    if in_init_file then
  4819.       call tonl;
  4820.  
  4821.    state = state_r;
  4822.    call set_path (cl_struc.rec_path);
  4823.    call tnou ('Kermit receive started.', 23);
  4824.  
  4825.    call rec_switch ();         /* Start receiving now. */
  4826.  
  4827.    call xfer_mode (0, code);
  4828.  
  4829.    return;
  4830.  
  4831.    end;      /* Rec_setup */
  4832.  
  4833. /* ****************************** Send_setup ******************************* */
  4834.  
  4835. /* SEND_SETUP -- Setup to send a group of files. */
  4836.  
  4837. Send_setup : proc;
  4838.  
  4839. /* ************************************************************************* */
  4840.  
  4841.    call xfer_mode (1, code);           /* Switch to transfer mode. */
  4842.    if code ^= 0 then
  4843.       return;
  4844.  
  4845.    if in_init_file then
  4846.       call tonl;
  4847.  
  4848.    state = state_s;
  4849.    call set_path (cl_struc.send_path);
  4850.    call tnou ('Kermit send started.', 20);
  4851.  
  4852.    call send_switch ();                /* Start sending now. */
  4853.  
  4854.    call xfer_mode (0, code);
  4855.  
  4856.    return;
  4857.  
  4858.    end;        /* Send_setup */
  4859.  
  4860. /* ***************************** Server_setup ****************************** */
  4861.  
  4862. /* SERVER_SETUP -- Setup to start server. */
  4863.  
  4864. Server_setup : proc;
  4865.  
  4866. /* ************************************************************************* */
  4867.  
  4868.    call xfer_mode (1, code);          /* Switch to transfer mode. */
  4869.    if code ^= 0 then
  4870.       return;
  4871.  
  4872.    if in_init_file then
  4873.       call tonl;
  4874.  
  4875.    call tnou ('Kermit server started.', 22);
  4876.  
  4877.    call server;
  4878.  
  4879.    call xfer_mode (0, code);
  4880.  
  4881.    return;
  4882.  
  4883.    end;      /* Server_setup */
  4884.  
  4885. /* ***************************** Print_cl_usage **************************** */
  4886.  
  4887. Print_cl_usage : proc;
  4888.  
  4889. /* ************************************************************************* */
  4890.  
  4891.    bad_index = length (com_name) + 10;
  4892.  
  4893.    call ioa$ ('%/ Usage : %v [{-Receive [pathname] | -Send wildcard%$', 99,
  4894.               com_name);
  4895.    call tnou (' | -SERver}]', 12);
  4896.    call ioa$ ('%#x[-Alternate filename] [-Log [pathname]] %$', 99, bad_index);
  4897.    call tnou ('[-Parity {MARK | NONE}]', 23);
  4898.    call ioa$ ('%#x[-File_Type {AUTOMATIC | TEXT | BINARY}]%$', 99, bad_index);
  4899.    call tnou (' [-INIT [pathname]]', 19);
  4900.    call ioa$ ('%#x[-POUnd {ON | OFF}] [-Help] [-Usage]%/%.', 99, bad_index);
  4901.  
  4902.    return;
  4903.  
  4904.    end;       /* Print_cl_usage */
  4905.  
  4906. /* ***************************** Print_cl_help ***************************** */
  4907.  
  4908. Print_cl_help : proc;
  4909.  
  4910. /* ************************************************************************* */
  4911.  
  4912.    call print_cl_usage;
  4913.  
  4914.    call ioa$ (' The first three options are mutually exclusive, %$', 99);
  4915.    call ioa$ ('but if none are specified%.', 99);
  4916.    call ioa$ (' then the user enters an interactive mode and is %$', 99);
  4917.    call ioa$ ('prompted for commands. All%.', 99);
  4918.    call ioa$ (' of the options may be abbreviated to those letters %$', 99);
  4919.    call ioa$ ('in uppercase.%/%.', 99);
  4920.    call ioa$ (' The options are :%/%.', 99);
  4921.    call ioa$ ('%5x-Receive [pathname]%/%8xUpload ONE file with the %$', 99);
  4922.    call ioa$ ('specified name or its original filename.%.', 99);
  4923.    call ioa$ ('%/%5x-Send wildcard%/%8xDownload several files. %$', 99);
  4924.    call ioa$ ('Wildcards may be used, but the -ALTERNATE%.', 99);
  4925.    call ioa$ ('%8xoption is then ignored.%.', 99);
  4926.    call ioa$ ('%/%5x-SERver%/%8xEnter server mode. Files may be %$', 99);
  4927.    call ioa$ ('sent and received, and additional%.', 99);
  4928.    call ioa$ ('%8xcommands may be issued.%.', 99);
  4929.  
  4930.    if ^more () then
  4931.       return;
  4932.  
  4933.    call ioa$ ('%/%5x-Alternate filename%.', 99);
  4934.    call ioa$ ('%8xAlternate file name for when ONE file is being sent.%.', 99);
  4935.    call ioa$ ('%/%5x-File_Type {AUTOMATIC | TEXT | BINARY}%.', 99);
  4936.    call ioa$ ('%8xSpecifies the type of file, %$', 99);
  4937.    call ioa$ ('or if AUTOMATIC is used then Kermit%.', 99);
  4938.    call ioa$ ('%8xwill try to determine its type. Default is AUTOMATIC.%.', 99);
  4939.    call ioa$ ('%/%5x-INIT [pathname]%.', 99);
  4940.    call tnou ('        By default an initialization file is executed.', 54);
  4941.    call ioa$ ('%8xDefault pathname is "%a".%.', 99, default_kermit_init_fname,
  4942.               length (default_kermit_init_fname));
  4943.    call ioa$ ('%/%5x-Parity {MARK | NONE}%.', 99);
  4944.    call ioa$ ('%8xSpecifies the character parity to %$', 99);
  4945.    call ioa$ ('use. Default is MARK.%.', 99);
  4946.    call ioa$ ('%/%5x-Log [pathname]%.', 99);
  4947.    call ioa$ ('%8xOpens a packet log file for recording the packets %$', 99);
  4948.    call ioa$ ('sent and received.%/%8xDefault log pathname is "%a".%.',
  4949.               99, default_packet_log, length (default_packet_log));
  4950.    call ioa$ ('%/%5x-POUnd {ON | OFF}%/%8xDetermines whether to convert DOS %$',
  4951.               99);
  4952.    call ioa$ ('pound signs. Default is ON.%/%.', 99);
  4953.  
  4954.    if ^more () then
  4955.       return;
  4956.  
  4957.    call ioa$ ('%/%5x-Help%/%8xDisplays this HELP message.%.', 99);
  4958.    call ioa$ ('%/%5x-Usage%/%8xDisplays the Kermit usage syntax only.%/%.', 99);
  4959.  
  4960.    return;
  4961.  
  4962.    end;       /* Print_cl_help */
  4963.  
  4964. /* ***************************** Start_log_file **************************** */
  4965.  
  4966. Start_log_file : proc;
  4967.  
  4968. /* ************************************************************************* */
  4969.  
  4970.    code = open_log (packet_log, cl_struc.log_path);
  4971.    if code ^= 0 then
  4972.       do;
  4973.          call get_error_msg (code);
  4974.          call ioa$ ('Log file not opened. %v%.', 99, errmsg);
  4975.       end;
  4976.  
  4977.    return;
  4978.  
  4979.    end;        /* Start_log_file */
  4980.  
  4981.    end;    /* Kermit */
  4982. -------------------------------------------------------------------------------
  4983.  
  4984. /* KERMIT_INIT -- Initialize Kermit variables. */
  4985.  
  4986. Kermit_init : proc;
  4987.  
  4988. $Insert *>insert>common.ins.plp
  4989. $Insert *>insert>kermit.ins.plp
  4990. $Insert *>insert>primos.ins.plp
  4991. $Insert *>insert>constants.ins.plp
  4992. $Insert syscom>keys.ins.pl1
  4993.  
  4994. Dcl temp fixed bin,
  4995.     b8 bit (8) aligned,
  4996.     b8_ptr ptr,
  4997.     primos_version char (16) var;
  4998.  
  4999. /* ************************************************************************* */
  5000.  
  5001.    b8_ptr = addr (b8);
  5002.    kversion = 'Public domain version 8.14';
  5003.    kprompt = 'Prime-Kermit> ';
  5004.    kprompt_len = length (kprompt);
  5005.    in_init_file = false;
  5006.    kermit_init_file = '';
  5007.  
  5008.    delay = default_delay;
  5009.    rec_seq = 0;
  5010.    msg_number = 0;
  5011.    snd_msg = '';
  5012.    rec_msg = '';
  5013.    rec_pkt_type = '';
  5014.    rec_length = 0;
  5015.  
  5016.    rec_file_size = -1;           /* Received file attributes. */
  5017.    rec_file_dtc = -1;
  5018.    rec_file_type = automatic_ft;
  5019.    use_attributes = true;
  5020.  
  5021.    do temp = 0 to 63;
  5022.       msg_table.slot(temp).msg = '';
  5023.       msg_table.slot(temp).acked = false;
  5024.       msg_table.slot(temp).retries = 0;
  5025.    end;
  5026.  
  5027.    tab_first = 0;                    /* Default transfer parameters. */
  5028.    tab_next = 0;
  5029.    state = 0;
  5030.    num_retries = 0;
  5031.    max_retries = default_max_retries;
  5032.    quote8_char = 'N';
  5033.    file_type = automatic_ft;         /* Unknown file type. */
  5034.    explicit_ft_set = false;
  5035.    first_write = true;
  5036.    filename_warning = true;
  5037.    do_repeats = false;
  5038.    do_transparent = false;
  5039.    do_flush = true;
  5040.    do_8bit_chks = false;
  5041.    auto_sum = true;
  5042.    packet_log_opened = false;
  5043.    packet_log_unit = 0;
  5044.    packet_log_pathname = default_packet_log;
  5045.    session_log_opened = false;
  5046.    session_log_unit = 0;
  5047.    session_log_pathname = default_session_log;
  5048.    session_log_save_line = '';
  5049.    window_size = 1;
  5050.    errmsg = '';
  5051.  
  5052.    take_level = 0;
  5053.    do temp = 1 to max_take_level;
  5054.       take_unit(temp) = 0;
  5055.    end;
  5056.  
  5057.    loc_pkt_size = my_pkt_size;       /* Default send init parameters. */
  5058.    loc_npad = my_npad;
  5059.    b8 = my_pad_chr;
  5060.    loc_padchar = b8_ptr -> char1_based;
  5061.    loc_timeout = my_timeout;
  5062.    b8 = my_eol_chr;
  5063.    loc_eol = b8_ptr -> char1_based;
  5064.    loc_quote_chr = my_quote_chr;
  5065.    loc_8quote_chr = my_8quote_chr;
  5066.    loc_chk_type = my_chk_type;
  5067.    loc_rep_chr = my_rep_chr;
  5068.    loc_capas1 = my_capas1;
  5069.    loc_file_attrib = false;
  5070.    loc_max_wsize = my_max_wsize;
  5071.  
  5072.    path_name = '';
  5073.    dir_name = '';
  5074.    non_null_dir = false;
  5075.    file_name = '';
  5076.    alternate_fname = '';
  5077.    file_unit = 0;
  5078.    file_opened = false;
  5079.    file_len = 0;
  5080.    file_pos = 0;
  5081.    space_count = 0;
  5082.    ignore_next = false;
  5083.    next_is_lf = false;
  5084.    saved_msg = '';
  5085.    saved_char = '';
  5086.  
  5087.    do temp = 1 to max_matches;
  5088.       matches(temp) = '';
  5089.    end;
  5090.  
  5091.    num_matches = 0;
  5092.    file_idx = 0;
  5093.  
  5094.    del_incomplete = true;
  5095.    ibuffer = copy (space_8bit_asc, ibuffer_size);
  5096.    ibuffer_ptr = addr (ibuffer);
  5097.    ibuflen = 0;
  5098.    ibuf_ptr = 0;
  5099.    char2_ptr = addr (char2);
  5100.    char2_ptr -> fb15_based = 0;
  5101.    pound_conversion = true;
  5102.    explicit_pound_set = false;
  5103.  
  5104.    do temp = 0 to 255;
  5105.       trans_char(temp) = '';
  5106.    end;
  5107.  
  5108.    dir_entry_ptr = addr (dir_entry);
  5109.  
  5110.    file_info_ptr = addr (file_info);
  5111.    file_info.version = 1;
  5112.    file_info.ldevno = -1;          /* No valid logical device number yet. */
  5113.  
  5114.    b8 = '00'b4;                    /* Setup all the character codes we need. */
  5115.    nul_7bit_asc = b8_ptr -> char1_based;
  5116.    b8 = '80'b4;
  5117.    nul_8bit_asc = b8_ptr -> char1_based;
  5118.  
  5119.    b8 = ctrl_a_7bit_dec;
  5120.    ctrl_a_7bit_asc = b8_ptr -> char1_based;
  5121.    b8 = ctrl_a_8bit_dec;
  5122.    ctrl_a_8bit_asc = b8_ptr -> char1_based;
  5123.  
  5124.    b8 = '08'b4;
  5125.    bs_7bit_asc = b8_ptr -> char1_based;
  5126.  
  5127.    b8 = '88'b4;
  5128.    bs_8bit_asc = b8_ptr -> char1_based;
  5129.  
  5130.    b8 = cr_7bit_dec;
  5131.    cr_7bit_asc = b8_ptr -> char1_based;
  5132.  
  5133.    rem_timeout = 60;             /* Default remote Kermit timeout for SHOW. */
  5134.    rem_eol = cr_7bit_asc;        /* We need this for the FIRST packet sent. */
  5135.  
  5136.    b8 = cr_8bit_dec;
  5137.    cr_8bit_asc = b8_ptr -> char1_based;
  5138.  
  5139.    b8 = lf_7bit_dec;
  5140.    lf_7bit_asc = b8_ptr -> char1_based;
  5141.  
  5142.    b8 = lf_8bit_dec;
  5143.    lf_8bit_asc = b8_ptr -> char1_based;
  5144.  
  5145.    b8 = '0C'b4;
  5146.    ff_7bit_asc = b8_ptr -> char1_based;
  5147.  
  5148.    b8 = '91'b4;
  5149.    dc1_8bit_asc = b8_ptr -> char1_based;
  5150.  
  5151.    b8 = '1A'b4;
  5152.    ctrl_z_7bit_asc = b8_ptr -> char1_based;
  5153.  
  5154.    b8 = '9A'b4;
  5155.    ctrl_z_8bit_asc = b8_ptr -> char1_based;
  5156.  
  5157.    b8 = '20'b4;
  5158.    space_7bit_asc = b8_ptr -> char1_based;
  5159.  
  5160.    b8 = '3F'b4;
  5161.    query_7bit_asc = b8_ptr -> char1_based;
  5162.  
  5163.    b8 = '60'b4;
  5164.    grave_7bit_asc = b8_ptr -> char1_based;
  5165.  
  5166.    b8 = 'FF'b4;
  5167.    del_8bit_asc = b8_ptr -> char1_based;
  5168.  
  5169.    my_new_erase = nul_7bit_asc || bs_8bit_asc;
  5170.    my_new_kill = nul_7bit_asc || del_8bit_asc;
  5171.  
  5172.    call user$ (my_user_number, temp);     /* Get my user number for later. */
  5173.  
  5174.    call get_user_info;
  5175.  
  5176.    call pri$rv (primos_version); /* See how up to date we are PRIMOS-wise. */
  5177.    old_primos_revision = (substr (primos_version, 1, 2) ^= '22');
  5178.  
  5179.    use_amlc_line = false;                 /* Asynchronous line variables. */
  5180.    escape_char = ctl (']');
  5181.    abort_char = 'C';
  5182.    break_char = 'B';
  5183.    saved_amlc_chrs = '';
  5184.    amlc_line = -1;
  5185.    baud_rate = 1200;
  5186.    baud_rate_index = 3;                   /* Default to 1200 baud. */
  5187.  
  5188.    return;
  5189.  
  5190.    end;         /* Kermit_init */
  5191. -------------------------------------------------------------------------------
  5192.  
  5193. /* LOG_INFO -- Log one line of info to log file. */
  5194.  
  5195. Log_info : proc (type, data);
  5196.  
  5197. Dcl type fixed bin,
  5198.     data char (256) var;
  5199.  
  5200. $Insert *>insert>common.ins.plp
  5201. $Insert *>insert>kermit.ins.plp
  5202. $Insert *>insert>primos.ins.plp
  5203. $Insert *>insert>constants.ins.plp
  5204.  
  5205. Dcl code fixed bin,
  5206.     (newdata, tempdata) char (512) var;
  5207.  
  5208. /* ************************************************************************* */
  5209.  
  5210.    if type = packet_log then
  5211.       do;
  5212.          if use_amlc_line then
  5213.             call tnou ('---- ' || data, length (data) + 5);
  5214.  
  5215.          if packet_log_opened then
  5216.             do;
  5217.                call wtlin$ (packet_log_unit, ('---- ' || data || '  '),
  5218.                             divide (length (data) + 6, 2, 15), code);
  5219.                if code ^= 0 then
  5220.                   do;
  5221.                      call get_error_msg (code);
  5222.                      call ioa$ ('Unable to write to the packet log file. %v%.',
  5223.                                 99, errmsg);
  5224.                      call tnou ('Closing the log file.', 21);
  5225.                      packet_log_opened = false;
  5226.                      call clo$fu (packet_log_unit, code);
  5227.                   end;
  5228.             end;
  5229.       end;
  5230.    else
  5231.       if session_log_opened then
  5232.          do;
  5233.             newdata = session_log_save_line || data;
  5234.  
  5235.             do while (index (newdata, lf_8bit_asc) ^= 0);
  5236.                tempdata = before (newdata, lf_8bit_asc);
  5237.                newdata = after (newdata, lf_8bit_asc);
  5238.  
  5239.                do while (index (tempdata, cr_8bit_asc) ^= 0);
  5240.                   tempdata = before (tempdata, cr_8bit_asc) ||
  5241.                              after (tempdata, cr_8bit_asc);
  5242.                end;
  5243.  
  5244.                call wtlin$ (session_log_unit, (tempdata || '  '),
  5245.                             divide (length (tempdata) + 1, 2, 15), code);
  5246.                if code ^= 0 then
  5247.                   do;
  5248.                      call get_error_msg (code);
  5249.                      call ioa$ ('Unable to write to the session log file. %v%.',
  5250.                                 99, errmsg);
  5251.                      call tnou ('Closing the log file.', 21);
  5252.                      session_log_opened = false;
  5253.                      call clo$fu (session_log_unit, code);
  5254.                   end;
  5255.             end;
  5256.  
  5257.             session_log_save_line = newdata;
  5258.          end;
  5259.  
  5260.    return;
  5261.  
  5262.    end;    /* Log_info */
  5263. -------------------------------------------------------------------------------
  5264.  
  5265. /* LOG_PACKET -- Log Kermit packet to disk. */
  5266.  
  5267. Log_packet : proc (packet_type, seq_num, data);
  5268.  
  5269. $Insert *>insert>common.ins.plp
  5270.  
  5271. Dcl packet_type char (1),
  5272.     seq_num fixed bin,
  5273.     data char (max_msg) var;
  5274.  
  5275. $Insert *>insert>kermit.ins.plp
  5276. $Insert *>insert>primos.ins.plp
  5277. $Insert *>insert>constants.ins.plp
  5278.  
  5279. Dcl line char (256) var,
  5280.     code fixed bin;
  5281.  
  5282. /* ************************************************************************* */
  5283.  
  5284.    if ^packet_log_opened then
  5285.       return;
  5286.  
  5287.    select (packet_type);
  5288.  
  5289.       when (msg_data)
  5290.          line = 'DATA ';
  5291.  
  5292.       when (msg_attrib)
  5293.          line = 'ATTR ';
  5294.  
  5295.       when (msg_ack)
  5296.          line = 'ACK  ';
  5297.  
  5298.       when (msg_nak)
  5299.          line = 'NAK  ';
  5300.  
  5301.       when (msg_snd_init)
  5302.          line = 'SNDI ';
  5303.  
  5304.       when (msg_break)
  5305.          line = 'BRK  ';
  5306.  
  5307.       when (msg_file)
  5308.          line = 'FILE ';
  5309.  
  5310.       when (msg_eof)
  5311.          line = 'EOF  ';
  5312.  
  5313.       when (msg_error)
  5314.          do;
  5315.             line = 'ERR  ';
  5316.             if use_amlc_line then
  5317.                call ioa$ ('---- Error during operation : "%v"%.', 99, data);
  5318.          end;
  5319.  
  5320.       when (msg_rcv_init)
  5321.          line = 'RCVI ';
  5322.  
  5323.       when (msg_host_command)
  5324.          line = 'HOST ';
  5325.  
  5326.       when (msg_text)
  5327.          line = 'TEXT ';
  5328.  
  5329.       when (msg_init_info)
  5330.          line = 'INIT ';
  5331.  
  5332.       when (msg_kermit)
  5333.          line = 'KER  ';
  5334.  
  5335.       when (msg_kermit_generic)
  5336.          line = 'GEN  ';
  5337.  
  5338.       when (msg_timeout)
  5339.          line = 'TIME ';
  5340.  
  5341.       when (msg_check_err)
  5342.          line = 'CHK  ';
  5343.  
  5344.       otherwise
  5345.          line = '?? ' || packet_type || space_8bit_asc;
  5346.  
  5347.    end;
  5348.  
  5349.    if seq_num < 10 then
  5350.       line = line || space_8bit_asc;
  5351.  
  5352.    line = line || trim (char (seq_num), '11'b);   /* Append the seq. number. */
  5353.  
  5354.    if length (data) ^= 0 then                     /* Append the data. */
  5355.       line = line || ' "' || data || '"';
  5356.  
  5357.    call wtlin$ (packet_log_unit, (line || '  '), divide (length (line) + 1,
  5358.                                                          2, 15), code);
  5359.    if code ^= 0 then
  5360.       do;
  5361.          call get_error_msg (code);
  5362.          call ioa$ ('Unable to log the packet. %v%/Closing the log file. %.',
  5363.                     99, errmsg);
  5364.          packet_log_opened = false;
  5365.          call clo$fu (packet_log_unit, code);
  5366.       end;
  5367.  
  5368.    return;
  5369.  
  5370.    end;        /* Log_packet */
  5371. -------------------------------------------------------------------------------
  5372.  
  5373. /* MATCH_FILE -- Match a wildcard spec from user to determine filenames. */
  5374.  
  5375. Match_file : proc returns (fixed bin);
  5376.  
  5377. $Insert *>insert>common.ins.plp
  5378. $Insert *>insert>kermit.ins.plp
  5379. $Insert *>insert>primos.ins.plp
  5380. $Insert syscom>keys.ins.pl1
  5381. $Insert syscom>errd.ins.pl1
  5382.  
  5383. Dcl (dir_unit, type, sufusd, code) fixed bin,
  5384.     (basename, fn, wild_name) char (32) var;
  5385.  
  5386. /* ************************************************************************* */
  5387.  
  5388.    code = 0;
  5389.    num_matches = 0;
  5390.  
  5391.    /* First we convert the filename to uppercase, and translate any
  5392.       wildcard characters from DOS to the PRIME equivelent. Apart from
  5393.       the one case below we cannot fully translate the wildcards, since
  5394.       we don't know what the user actually means.
  5395.  
  5396.       E.g. Given the file A.B.C, if the user types *.C do they just mean
  5397.            the files @.C, or do they mean @@.C which would include A.B.C. */
  5398.  
  5399.    if file_name = '*.*' then
  5400.       file_name = '@@';
  5401.  
  5402.    file_name = translate (file_name, uppercase || '@+', lowercase || '*?');
  5403.  
  5404.    if non_null_dir then
  5405.       path_name = dir_name || '>' || file_name;
  5406.    else
  5407.       path_name = file_name;
  5408.  
  5409.    call set_path (path_name);
  5410.  
  5411.    if search (path_name, '@+') = 0 then /* See if we have just one file name. */
  5412.       do;
  5413.          num_matches = 1;
  5414.          matches(1) = path_name;
  5415.          return (code);
  5416.       end;
  5417.  
  5418.    if search (dir_name, '@+') ^= 0 then      /* Wildcarded directories ? */
  5419.       return (e$itre);
  5420.  
  5421.    wild_name = file_name;
  5422.  
  5423.    call srsfx$ (k$read + k$getu, dir_name, dir_unit, type, 0, '', basename,
  5424.                 sufusd, code);
  5425.    if code ^= 0 then
  5426.       return (code);
  5427.  
  5428.    call dir$rd (k$init, dir_unit, dir_entry_ptr, dir_entry_size, code);
  5429.  
  5430.    do until (code ^= 0);
  5431.  
  5432.       call dir$rd (k$read, dir_unit, dir_entry_ptr, dir_entry_size, code);
  5433.  
  5434.       if code = 0 & dir_entry.ecw.type = '02'b4 &
  5435.          (dir_entry.file_inf.type < '02'b4 |
  5436.           dir_entry.file_inf.type = '07'b4) then
  5437.          do;                  /* It's an ordinary SAM, DAM, or CAM file. */
  5438.             fn = trim (dir_entry.entryname, '11'b);
  5439.             if wild$ (wild_name, fn, code) then
  5440.                do;
  5441.                   num_matches = num_matches + 1;
  5442.                   if num_matches <= max_matches then
  5443.                      matches(num_matches) = fn;
  5444.                   else
  5445.                      code = e$tmvv;         /* Too many values for variable. */
  5446.                end;
  5447.          end;
  5448.    end;
  5449.  
  5450.    call clo$fu (dir_unit, sufusd);
  5451.  
  5452.    if code = e$eof then
  5453.       code = 0;
  5454.  
  5455.    return (code);
  5456.  
  5457.    end;     /* Match_file */
  5458. -------------------------------------------------------------------------------
  5459.  
  5460. /* NEXT_FILE -- Fetch next file of wildcard specification. */
  5461.  
  5462. Next_file : proc returns (fixed bin);
  5463.  
  5464. $Insert *>insert>common.ins.plp
  5465. $Insert *>insert>kermit.ins.plp
  5466. $Insert *>insert>constants.ins.plp
  5467.  
  5468. Dcl code fixed bin,
  5469.     test_flag bit (1) aligned;
  5470.  
  5471. /* ************************************************************************* */
  5472.  
  5473.    test_flag = false;
  5474.  
  5475.    do until (test_flag);
  5476.       if file_idx > num_matches | file_idx = 0 then
  5477.          return (ker_nomorfiles);    /* Check for the end of the table. */
  5478.  
  5479.       call set_path (matches(file_idx));  /* Get the next file name. */
  5480.  
  5481.       code = open_input ();               /* Try to open the file. */
  5482.       if code ^= 0 then
  5483.          do;
  5484.             call get_error_msg (code);
  5485.             call log_info (packet_log, 'Error opening ' || path_name || '. ' ||
  5486.                                         errmsg);
  5487.             file_idx = file_idx + 1;      /* Try the next file. */
  5488.          end;
  5489.       else
  5490.          do;
  5491.             test_flag = true;
  5492.  
  5493.             if packet_log_opened then
  5494.                do;
  5495.                   select (file_type);
  5496.  
  5497.                      when (ascii_ft)
  5498.                         errmsg = 'as ASCII file type.';
  5499.  
  5500.                      when (binary_ft)
  5501.                         errmsg = 'as BINARY file type.';
  5502.  
  5503.                      when (automatic_ft)
  5504.                         errmsg = 'with AUTOMATIC file type detection.';
  5505.  
  5506.                      otherwise
  5507.                         errmsg = 'with an ILLEGAL file type.';
  5508.  
  5509.                   end;
  5510.  
  5511.                   call log_info (packet_log, 'File ' || path_name ||
  5512.                                              ' opened ' || errmsg);
  5513.  
  5514.                   if explicit_ft_set then
  5515.                      call log_info (packet_log,
  5516.                                     'The file type has been explicitly set.');
  5517.                   else
  5518.                      if file_type ^= automatic_ft then
  5519.                         call log_info (packet_log,
  5520.                                   'The file type has been automatically set.');
  5521.                end;
  5522.          end;
  5523.  
  5524.    end;
  5525.  
  5526.    if num_matches = 1 & length (alternate_fname) ^= 0 then
  5527.       do;              /* Use the alternate file name if given. */
  5528.          file_name = alternate_fname;
  5529.  
  5530.          if packet_log_opened then
  5531.             call log_info (packet_log, 'The file ' || path_name ||
  5532.                            ' will be sent using the alternate file name of ' ||
  5533.                            alternate_fname || '.');
  5534.  
  5535.          if ^non_null_dir then
  5536.             path_name = file_name;
  5537.          else
  5538.             path_name = dir_name || '>' || file_name;
  5539.       end;
  5540.  
  5541.    file_idx = file_idx + 1;               /* Point to next file name. */
  5542.  
  5543.    return (ker_normal);
  5544.  
  5545.    end;       /* Next_file */
  5546. -------------------------------------------------------------------------------
  5547.  
  5548. /* OPEN_INPUT -- Open input file, determine its type and length. */
  5549.  
  5550. Open_input : proc returns (fixed bin);
  5551.  
  5552. $Insert *>insert>common.ins.plp
  5553. $Insert *>insert>kermit.ins.plp
  5554. $Insert *>insert>primos.ins.plp
  5555. $Insert *>insert>constants.ins.plp
  5556. $Insert syscom>keys.ins.pl1
  5557. $Insert syscom>errd.ins.pl1
  5558.  
  5559. Dcl (type, code, rnw, code2, sufusd) fixed bin,
  5560.     basename char (32) var;
  5561.  
  5562. /* ************************************************************************* */
  5563.  
  5564.    call srsfx$ (k$read + k$getu, path_name, file_unit, type, 0, '', basename,
  5565.                 sufusd, code);
  5566.  
  5567.    if type > 1 & type ^= 7 then
  5568.       do;
  5569.          call clo$fu (file_unit, rnw);
  5570.          if code = 0 then
  5571.             code = e$wft;
  5572.       end;
  5573.  
  5574.    file_opened = (code = 0);
  5575.  
  5576.    if code ^= 0 then
  5577.       return (code);
  5578.  
  5579.    space_count = 0;        /* Initialise these just in case. */
  5580.    ignore_next = false;
  5581.    next_is_lf = false;
  5582.  
  5583.    ibuflen = 0;            /* These must be initialised. */
  5584.    file_pos = 0;
  5585.    ibuf_ptr = 1;
  5586.    ibuffer = '';
  5587.  
  5588.    code = get_len (false);
  5589.    if code = 0 then
  5590.       do;
  5591.          if file_len = 0 then
  5592.             file_type = ascii_ft;          /* This takes care of empty files. */
  5593.  
  5594.          if file_type = automatic_ft then  /* AUTOMATIC file type detection. */
  5595.             call ck_file_type;
  5596.  
  5597.          if file_type = binary_ft & ^explicit_pound_set then
  5598.             pound_conversion = false;      /* Re-set this if need be. */
  5599.  
  5600.          if file_type = ascii_ft then
  5601.             code = get_len (true);
  5602.  
  5603.          if code = 0 then
  5604.             return (code);
  5605.       end;
  5606.  
  5607.    file_opened = false;      /* Something is wrong here, so close the file. */
  5608.    call clo$fu (file_unit, code2);
  5609.  
  5610.    return (code);
  5611.  
  5612. /* ****************************** Ck_file_type ***************************** */
  5613.  
  5614. Ck_file_type : proc;
  5615.  
  5616. Dcl (character, prev_char) char (1),
  5617.     character_ptr ptr;
  5618.  
  5619. Dcl 1 bit_char based,
  5620.       2 high_bit bit (1),
  5621.       2 rest bit (7);
  5622.  
  5623. /* ************************************************************************* */
  5624.  
  5625.    /* Initialize local variables for file type checking. */
  5626.  
  5627.    code = 0;
  5628.    character = nul_7bit_asc;
  5629.    character_ptr = addr (character);
  5630.  
  5631.    call prwf$$ (k$read, file_unit, ibuffer_ptr, ibuffer_size_wds, 0, rnw, code);
  5632.  
  5633.    if code = e$eof & rnw ^= 0 then
  5634.       code = 0;
  5635.  
  5636.    ibuflen = 2 * rnw;
  5637.    file_pos = ibuflen;
  5638.  
  5639.    if code ^= 0 then
  5640.       return;
  5641.  
  5642.    file_type = ascii_ft;         /* Assume it's ASCII to begin with. */
  5643.  
  5644.    do ibuf_ptr = 1 to ibuflen while (file_type ^= binary_ft);
  5645.  
  5646.       prev_char = character;
  5647.       character = substr (ibuffer, ibuf_ptr, 1);
  5648.  
  5649.    /* If the high bit is off then check for some special
  5650.       characters before deciding that it IS a binary file. */
  5651.  
  5652.       if ^character_ptr -> bit_char.high_bit then
  5653.          if prev_char ^= dc1_8bit_asc &        /* Space compression. */
  5654.             ^(prev_char = lf_8bit_asc & character = nul_7bit_asc) & /* LFNUL */
  5655.             ^(character = bs_7bit_asc |        /* Back Space. */
  5656.               character = ff_7bit_asc) &       /* Form Feed. */
  5657.             ^(character = ctrl_a_7bit_asc &   /* CTRL-A for FORTRAN formats. */
  5658.               (prev_char = lf_8bit_asc | prev_char = nul_7bit_asc |
  5659.                prev_char = ctrl_a_7bit_asc)) &
  5660.             character ^= ctrl_z_7bit_asc then
  5661.                file_type = binary_ft;
  5662.  
  5663.    end;
  5664.  
  5665.    if file_type ^= binary_ft & file_len = ibuflen then
  5666.       do;            /* ASCII files must end in LF or CTRL-Z. */
  5667.          if character = nul_7bit_asc then
  5668.             character = prev_char;
  5669.  
  5670.          if ^(character = lf_8bit_asc | character = ctrl_z_7bit_asc) then
  5671.             file_type = binary_ft;
  5672.       end;
  5673.  
  5674.    ibuflen = 0;             /* Re-initialize some of our buffer variables. */
  5675.    ibuf_ptr = 1;
  5676.    ibuffer = '';
  5677.  
  5678.    call prwf$$ (k$posn + k$prea, file_unit, null (), 0, 0, rnw, code);
  5679.  
  5680.    if code = 0 then
  5681.       file_pos = 0;
  5682.  
  5683.    return;
  5684.  
  5685.    end;        /* Ck_file_type */
  5686.  
  5687.    end;      /* Open_input */
  5688. -------------------------------------------------------------------------------
  5689.  
  5690. /* OPEN_LOG -- Open an output log file. */
  5691.  
  5692. Open_log : proc (log_type, pathname) returns (fixed bin);
  5693.  
  5694. Dcl log_type fixed bin,
  5695.     pathname char (128) var;
  5696.  
  5697. $Insert *>insert>common.ins.plp
  5698. $Insert *>insert>primos.ins.plp
  5699. $Insert *>insert>constants.ins.plp
  5700. $Insert syscom>keys.ins.pl1
  5701. $Insert syscom>errd.ins.pl1
  5702.  
  5703. Dcl (log_unit, type, sufusd, code) fixed bin,
  5704.     basename char (32) var,
  5705.     fn char (128) var;
  5706.  
  5707. /* ************************************************************************* */
  5708.  
  5709.    fn = pathname;
  5710.    if length (fn) = 0 then
  5711.       if log_type = packet_log then
  5712.          fn = default_packet_log;
  5713.       else
  5714.          fn = default_session_log;
  5715.  
  5716.    call fil$dl (fn, code);       /* Delete any old file first, if possible. */
  5717.  
  5718.    if code = 0 | code = e$fntf | code = e$ninf then
  5719.       call srsfx$ (k$writ + k$getu, fn, log_unit, type, 0, '', basename,
  5720.                    sufusd, code);
  5721.  
  5722.    if code = 0 then
  5723.       do;
  5724.          if fnchk$ (k$uprc, fn) then
  5725.             fn = '*>' || fn;
  5726.  
  5727.          if log_type = packet_log then
  5728.             do;
  5729.                packet_log_opened = true;
  5730.                packet_log_unit = log_unit;
  5731.                packet_log_pathname = fn;
  5732.             end;
  5733.          else
  5734.             do;
  5735.                session_log_opened = true;
  5736.                session_log_unit = log_unit;
  5737.                session_log_pathname = fn;
  5738.             end;
  5739.       end;
  5740.    else
  5741.       if log_type = packet_log then
  5742.          packet_log_opened = false;
  5743.       else
  5744.          session_log_opened = false;
  5745.  
  5746.    return (code);
  5747.  
  5748.    end;      /* Open_log */
  5749. -------------------------------------------------------------------------------
  5750.  
  5751. /* OPEN_OUTPUT -- Open an output file. */
  5752.  
  5753. Open_output : proc returns (fixed bin);
  5754.  
  5755. $Insert *>insert>kermit.ins.plp
  5756. $Insert *>insert>common.ins.plp
  5757. $Insert *>insert>primos.ins.plp
  5758. $Insert *>insert>constants.ins.plp
  5759. $Insert syscom>keys.ins.pl1
  5760. $Insert syscom>errd.ins.pl1
  5761.  
  5762. Dcl (type, sufusd, code, num_len, i) fixed bin,
  5763.     (file_exists, new_file_name, overwrite) bit (1) aligned,
  5764.     new_path_ptr ptr,
  5765.     (treename, new_path) char (128) var,
  5766.     (basename, suffix) char (32) var;
  5767.  
  5768. Dcl 1 bvs based,
  5769.       2 len fixed bin,
  5770.       2 chars char (128);
  5771.  
  5772. %Replace dot by '.';
  5773.  
  5774. /* ************************************************************************* */
  5775.  
  5776.    file_exists = false;
  5777.    file_opened = false;
  5778.    new_file_name = false;
  5779.  
  5780.    if non_null_dir then
  5781.       if ^tnchk$ (k$uprc, dir_name) then
  5782.          return (e$itre);                 /* A bad directory name given. */
  5783.  
  5784.    if ^fnchk$ (k$uprc, file_name) then
  5785.       do;                                 /* Replace a bad file name. */
  5786.          new_file_name = true;
  5787.          file_name = 'KERMIT_FILE';
  5788.  
  5789.          if ^non_null_dir then
  5790.             path_name = file_name;
  5791.          else
  5792.             path_name = dir_name || '>' || file_name;
  5793.       end;
  5794.  
  5795.    if filename_warning then
  5796.       do;
  5797.          call srsfx$ (k$exst, path_name, file_unit, type, 0, '', basename,
  5798.                       sufusd, code);
  5799.          if code = 0 then
  5800.             do;
  5801.                file_exists = true;
  5802.                new_path_ptr = addr (new_path);
  5803.                overwrite = (length (file_name) = 32);
  5804.  
  5805.                if overwrite then   /* Overwrite or append to the file name. */
  5806.                   num_len = 1;
  5807.                else
  5808.                   do;
  5809.                      num_len = 32 - length (file_name);
  5810.                      if num_len > 4 then
  5811.                         num_len = 4;
  5812.                   end;
  5813.  
  5814.                if index (file_name, dot) ^= 0 then
  5815.                   do;
  5816.                      treename = before (file_name, dot);
  5817.                      suffix = dot || after (file_name, dot);
  5818.                   end;
  5819.                else
  5820.                   do;
  5821.                      treename = file_name;
  5822.                      suffix = '';
  5823.                   end;
  5824.  
  5825.                if overwrite then
  5826.                   treename = substr (treename, 1, length (treename) - 1);
  5827.  
  5828.                do i = 1 to 9999 until (code ^= 0);
  5829.                   if overwrite then
  5830.                      if i = 10 then
  5831.                         do;
  5832.                            num_len = 2;
  5833.                            treename = substr (treename, 1,
  5834.                                               length (treename) - 1);
  5835.                         end;
  5836.                      else
  5837.                         if i = 100 then
  5838.                            do;
  5839.                               num_len = 3;
  5840.                               treename = substr (treename, 1,
  5841.                                                  length (treename) - 1);
  5842.                            end;
  5843.                         else
  5844.                            if i = 1000 then
  5845.                               do;
  5846.                                  num_len = 4;
  5847.                                  treename = substr (treename, 1,
  5848.                                                     length (treename) - 1);
  5849.                               end;
  5850.  
  5851.                   call ioa$rs (new_path_ptr -> bvs.chars, 128,
  5852.                                new_path_ptr -> bvs.len, '%v%#zd%v%$', 99,
  5853.                                treename, num_len, i, suffix);
  5854.  
  5855.                   call srsfx$ (k$exst, new_path, file_unit, type, 0, '',
  5856.                                basename, sufusd, code);
  5857.                end;
  5858.  
  5859.                if code = e$fntf then
  5860.                   call set_path (new_path);
  5861.                else
  5862.                   if code = 0 then
  5863.                      code = e$ialn;
  5864.             end;
  5865.       end;
  5866.    else
  5867.       call fil$dl (path_name, code);
  5868.  
  5869.    if code = 0 | code = e$fntf | code = e$ninf then
  5870.       do;
  5871.          call srsfx$ (k$writ + k$getu, path_name, file_unit, type, 0, '',
  5872.                       basename, sufusd, code);
  5873.          if code = 0 then
  5874.             do;
  5875.                ibuffer = '';
  5876.                ibuf_ptr = 0;
  5877.                first_write = true;
  5878.             end;
  5879.       end;
  5880.  
  5881.    file_opened = (code = 0);
  5882.  
  5883.    if code = 0 then
  5884.       if new_file_name then
  5885.          code = e$bnam;          /* Say that the file name was bad. */
  5886.       else
  5887.          if file_exists then     /* Say that the file already exists. */
  5888.             code = e$exst;
  5889.  
  5890.    return (code);
  5891.  
  5892.    end;         /* Open_output */
  5893. -------------------------------------------------------------------------------
  5894.  
  5895. /* PRS_SEND_INIT -- Parse SND_INIT packet from remote Kermit. */
  5896.  
  5897. Prs_send_init : proc;
  5898.  
  5899. $Insert *>insert>common.ins.plp
  5900. $Insert *>insert>kermit.ins.plp
  5901. $Insert *>insert>constants.ins.plp
  5902.  
  5903. Dcl (cap_len, cap_pos, cap_byte) fixed bin,
  5904.     cap_ptr ptr;
  5905.  
  5906. /* ************************************************************************* */
  5907.  
  5908.    rem_pkt_size = 80;   /* Set the default values for fields not received. */
  5909.    rem_npad = 0;
  5910.    rem_padchar = nul_7bit_asc;
  5911.    rem_pad_chars = copy (rem_padchar, max_rem_pad_chrs);  /* Never received. */
  5912.    rem_timeout = 60;                /* Timeout in seconds. */
  5913.    rem_eol = cr_7bit_asc;
  5914.    rem_quote_chr = '#';
  5915.    rem_8quote_chr = 'N';
  5916.    rem_chk_type = '1';
  5917.    rem_rep_chr = space_8bit_asc;
  5918.    rem_capas1 = 0;
  5919.    rem_file_attrib = false;
  5920.    rem_windowing = false;
  5921.    rem_max_wsize = 1;
  5922.  
  5923.    /* Process the packet according to its length. */
  5924.  
  5925.    select (length (rec_msg) - pkt_tot_ovr_head);
  5926.  
  5927.       when (p_si_bufsiz)
  5928.          goto pkt_lbl;
  5929.  
  5930.       when (p_si_timout)
  5931.          goto to_lbl;
  5932.  
  5933.       when (p_si_npad)
  5934.          goto np_lbl;
  5935.  
  5936.       when (p_si_pad)
  5937.          goto pc_lbl;
  5938.  
  5939.       when (p_si_eol)
  5940.         goto eol_lbl;
  5941.  
  5942.       when (p_si_quote)
  5943.          goto qc_lbl;
  5944.  
  5945.       when (p_si_8quote)
  5946.          goto ebqc_lbl;
  5947.  
  5948.       when (p_si_chk)
  5949.          goto chk_lbl;
  5950.  
  5951.       when (p_si_rep)
  5952.          go to rep_lbl;
  5953.  
  5954.    end;
  5955.  
  5956.    /* Longer messages drop through to check the capabilities. */
  5957.  
  5958.    cap_ptr = addr (rem_capas1);
  5959.    rem_capas1 = knum (substr (rec_msg, pkt_msg + p_si_capas, 1));
  5960.    rem_file_attrib = cap_ptr -> capas.file_attributes;
  5961.    rem_windowing = cap_ptr -> capas.windowing;
  5962.  
  5963.    /* Find the end of the variable length capabilities field. */
  5964.  
  5965.    cap_len = 1;
  5966.    cap_byte = rem_capas1;
  5967.    cap_ptr = addr (cap_byte);
  5968.  
  5969.    do while (cap_ptr -> capas.continues);
  5970.       cap_len = cap_len + 1;
  5971.       cap_byte = knum (substr (rec_msg, pkt_msg + p_si_capas + cap_len - 1, 1));
  5972.    end;
  5973.  
  5974.    cap_pos = pkt_msg + p_si_capas + cap_len;
  5975.  
  5976.    if rem_windowing then             /* Get the maximum window size. */
  5977.       rem_max_wsize = knum (substr (rec_msg, cap_pos, 1));
  5978.  
  5979. Rep_lbl :
  5980.    rem_rep_chr = substr (rec_msg, pkt_msg + p_si_rep, 1);
  5981.  
  5982. Chk_lbl :
  5983.    rem_chk_type = substr (rec_msg, pkt_msg + p_si_chk, 1);
  5984.  
  5985. Ebqc_lbl :
  5986.    rem_8quote_chr = substr (rec_msg, pkt_msg + p_si_8quote, 1);
  5987.  
  5988. Qc_lbl :
  5989.    rem_quote_chr = substr (rec_msg, pkt_msg + p_si_quote, 1);
  5990.  
  5991. Eol_lbl :
  5992.    char2_ptr -> fb15_based = knum (substr (rec_msg, pkt_msg + p_si_eol, 1));
  5993.    rem_eol = char2(2);
  5994.  
  5995. Pc_lbl :
  5996.    rem_padchar = ctl (substr (rec_msg, pkt_msg + p_si_pad, 1));
  5997.    rem_pad_chars = copy (rem_padchar, max_rem_pad_chrs);
  5998.  
  5999. Np_lbl :
  6000.    rem_npad = knum (substr (rec_msg, pkt_msg + p_si_npad, 1));
  6001.  
  6002. To_lbl :
  6003.    rem_timeout = knum (substr (rec_msg, pkt_msg + p_si_timout, 1));
  6004.  
  6005. Pkt_lbl :
  6006.    rem_pkt_size = knum (substr (rec_msg, pkt_msg + p_si_bufsiz, 1));
  6007.  
  6008.    return;
  6009.  
  6010.    end;        /* Prs_send_init */
  6011. -------------------------------------------------------------------------------
  6012.  
  6013. /* READ_INPUT -- Read input file and form data packet. */
  6014.  
  6015. Read_input : proc (code) returns (fixed bin);
  6016.  
  6017. Dcl code fixed bin;
  6018.  
  6019. $Insert *>insert>common.ins.plp
  6020. $Insert *>insert>kermit.ins.plp
  6021. $Insert *>insert>primos.ins.plp
  6022. $Insert *>insert>constants.ins.plp
  6023. $Insert syscom>keys.ins.pl1
  6024. $Insert syscom>errd.ins.pl1
  6025.  
  6026. Dcl (rep_count, max_chars, rnw) fixed bin,
  6027.     new_char_ptr ptr,
  6028.     (packet_full, repeating) bit (1) aligned,
  6029.     (prev_char, new_char) char (1),
  6030.     chr char (6) var;
  6031.  
  6032. /* ************************************************************************* */
  6033.  
  6034.    code = 0;
  6035.    char2_ptr -> fb15_based = 0;
  6036.    chr = '';
  6037.    repeating = false;
  6038.    packet_full = false;
  6039.    new_char_ptr = addr (new_char);
  6040.  
  6041.    if length (saved_msg) ^= 0 then
  6042.       do;
  6043.          snd_msg = saved_msg;
  6044.          saved_msg = '';
  6045.  
  6046.          rep_count = length (saved_char);       /* For EOF with 1 char left
  6047.                                                    rep_count will be 0. */
  6048.          if rep_count = 1 then
  6049.             do;
  6050.                prev_char = substr (saved_char, 1, 1);
  6051.                saved_char = '';
  6052.             end;
  6053.       end;
  6054.    else
  6055.       do;
  6056.          rep_count = 0;
  6057.          snd_msg = '';
  6058.          prev_char = nul_7bit_asc;
  6059.       end;
  6060.  
  6061.    max_chars = rem_pkt_size - pkt_tot_ovr_head + 1;  /* Maximum packet size. */
  6062.  
  6063. Loop :
  6064.  
  6065.    do until (packet_full | code ^= 0);              /* Main packet loop. */
  6066.  
  6067.       call read_char;
  6068.       if code ^= 0 then
  6069.          if do_repeats then
  6070.             if rep_count = 0 | code ^= e$eof then
  6071.                leave loop;
  6072.             else
  6073.                goto store_chr;
  6074.          else
  6075.             leave loop;
  6076.  
  6077.       if do_repeats then
  6078.          if (new_char = prev_char & rep_count < 94) | rep_count = 0 then
  6079.             do;
  6080.                repeating = true;
  6081.                rep_count = rep_count + 1;
  6082.             end;
  6083.          else
  6084.             do;
  6085. Store_chr :
  6086.                repeating = false;
  6087.                char2(2) = prev_char;
  6088.                chr = trans_char (char2_ptr -> fb15_based);
  6089.  
  6090.                if rep_count > 2 then
  6091.                   do;
  6092.                      char2_ptr -> fb15_based = rep_count + 32;
  6093.                      chr = loc_rep_chr || char2(2) || chr;
  6094.                   end;
  6095.                else
  6096.                   if rep_count = 2 then
  6097.                      chr = chr || chr;
  6098.  
  6099.                rep_count = 1;
  6100.             end;
  6101.       else
  6102.          do;
  6103.             char2(2) = new_char;
  6104.             chr = trans_char (char2_ptr -> fb15_based);
  6105.          end;
  6106.  
  6107.       prev_char = new_char;
  6108.  
  6109.       if ^repeating then
  6110.          if length (snd_msg) + length (chr) <= max_chars then
  6111.             snd_msg = snd_msg || chr;
  6112.          else
  6113.             do;
  6114.                packet_full = true;
  6115.                saved_msg = chr;
  6116.  
  6117.                if code = e$eof then
  6118.                   saved_char = '';
  6119.                else
  6120.                   saved_char = new_char;
  6121.             end;
  6122.    end;
  6123.  
  6124.    if code = e$eof then
  6125.       code = 0;
  6126.  
  6127.    if code ^= 0 then
  6128.       return (ker_internalerr);
  6129.    else
  6130.       if length (snd_msg) = 0 then
  6131.          return (ker_eof);
  6132.       else
  6133.          return (ker_normal);
  6134.  
  6135. /* ******************************* Read_raw ******************************** */
  6136.  
  6137. Read_raw : proc;
  6138.  
  6139. /* ************************************************************************* */
  6140.  
  6141.    ibuf_ptr = ibuf_ptr + 1;
  6142.  
  6143.    if ibuf_ptr > ibuflen then
  6144.       do;
  6145.          call prwf$$ (k$read, file_unit, ibuffer_ptr, ibuffer_size_wds, 0,
  6146.                       rnw, code);
  6147.          if code = e$eof & rnw ^= 0 then
  6148.             code = 0;
  6149.  
  6150.          ibuflen = 2 * rnw;
  6151.  
  6152.          if code = 0 then
  6153.             do;
  6154.                file_pos = file_pos + ibuflen;
  6155.  
  6156.                if file_pos > file_len then
  6157.                   ibuflen = ibuflen - 1;
  6158.             end;
  6159.          else
  6160.             return;
  6161.  
  6162.          ibuf_ptr = 1;
  6163.  
  6164.       end;
  6165.  
  6166.    new_char = substr (ibuffer, ibuf_ptr, 1);
  6167.  
  6168.    return;
  6169.  
  6170.    end;              /* Read_raw */
  6171.  
  6172. /* ******************************* Read_char ******************************* */
  6173.  
  6174. Read_char : proc;
  6175.  
  6176. /* ************************************************************************* */
  6177.  
  6178.    if space_count > 0 then          /* Still doing space compression. */
  6179.       do;
  6180.          new_char = space_7bit_asc;
  6181.          space_count = space_count - 1;
  6182.       end;
  6183.    else
  6184.       if next_is_lf then            /* Next character must be a LF. */
  6185.          do;
  6186.             next_is_lf = false;
  6187.             new_char = lf_7bit_asc;
  6188.          end;
  6189.       else
  6190.          do;
  6191.             if ignore_next then     /* Ignore the next character. */
  6192.                do;
  6193.                   ignore_next = false;
  6194.                   call read_raw;
  6195.                   if code ^= 0 then
  6196.                      return;
  6197.                end;
  6198.  
  6199.             call read_raw;
  6200.             if code ^= 0 then
  6201.                return;
  6202.  
  6203.             if file_type = ascii_ft then
  6204.                if new_char = dc1_8bit_asc then   /* Space compression char. */
  6205.                   do;
  6206.                      call read_raw;         /* Get the number of spaces. */
  6207.                      if code ^= 0 then
  6208.                         return;
  6209.  
  6210.                      space_count = (new_char_ptr -> bit8_based) - 1;
  6211.                      new_char = space_7bit_asc;
  6212.                   end;
  6213.                else
  6214.                   if new_char = lf_8bit_asc then   /* Linefeed character. */
  6215.                      do;
  6216.                         next_is_lf = true;
  6217.                         ignore_next = (mod (ibuf_ptr, 2) ^= 0);
  6218.                         new_char = cr_7bit_asc;    /* Replace LF by CR LF. */
  6219.                      end;
  6220.                   else       /* For all other chars make them 7-bit ASCII. */
  6221.                      new_char = clr8 (new_char);
  6222.          end;
  6223.  
  6224.    return;
  6225.  
  6226.    end;              /* Read_char */
  6227.  
  6228.    end;             /* Read_input */
  6229. -------------------------------------------------------------------------------
  6230.  
  6231. /* REC_AMLC -- Receive characters from an asynchronous line. */
  6232.  
  6233. /* This subroutine reads characters until a new line
  6234.    is found or the buffer size is reached. */
  6235.  
  6236. Rec_amlc : proc (line, buffer, maxbuffer, bufferlen) returns (fixed bin);
  6237.  
  6238. $Insert *>insert>common.ins.plp
  6239.  
  6240. Dcl (line, maxbuffer, bufferlen) fixed bin,
  6241.     buffer char (max_msg);
  6242.  
  6243. $Insert *>insert>kermit.ins.plp
  6244. $Insert *>insert>primos.ins.plp
  6245. $Insert *>insert>constants.ins.plp
  6246.  
  6247. %Replace max_buff by 256;
  6248.  
  6249. Dcl (idx1, idx2, code) fixed bin,
  6250.     statv (2) fixed bin,
  6251.     (onechar_ptr, get_buff_ptr) ptr,
  6252.     onechar char,
  6253.     getbuffer char (max_buff),
  6254.     (tempbuffer, tempbuff2, getbuff2) char (max_buff) var;
  6255.  
  6256. /* ************************************************************************* */
  6257.  
  6258.    code = 0;
  6259.    onechar_ptr = addr (onechar);
  6260.    get_buff_ptr = addr (getbuffer);
  6261.    tempbuffer = saved_amlc_chrs;
  6262.    tempbuff2 = set8str (tempbuffer);
  6263.    saved_amlc_chrs = '';
  6264.  
  6265.    do while (index (tempbuff2, lf_8bit_asc) = 0 &
  6266.              index (tempbuff2, cr_8bit_asc) = 0 &
  6267.              length (tempbuffer) < maxbuffer & code = 0);
  6268.  
  6269.       call t$amlc (line, onechar_ptr, 1, 1, statv, 1, code);
  6270.       if code = 0 then
  6271.          do;
  6272.             tempbuffer = tempbuffer || onechar;
  6273.             tempbuff2 = set8 (onechar);
  6274.             call t$amlc (line, get_buff_ptr, maxbuffer - length (tempbuffer) -1,
  6275.                          6, statv, 1, code);
  6276.             if statv(1) > 0 & code = 0 then
  6277.                do;
  6278.                   getbuff2 = substr (getbuffer, 1, statv(1));
  6279.                   tempbuffer = tempbuffer || getbuff2;
  6280.                   tempbuff2 = tempbuff2 || set8str (getbuff2);
  6281.                end;
  6282.          end;
  6283.    end;
  6284.  
  6285.    if code ^= 0 then
  6286.       do;
  6287.          bufferlen = 1;
  6288.          substr (buffer, 1, 1) = nul_7bit_asc;
  6289.          return (code);
  6290.       end;
  6291.  
  6292.    tempbuff2 = set8str (tempbuffer);
  6293.    idx1 = index (tempbuff2, lf_8bit_asc);
  6294.    idx2 = index (tempbuff2, cr_8bit_asc);
  6295.  
  6296.    if idx2 = 0 | (idx1 < idx2 & idx1 ^= 0) then
  6297.       idx2 = idx1;
  6298.  
  6299.    if idx2 > maxbuffer | idx2 = 0 then
  6300.       idx2 = maxbuffer;
  6301.  
  6302.    if idx2 ^= 0 & idx2 < length (tempbuffer) then
  6303.       saved_amlc_chrs = substr (tempbuffer, idx2 + 1, length (tempbuffer)-idx2);
  6304.  
  6305.    buffer = substr (tempbuffer, 1, idx2);
  6306.    bufferlen = idx2;
  6307.  
  6308.    return (code);
  6309.  
  6310.    end;      /* Rec_amlc */
  6311. -------------------------------------------------------------------------------
  6312.  
  6313. /* REC_PACKET -- Receive a packet from remote Kermit. */
  6314.  
  6315. Rec_packet : proc;
  6316.  
  6317. $Insert *>insert>common.ins.plp
  6318. $Insert *>insert>kermit.ins.plp
  6319. $Insert *>insert>primos.ins.plp
  6320. $Insert *>insert>constants.ins.plp
  6321.  
  6322. Dcl (code, rec_msg_len, nchr) fixed bin,
  6323.     chr char (1),
  6324.     line char (max_msg) var;
  6325.  
  6326. /* ************************************************************************* */
  6327.  
  6328.    code = 0;
  6329.    timeout = bad_return;        /* Local label used for Timeout condition. */
  6330.  
  6331.    call limit$ ('0702'b4, (rem_timeout), 0, nchr);
  6332.  
  6333.    do until (chr = ctrl_a_8bit_asc);
  6334.       if use_amlc_line then
  6335.          code = rec_amlc (amlc_line, chr, 1, nchr);
  6336.       else
  6337.          do;
  6338.             call c1in (char2);
  6339.             chr = char2(2);
  6340.          end;
  6341.  
  6342.       chr = set8 (chr);
  6343.    end;
  6344.  
  6345.    call limit$ ('0702'b4, 0, 0, nchr);         /* Turn off the timer. */
  6346.  
  6347.    call get_line;                     /* Get the rest of the message. */
  6348.  
  6349.    if code ^= 0 then           /* This MAY have been set in GET_LINE. */
  6350.       do;
  6351.          rec_pkt_type = '1';   /* This will force an error condition */
  6352.          return;               /* to halt the transfer. */
  6353.       end;
  6354.  
  6355.    rec_msg_len = length (rec_msg);
  6356.    if rec_msg_len < pkt_msg then   /* Check that the packet length is valid. */
  6357.       do;
  6358.          rec_pkt_type = msg_check_err;
  6359.  
  6360.          if packet_log_opened then
  6361.             do;
  6362.                call log_info (packet_log, 'Packet length of ' ||
  6363.                               trim (char (rec_msg_len), '11'b) ||
  6364.                               ' is too short.');
  6365.  
  6366.                if rec_msg_len <= 1 then
  6367.                   line = '';
  6368.                else
  6369.                   line = substr (rec_msg, 2);
  6370.  
  6371.                call log_packet (rec_pkt_type, 0, line);
  6372.             end;
  6373.  
  6374.          return;
  6375.  
  6376.       end;
  6377.  
  6378.    /* Now extract the fields from the packet. */
  6379.  
  6380.    rec_pkt_type = set8 (substr (rec_msg, pkt_type, 1));
  6381.    rec_length = knum (substr (rec_msg, pkt_count, 1)) + 2;
  6382.    rec_seq = knum (substr (rec_msg, pkt_seq, 1));
  6383.  
  6384.    /* Check that the packet length is correct. */
  6385.  
  6386.    if rec_msg_len ^= rec_length then
  6387.       do;
  6388.          rec_pkt_type = msg_check_err;
  6389.  
  6390.          if packet_log_opened then
  6391.             do;
  6392.                call log_info (packet_log, 'Packet length byte (' ||
  6393.                               trim (char (rec_length - 2), '11'b) ||
  6394.                               ') is not equal to packet size (' ||
  6395.                               trim (char (rec_msg_len - 2), '11'b) || ').');
  6396.  
  6397.                if rec_msg_len <= 1 then
  6398.                   line = '';
  6399.                else
  6400.                   line = substr (rec_msg, 2);
  6401.  
  6402.                call log_packet (rec_pkt_type, 0, line);
  6403.             end;
  6404.  
  6405.          return;
  6406.  
  6407.       end;
  6408.  
  6409.    if ^check_checksum () then         /* Check the checksum. */
  6410.       if packet_log_opened then
  6411.          do;
  6412.             if rec_msg_len <= 1 then
  6413.                line = '';
  6414.             else
  6415.                line = substr (rec_msg, 2);
  6416.  
  6417.             call log_packet (rec_pkt_type, 0, line);
  6418.          end;
  6419.       else
  6420.          ;
  6421.    else                     /* A good return. */
  6422.       if packet_log_opened then
  6423.          do;
  6424.             if rec_msg_len <= pkt_msg then
  6425.                line = '';
  6426.             else
  6427.                line = substr (rec_msg, pkt_msg, rec_msg_len - pkt_msg);
  6428.  
  6429.             call log_packet (rec_pkt_type, rec_seq, line);
  6430.          end;
  6431.  
  6432.    return;
  6433.  
  6434. Bad_return :    /* If we get here then the Timeout condition has been raised. */
  6435.  
  6436.    rec_pkt_type = msg_timeout;
  6437.    call log_packet (rec_pkt_type, 0, '');
  6438.  
  6439.    return;
  6440.  
  6441. /* ******************************* Get_line ******************************** */
  6442.  
  6443. Get_line : proc;
  6444.  
  6445. Dcl rec_msg_buffer char (max_msg),
  6446.     last_char char (1),
  6447.     buflen fixed bin;
  6448.  
  6449. /* ************************************************************************* */
  6450.  
  6451.    if use_amlc_line then
  6452.       do;
  6453.          code = rec_amlc (amlc_line, rec_msg_buffer, max_msg_less1, buflen);
  6454.          if code ^= 0 then
  6455.             return;
  6456.       end;
  6457.    else
  6458.       call cnin$ (rec_msg_buffer, max_msg_less1, buflen);
  6459.  
  6460.    last_char = clr8 (substr (rec_msg_buffer, buflen, 1));
  6461.  
  6462.    if last_char = cr_7bit_asc | last_char = lf_7bit_asc then
  6463.       buflen = buflen - 1;
  6464.  
  6465.    rec_msg = ctrl_a_8bit_asc || substr (rec_msg_buffer, 1, buflen);
  6466.  
  6467.    return;
  6468.  
  6469.    end;         /* Get_line */
  6470.  
  6471. /* ***************************** Check_checksum **************************** */
  6472.  
  6473. Check_checksum : proc returns (bit (1) aligned);
  6474.  
  6475. Dcl (chksum, chksum7, chksum8, key, rec_len, rec_pkt_chksum) fixed bin;
  6476.  
  6477. /* ************************************************************************* */
  6478.  
  6479.    rec_len = rec_length - 1;
  6480.    rec_pkt_chksum = knum (substr (rec_msg, rec_length, 1));
  6481.  
  6482.    if auto_sum then      /* If checksum type is undetermined, then try both. */
  6483.       do;
  6484.          chksum7 = chks (0, substr (rec_msg, 1, rec_len));
  6485.          chksum8 = chks (1, substr (rec_msg, 1, rec_len));
  6486.  
  6487.          if (chksum7 ^= rec_pkt_chksum) & (chksum8 ^= rec_pkt_chksum) then
  6488.             do;
  6489.                rec_pkt_type = msg_check_err;
  6490.                call log_info (packet_log, 'Checksum error : wanted '||
  6491.                               trim (char (chksum7), '11'b) || ' or ' ||
  6492.                               trim (char (chksum8), '11'b) ||', but got ' ||
  6493.                               trim (char (rec_pkt_chksum), '11'b) || '.');
  6494.                return (false);
  6495.             end;
  6496.  
  6497.          /* Determine checksum type if undetermined. */
  6498.  
  6499.          if chksum7 ^= chksum8 then
  6500.             do;
  6501.                auto_sum = false;
  6502.                do_8bit_chks = (chksum8 = rec_pkt_chksum);
  6503.                if do_8bit_chks then
  6504.                   call log_info (packet_log, 'Doing 8 bit checksums.');
  6505.                else
  6506.                   call log_info (packet_log, 'Doing 7 bit checksums.');
  6507.             end;
  6508.  
  6509.       end;
  6510.    else
  6511.       do;                 /* Checksum type already determined. */
  6512.          if do_8bit_chks then
  6513.             key = 1;
  6514.          else
  6515.             key = 0;
  6516.  
  6517.          chksum = chks (key, substr (rec_msg, 1, rec_len));
  6518.  
  6519.          if chksum ^= rec_pkt_chksum then
  6520.             do;
  6521.                rec_pkt_type = msg_check_err;
  6522.                char2(1) = nul_7bit_asc;
  6523.                char2(2) = substr (rec_msg, rec_length, 1);
  6524.                rec_pkt_chksum = char2_ptr -> fb15_based - 32;
  6525.                call log_info (packet_log, 'Checksum error : wanted ' ||
  6526.                               trim (char (chksum), '11'b) || ', but got ' ||
  6527.                               trim (char (rec_pkt_chksum), '11'b) || '.');
  6528.                return (false);
  6529.             end;
  6530.       end;
  6531.  
  6532.    return (true);
  6533.  
  6534.    end;          /* Check_checksum */
  6535.  
  6536.    end;        /* Rec_packet */
  6537. -------------------------------------------------------------------------------
  6538.  
  6539. /* REC_SWITCH -- Handle Kermit file receive protocol. */
  6540.  
  6541. Rec_switch : proc;
  6542.  
  6543. $Insert *>insert>common.ins.plp
  6544. $Insert *>insert>kermit.ins.plp
  6545. $Insert *>insert>primos.ins.plp
  6546. $Insert *>insert>constants.ins.plp
  6547. $Insert syscom>errd.ins.pl1
  6548.  
  6549. Dcl (temp, i, fs_attr_type, rep_count, eof_rec_seq) fixed bin,
  6550.     new_path char (128) var,
  6551.     chr char (1),
  6552.     (single_file_rec, test_flag, discard) bit (1) aligned;
  6553.  
  6554. /* ************************************************************************* */
  6555.  
  6556.    do_flush = true;
  6557.    discard = false;
  6558.    num_retries = 0;          /* Initialize the number of retries. */
  6559.    eof_rec_seq = -1;
  6560.    single_file_rec = (length (path_name) ^= 0);
  6561.  
  6562.    if packet_log_opened then
  6563.       do;
  6564.          if single_file_rec then
  6565.             errmsg = space_8bit_asc || path_name;
  6566.          else
  6567.             errmsg = '';
  6568.  
  6569.          call log_info (packet_log, '');
  6570.          call log_info (packet_log, kversion || ' receiving' || errmsg || '.');
  6571.       end;
  6572.  
  6573.    do while (true);
  6574.  
  6575.       select (state);
  6576.  
  6577.          when (state_r)
  6578.             state = rec_init ();
  6579.  
  6580.          when (state_rf)
  6581.             state = rec_file ();
  6582.  
  6583.          when (state_ra)
  6584.             state = rec_attrib ();
  6585.  
  6586.          when (state_rdw)
  6587.             state = rec_windowing ();
  6588.  
  6589.          when (state_c)
  6590.             do;
  6591.                call sleep$ (3000);
  6592.                return;
  6593.             end;
  6594.  
  6595.          otherwise                    /* This includes state_a. */
  6596.             do;
  6597.                do_flush = true;
  6598.                call discard_output (i);
  6599.                if i ^= 0 then
  6600.                   do;
  6601.                      call get_error_msg (i);
  6602.                      snd_msg = 'Error trying to discard the output file. ' ||
  6603.                                errmsg;
  6604.                      call send_packet (msg_error, length (snd_msg), msg_number);
  6605.                   end;
  6606.  
  6607.                call sleep$ (3000);
  6608.                return;
  6609.             end;
  6610.  
  6611.       end;     /* select */
  6612.  
  6613.    end;     /* do while ... */
  6614.  
  6615. /* ******************************** Rec_init ******************************* */
  6616.  
  6617. Rec_init : proc returns (fixed bin);
  6618.  
  6619. /* ************************************************************************* */
  6620.  
  6621.    msg_number = 0;               /* Initialize sequence numbering. */
  6622.  
  6623.    if ^rec_message () then       /* Get a packet. */
  6624.       return (state_a);
  6625.  
  6626.    if rec_pkt_type = msg_snd_init then
  6627.       do;
  6628.          call ack_send_init;
  6629.          num_retries = 0;
  6630.          msg_number = mod (msg_number + 1, 64);
  6631.          return (state_rf);         /* Ready to receive file info. */
  6632.       end;
  6633.    else
  6634.       do;
  6635.          call send_packet (msg_nak, 0, rec_seq);
  6636.          return (state_a);
  6637.       end;
  6638.  
  6639.    end;      /* Rec_init */
  6640.  
  6641. /* ******************************* Rec_file ******************************** */
  6642.  
  6643. Rec_file : proc returns (fixed bin);
  6644.  
  6645. /* ************************************************************************* */
  6646.  
  6647.    if ^rec_message () then             /* Get a packet. */
  6648.       return (state_a);
  6649.  
  6650.    discard = false;                    /* Initialise these just in case. */
  6651.    eof_rec_seq = -1;
  6652.  
  6653.    do i = 0 to 63;
  6654.       msg_table.slot(i).acked = false;
  6655.       msg_table.slot(i).retries = 0;
  6656.    end;
  6657.  
  6658.    select (rec_pkt_type);
  6659.  
  6660.       when (msg_file)
  6661.          do;
  6662.             if rec_seq ^= msg_number then
  6663.                do;
  6664.                   snd_msg = 'Protocol error detected.';
  6665.                   call send_packet (msg_error, length (snd_msg), msg_number);
  6666.                   return (state_a);
  6667.                end;
  6668.  
  6669.             if length (path_name) = 0 then  /* Get pathname from the packet. */
  6670.                do;
  6671.                   if single_file_rec then
  6672.                      do;
  6673.                         snd_msg = 'Error : only ONE file upload allowed.';
  6674.                         call send_packet (msg_error, length (snd_msg),
  6675.                                           msg_number);
  6676.                         return (state_a);
  6677.                      end;
  6678.  
  6679.                   path_name = substr (rec_msg, pkt_msg, length (rec_msg) -
  6680.                                                         pkt_msg);
  6681.                   path_name = trim (set8str (path_name), '11'b);
  6682.  
  6683.                   /* The pathname may have repeat character processing in it,
  6684.                      so we must handle this. 8-bit quoting and control quoting
  6685.                      are not allowed in path names, and so will be caught
  6686.                      later on. */
  6687.  
  6688.                   if do_repeats then
  6689.                      if index (path_name, loc_rep_chr) ^= 0 then
  6690.                         do;
  6691.                            new_path = '';
  6692.  
  6693.                            do i = 1 to length (path_name);
  6694.                               chr = substr (path_name, i, 1);
  6695.  
  6696.                               if chr = loc_rep_chr then
  6697.                                  do;
  6698.                                     i = i + 1;
  6699.                                     rep_count = knum (substr (path_name, i, 1));
  6700.  
  6701.                                     i = i + 1;
  6702.                                     chr = substr (path_name, i, 1);
  6703.                                  end;
  6704.                               else
  6705.                                  rep_count = 1;
  6706.  
  6707.                               do temp = 1 to rep_count;
  6708.                                  new_path = new_path || chr;
  6709.                               end;
  6710.  
  6711.                            end;
  6712.  
  6713.                            path_name = new_path;
  6714.  
  6715.                         end;
  6716.  
  6717.                   call set_path (path_name);
  6718.  
  6719.                end;
  6720.  
  6721.             i = open_output ();      /* Open the file for writing. */
  6722.  
  6723.             select (i);
  6724.  
  6725.                when (0)
  6726.                   snd_msg = '';
  6727.  
  6728.                when (e$exst)
  6729.                   do;            /* Acknowldege with our new file name. */
  6730.                      snd_msg = file_name;
  6731.                      call log_info (packet_log,
  6732.                   'File already exists. New file name is ' || file_name || '.');
  6733.                   end;
  6734.  
  6735.                when (e$bnam)
  6736.                   do;
  6737.                      snd_msg = file_name;
  6738.                      call log_info (packet_log, 'The file name is illegal, ' ||
  6739.                                     file_name || ' will be used instead.');
  6740.                   end;
  6741.  
  6742.                when (e$ialn)
  6743.                   do;
  6744.                      snd_msg =
  6745.                      'File already exists. Unable to generate a new file name!';
  6746.                      call send_packet (msg_error, length (snd_msg), msg_number);
  6747.                      return (state_a);
  6748.                   end;
  6749.  
  6750.                otherwise
  6751.                   do;
  6752.                      call get_error_msg (i);
  6753.                      snd_msg = 'Error opening file on remote system. ' ||
  6754.                                errmsg;
  6755.                      call send_packet (msg_error, length (snd_msg), msg_number);
  6756.                      return (state_a);
  6757.                   end;
  6758.             end;
  6759.  
  6760.             if explicit_ft_set then
  6761.                do;
  6762.                   rec_file_type = file_type;
  6763.  
  6764.                   if packet_log_opened then
  6765.                      do;
  6766.                         errmsg =
  6767.                           'The receiving file type has been explicitly set to ';
  6768.  
  6769.                         select (file_type);
  6770.  
  6771.                            when (ascii_ft)
  6772.                               errmsg = errmsg || 'ASCII.';
  6773.  
  6774.                            when (binary_ft)
  6775.                               errmsg = errmsg || 'BINARY.';
  6776.  
  6777.                            when (automatic_ft)      /* ? - This can't be! */
  6778.                               errmsg = errmsg || 'AUTOMATIC.';
  6779.  
  6780.                            otherwise                /* And what's this ? */
  6781.                               errmsg = errmsg || 'ILLEGAL.';
  6782.  
  6783.                         end;
  6784.  
  6785.                         call log_info (packet_log, (errmsg));
  6786.                      end;
  6787.                end;
  6788.             else
  6789.                do;
  6790.                   rec_file_type = automatic_ft;
  6791.                   file_type = ascii_ft;       /* Assume this to start with. */
  6792.  
  6793.                   if packet_log_opened then
  6794.                      do;
  6795.                         call log_info (packet_log,
  6796.                      'The receiving file type will be automatically detected.');
  6797.                         call log_info (packet_log,
  6798.                               'But ASCII file type will initially be assumed.');
  6799.                      end;
  6800.                end;
  6801.  
  6802.             /* Acknowledge the file header packet. */
  6803.  
  6804.             num_retries = 0;
  6805.             do_flush = false;
  6806.             msg_number = mod (msg_number + 1, 64);
  6807.             call send_packet (msg_ack, length (snd_msg), rec_seq);
  6808.  
  6809.             if loc_file_attrib then    /* Get the file attributes if we can. */
  6810.                return (state_ra);
  6811.             else
  6812.                do;
  6813.                   tab_first = msg_number;
  6814.                   return (state_rdw);
  6815.                end;
  6816.          end;
  6817.  
  6818.       when (msg_eof, msg_snd_init)
  6819.          if rec_seq = mod (msg_number - 1, 64) then
  6820.             do;
  6821.                if bump_retry () then
  6822.                   if rec_pkt_type = msg_eof then
  6823.                      call send_packet (msg_ack, 0, rec_seq);
  6824.                   else
  6825.                      call ack_send_init;
  6826.  
  6827.                return (state);
  6828.             end;
  6829.          else
  6830.             do;
  6831.                snd_msg = 'Protocol error detected.';
  6832.                call send_packet (msg_error, length (snd_msg), msg_number);
  6833.                return (state_a);
  6834.             end;
  6835.  
  6836.       when (msg_break)
  6837.          do;
  6838.             call send_packet (msg_ack, 0, rec_seq);
  6839.             return (state_c);
  6840.          end;
  6841.  
  6842.       when (msg_error)
  6843.          return (state_a);
  6844.  
  6845.       otherwise
  6846.          do;
  6847.             snd_msg = 'Unexpected packet type "' || rec_pkt_type ||
  6848.                       '" received on remote system.';
  6849.             call send_packet (msg_error, length (snd_msg), msg_number);
  6850.             return (state_a);
  6851.          end;
  6852.  
  6853.    end;      /* Select */
  6854.  
  6855.    end;    /* Rec_file */
  6856.  
  6857. /* ****************************** Rec_attrib ******************************* */
  6858.  
  6859. Rec_attrib : proc returns (fixed bin);
  6860.  
  6861. Dcl avail_disk_space fixed bin (31),
  6862.     code fixed bin,
  6863.     1 quota_info,
  6864.       2 (record_size, dir_used, max_quota, quota_used) fixed bin (31),
  6865.       2 (duff1, duff2, duff3, duff4) fixed bin (31),
  6866.     inf_array (8) fixed bin (31) based;
  6867.  
  6868. /* ************************************************************************* */
  6869.  
  6870.    if ^rec_message () then                 /* Get a packet. */
  6871.       return (state_a);
  6872.  
  6873.    select (rec_pkt_type);
  6874.  
  6875.       when (msg_attrib)
  6876.          do;
  6877.             call q$read (dir_name, addr (quota_info) -> inf_array, 4, temp,
  6878.                          code);
  6879.             if code ^= 0 | temp = 1 then
  6880.                avail_disk_space = -1;
  6881.             else
  6882.                do;
  6883.                   avail_disk_space = quota_info.max_quota -
  6884.                                      quota_info.quota_used;
  6885.                   if quota_info.record_size ^= 1024 then
  6886.                      avail_disk_space = divide ((avail_disk_space *
  6887.                                      quota_info.record_size) + 1023, 1024, 31);
  6888.                end;
  6889.  
  6890.             call decode_attrs;
  6891.  
  6892.             if avail_disk_space = -1 | rec_file_size <= 0 | rec_file_size <=
  6893.                                                           avail_disk_space then
  6894.                snd_msg = 'Y';
  6895.             else               /* ONLY reject the file if we run out of room. */
  6896.                do;
  6897.                   call discard_output (temp);
  6898.  
  6899.                   if fs_attr_type = 0 then
  6900.                      snd_msg = 'N!';
  6901.                   else
  6902.                      snd_msg = 'N1';
  6903.                end;
  6904.  
  6905.             if rec_file_dtc = 0 then
  6906.                snd_msg = snd_msg || '#';
  6907.  
  6908.             if file_type = illegal_ft then
  6909.                do;
  6910.                   rec_file_type = automatic_ft;
  6911.                   file_type = ascii_ft;       /* Reset this, but let the */
  6912.                   snd_msg = snd_msg || '"';   /* other side know. */
  6913.                end;
  6914.  
  6915.             num_retries = 0;
  6916.             msg_number = mod (msg_number + 1, 64);
  6917.             call send_packet (msg_ack, length (snd_msg), rec_seq);
  6918.  
  6919.             if substr (snd_msg, 1, 1) = 'N' then
  6920.                call log_info (packet_log, 'Unable to receive the file ' ||
  6921.                                           file_name || '. File too big.');
  6922.             return (state);
  6923.          end;
  6924.  
  6925.       when (msg_data)
  6926.          do;
  6927.             if rec_seq ^= msg_number then    /* Out of sequence messages. */
  6928.                if rec_seq = mod (msg_number - 1, 64) then
  6929.                   do;
  6930.                      if bump_retry () then
  6931.                         call send_packet (msg_ack, 0, rec_seq);
  6932.                      return (state);
  6933.                   end;
  6934.                else
  6935.                   do;
  6936.                      snd_msg = 'Protocol error detected.';
  6937.                      call send_packet (msg_error, length (snd_msg), msg_number);
  6938.                      return (state_a);
  6939.                   end;
  6940.  
  6941.             temp = write_output ();
  6942.             if temp ^= 0 then
  6943.                do;
  6944.                   call get_error_msg (temp);
  6945.                   snd_msg = 'Unable to write to output file. ' || errmsg;
  6946.                   call send_packet (msg_error, length (snd_msg), msg_number);
  6947.                   return (state_a);
  6948.                end;
  6949.  
  6950.             num_retries = 0;
  6951.             msg_number = mod (msg_number + 1, 64);
  6952.             call send_packet (msg_ack, 0, rec_seq);
  6953.  
  6954.             tab_first = msg_number;
  6955.  
  6956.             return (state_rdw);
  6957.          end;
  6958.  
  6959.       when (msg_file)
  6960.          if rec_seq = mod (msg_number - 1, 64) then
  6961.             do;
  6962.                if bump_retry () then
  6963.                   call send_packet (msg_ack, 0, rec_seq);
  6964.                return (state);
  6965.             end;
  6966.          else
  6967.             do;
  6968.                snd_msg = 'Protocol error detected.';
  6969.                call send_packet (msg_error, length (snd_msg), msg_number);
  6970.                return (state_a);
  6971.             end;
  6972.  
  6973.       when (msg_eof)
  6974.          if rec_seq = msg_number then
  6975.             do;
  6976.                i = close_output ();
  6977.                call set_path ('');    /* Knock out the file_name for later. */
  6978.                if i ^= 0 then
  6979.                   do;
  6980.                      call get_error_msg (i);
  6981.                      snd_msg = 'Unable to close output file on remote system. '
  6982.                                || errmsg;
  6983.                      call send_packet (msg_error, length (snd_msg), msg_number);
  6984.                      return (state_a);
  6985.                   end;
  6986.  
  6987.                num_retries = 0;
  6988.                msg_number = mod (msg_number + 1, 64);
  6989.                call send_packet (msg_ack, 0, rec_seq);
  6990.  
  6991.                return (state_rf);
  6992.             end;
  6993.          else
  6994.             do;
  6995.                snd_msg = 'Protocol error detected.';
  6996.                call send_packet (msg_error, length (snd_msg), msg_number);
  6997.                return (state_a);
  6998.             end;
  6999.  
  7000.       when (msg_error)
  7001.          return (state_a);
  7002.  
  7003.       otherwise
  7004.          do;
  7005.             snd_msg = 'Unexpected packet type "' || rec_pkt_type ||
  7006.                       '" received on remote system.';
  7007.             call send_packet (msg_error, length (snd_msg), msg_number);
  7008.             return (state_a);
  7009.          end;
  7010.  
  7011.    end;         /* select */
  7012.  
  7013.    end;     /* Rec_attrib */
  7014.  
  7015. /* ***************************** Rec_windowing ***************************** */
  7016.  
  7017. Rec_windowing : proc returns (fixed bin);
  7018.  
  7019. /* ************************************************************************* */
  7020.  
  7021.    call rec_packet;             /* Get input. */
  7022.  
  7023.    select (rec_pkt_type);
  7024.  
  7025.       when (msg_data)
  7026.          do;
  7027.             call update_table;
  7028.             if tab_first = eof_rec_seq then
  7029.                do;
  7030.                   rec_seq = eof_rec_seq;
  7031.                   goto eof;
  7032.                end;
  7033.             else
  7034.                return (state);
  7035.          end;
  7036.  
  7037.       when (msg_eof)
  7038.          do;
  7039.             eof_rec_seq = rec_seq;
  7040.  
  7041.             if length (rec_msg) > pkt_msg then
  7042.                rec_msg = substr (rec_msg, pkt_msg, 1);
  7043.             else
  7044.                rec_msg = '';
  7045.  
  7046.             discard = (rec_msg = 'D');
  7047.  
  7048.             if discard then
  7049.                call discard_output (i);
  7050.             else
  7051.                do;
  7052.                   if tab_first ^= eof_rec_seq then
  7053.                      do;
  7054.                         call nak_all;
  7055.                         return (state);
  7056.                      end;
  7057. Eof :
  7058.                   i = close_output ();
  7059.                end;
  7060.  
  7061.             do_flush = true;                /* Okay, we can do this now, */
  7062.             call set_path ('');             /* and do this for later. */
  7063.  
  7064.             if i ^= 0 then
  7065.                do;
  7066.                   call get_error_msg (i);
  7067.                   if discard then
  7068.                      snd_msg =
  7069.                           'Unable to discard the output file on remote system. '
  7070.                           || errmsg;
  7071.                   else
  7072.                      snd_msg = 'Unable to close output file on remote system. '
  7073.                                || errmsg;
  7074.                   call send_packet (msg_error, length (snd_msg), msg_number);
  7075.                   return (state_a);
  7076.                end;
  7077.  
  7078.             num_retries = 0;
  7079.             msg_number = mod (rec_seq + 1, 64);
  7080.             call send_packet (msg_ack, 0, rec_seq);
  7081.  
  7082.             return (state_rf);
  7083.  
  7084.          end;
  7085.  
  7086.       when (msg_error)
  7087.          return (state_a);
  7088.  
  7089.       when (msg_timeout)
  7090.          do;
  7091.             if bump_retry () then
  7092.                do;
  7093.                   num_retries = num_retries - 1;   /* Don't increase this. */
  7094.                   call log_info (packet_log,
  7095.                                       'Timeout : NAK for most desired packet.');
  7096.                   call nak_oldest (true);
  7097.                end;
  7098.  
  7099.             return (state);
  7100.          end;
  7101.  
  7102.       when (msg_check_err)
  7103.          do;
  7104.             if bump_retry () then
  7105.                do;
  7106.                   num_retries = num_retries - 1;   /* Don't increase this. */
  7107.                   call log_info (packet_log,
  7108.                             'Checksum error : NAK for oldest unACKed packet.');
  7109.                   call nak_oldest (false);
  7110.                end;
  7111.  
  7112.             return (state);
  7113.          end;
  7114.  
  7115.       otherwise
  7116.          do;
  7117.             snd_msg = 'Unexpected packet type "' || rec_pkt_type ||
  7118.                       '" received on remote system.';
  7119.             call send_packet (msg_error, length (snd_msg), msg_number);
  7120.             return (state_a);
  7121.          end;
  7122.  
  7123.    end;      /* Select */
  7124.  
  7125.    end;   /* Rec_windowing */
  7126.  
  7127. /* ****************************** Rec_message ****************************** */
  7128.  
  7129. Rec_message : proc returns (bit (1) aligned);
  7130.  
  7131. /* ************************************************************************* */
  7132.  
  7133.    test_flag = false;
  7134.  
  7135.    do until (test_flag);
  7136.  
  7137.       call rec_packet;
  7138.  
  7139.       if rec_pkt_type = msg_timeout | rec_pkt_type = msg_check_err then
  7140.          if bump_retry () then
  7141.             call send_packet (msg_nak, 0, msg_number);
  7142.          else
  7143.             return (false);
  7144.       else
  7145.          test_flag = true;
  7146.    end;
  7147.  
  7148.    return (true);
  7149.  
  7150.    end;       /* Rec_message */
  7151.  
  7152. /* ***************************** Update_table ****************************** */
  7153.  
  7154. Update_table : proc;
  7155.  
  7156. /* ************************************************************************* */
  7157.  
  7158.    if ^between (rec_seq, tab_first, mod (tab_first + window_size - 1, 64)) then
  7159.       do;
  7160.          if between (rec_seq, mod (tab_first - window_size, 64),
  7161.                               mod (tab_first - 1, 64)) then
  7162.             call send_packet (msg_ack, 0, rec_seq);
  7163.  
  7164.          return;
  7165.       end;
  7166.  
  7167.    /* Add the new data packet to the table. */
  7168.  
  7169.    if rec_seq ^= eof_rec_seq then     /* Don't mark the EOF packet as ACKed. */
  7170.       do;
  7171.          msg_table.slot(rec_seq).msg = rec_msg;
  7172.          msg_table.slot(rec_seq).acked = true;
  7173.       end;
  7174.  
  7175.    if msg_table.slot(tab_first).acked then
  7176.       do;
  7177.          i = tab_first;
  7178.  
  7179.          do until (^msg_table.slot(i).acked);
  7180.             rec_msg = msg_table.slot(i).msg;
  7181.  
  7182.             temp = write_output ();
  7183.             if temp ^= 0 then
  7184.                do;
  7185.                   call get_error_msg (temp);
  7186.                   snd_msg = 'Unable to write to output file. ' || errmsg;
  7187.                   call send_packet (msg_error, length (snd_msg), msg_number);
  7188.                   state = state_a;
  7189.                   return;
  7190.                end;
  7191.             else
  7192.                msg_table.slot(i).acked = false;
  7193.  
  7194.             i = mod (i + 1, 64);
  7195.          end;
  7196.  
  7197.          tab_first = i;
  7198.       end;
  7199.  
  7200.    num_retries = 0;
  7201.    msg_number = mod (rec_seq + 1, 64);
  7202.  
  7203.    call send_packet (msg_ack, 0, rec_seq);    /* Acknowledge the packet. */
  7204.  
  7205.    return;
  7206.  
  7207.    end;      /* Update_table */
  7208.  
  7209. /* ****************************** Nak_oldest ******************************* */
  7210.  
  7211. Nak_oldest : proc (desire);
  7212.  
  7213. Dcl desire bit (1) aligned;
  7214.  
  7215. /* ************************************************************************* */
  7216.  
  7217.    i = tab_first;
  7218.    temp = mod (tab_first + window_size, 64);
  7219.  
  7220.    do until (i = temp);
  7221.       if ^msg_table.slot(i).acked then
  7222.          do;
  7223.             call send_packet (msg_nak, 0, i);
  7224.             return;
  7225.          end;
  7226.  
  7227.       i = mod (i + 1, 64);
  7228.    end;
  7229.  
  7230.    /* No packets to NAK, so NAK for next in hope of unblocking
  7231.       sender if a NAK for the most desired packet is required. */
  7232.  
  7233.    if desire then
  7234.       call send_packet (msg_nak, 0, temp);
  7235.  
  7236.    return;
  7237.  
  7238.    end;      /* Nak_oldest */
  7239.  
  7240. /* ******************************* Nak_all ********************************* */
  7241.  
  7242. Nak_all : proc;
  7243.  
  7244. /* ************************************************************************* */
  7245.  
  7246.    i = tab_first;
  7247.  
  7248.    do until (i = eof_rec_seq);
  7249.       if ^msg_table.slot(i).acked then
  7250.          call send_packet (msg_nak, 0, i);
  7251.  
  7252.       i = mod (i + 1, 64);
  7253.    end;
  7254.  
  7255.    return;
  7256.  
  7257.    end;       /* Nak_all */
  7258.  
  7259. /* ******************************* Bump_retry ****************************** */
  7260.  
  7261. Bump_retry : proc returns (bit (1) aligned);
  7262.  
  7263. /* ************************************************************************* */
  7264.  
  7265.    if num_retries > max_retries then
  7266.       do;
  7267.          snd_msg = 'Retry limit exceeded on remote system.';
  7268.          call send_packet (msg_error, length (snd_msg), msg_number);
  7269.          state = state_a;
  7270.          return (false);
  7271.       end;
  7272.  
  7273.    num_retries = num_retries + 1;
  7274.  
  7275.    return (true);
  7276.  
  7277.    end;          /* Bump_retry */
  7278.  
  7279. /* ****************************** Decode_attrs ***************************** */
  7280.  
  7281. Decode_attrs : proc;
  7282.  
  7283. Dcl (str, data) char (max_msg) var,
  7284.     attr char (1),
  7285.     (len, found, code) fixed bin;
  7286.  
  7287. /* ************************************************************************* */
  7288.  
  7289.    rec_file_size = -1;    /* -1 = Unknown, 0 = Illegal, > 0 = Legal value. */
  7290.    rec_file_dtc = -1;
  7291.  
  7292.    found = 0;
  7293.    str = substr (rec_msg, pkt_msg, length (rec_msg) - pkt_msg);
  7294.    str = set8str (str);
  7295.  
  7296.    do while (length (str) > 0 & found < 5);
  7297.  
  7298.       attr = substr (str, 1, 1);
  7299.  
  7300.       len = knum (substr (str, 2, 1));
  7301.  
  7302.       data = substr (str, 3, len);
  7303.       str = substr (str, len + 3);
  7304.  
  7305.       select (attr);
  7306.  
  7307.          when ('!')             /* File size in Kbytes. */
  7308.             do;
  7309.                fs_attr_type = 0;
  7310.                rec_file_size = bin (trim (data, '11'b), 31);
  7311.             end;
  7312.  
  7313.          when ('1')             /* File size in bytes. */
  7314.             do;
  7315.                fs_attr_type = 1;
  7316.                rec_file_size = bin (trim (data, '11'b), 31);
  7317.                rec_file_size = divide (rec_file_size + 1023, 1024, 31);
  7318.             end;
  7319.  
  7320.          when ('#')             /* Date/Time file created (DTC). */
  7321.             do;
  7322.                if substr (data, 1, 2) = '19' then
  7323.                   data = substr (data, 3);    /* Knock off the century. */
  7324.  
  7325.                data = substr (data, 1, 2) || '-' || substr (data, 3, 2) ||
  7326.                       '-' || substr (data, 5, 2) || '.' ||
  7327.                       after (data, space_8bit_asc);
  7328.  
  7329.                call cv$dtb (data, rec_file_dtc, code);
  7330.                if code ^= 0 then
  7331.                   rec_file_dtc = 0;
  7332.  
  7333.             end;
  7334.  
  7335.          when ('.')             /* Machine and OS. */
  7336.             if ^explicit_pound_set &
  7337.                (data = 'U8' | substr (data, 1, 1) = 'K') then
  7338.                pound_conversion = true;    /* U8 = MS-DOS, K = Atari. */
  7339.  
  7340.          when ('"')             /* Indication of file type. */
  7341.             if ^explicit_ft_set then     /* Might as well use this if we can. */
  7342.                do;
  7343.                   select (substr (data, 1, 1));
  7344.  
  7345.                      when ('A')
  7346.                         do;
  7347.                            rec_file_type = ascii_ft;    /* ASCII file. */
  7348.                            call log_info (packet_log,
  7349.     'The received file type attribute is ASCII, this file type will be used.');
  7350.                         end;
  7351.  
  7352.                      when ('B')
  7353.                         do;
  7354.                            rec_file_type = binary_ft;   /* BINARY file. */
  7355.                            call log_info (packet_log,
  7356.    'The received file type attribute is BINARY, this file type will be used.');
  7357.                         end;
  7358.  
  7359.                      when ('I')
  7360.                         do;
  7361.                            rec_file_type = binary_ft; /* IMAGE file (BINARY). */
  7362.                            call log_info (packet_log,
  7363.  'The received file type attribute is IMAGE, but BINARY file type will be used.'
  7364.                                           );
  7365.                         end;
  7366.  
  7367.                      otherwise
  7368.                         do;
  7369.                            rec_file_type = illegal_ft;  /* ILLEGAL file type. */
  7370.                            call log_info (packet_log,
  7371.                                'The received file type attribute is ILLEGAL.');
  7372.                            call log_info (packet_log, 'The file type will be '
  7373.                 || 'automatically detected, but ASCII will initially be used.');
  7374.                         end;
  7375.  
  7376.                   end;
  7377.  
  7378.                   file_type = rec_file_type;
  7379.  
  7380.                end;
  7381.  
  7382.          otherwise
  7383.             found = found - 1;        /* Didn't find one we wanted. */
  7384.  
  7385.       end;
  7386.  
  7387.       found = found + 1;        /* Assume that we did find one. */
  7388.  
  7389.    end;
  7390.  
  7391.    return;
  7392.  
  7393.    end;          /* Decode_attrs */
  7394.  
  7395.    end;       /* Rec_switch */
  7396. -------------------------------------------------------------------------------
  7397.  
  7398. /* REN_HNDLR -- On_unit for returning after a PUSH. */
  7399.  
  7400. Ren_hndlr : proc (dummy);
  7401.  
  7402. Dcl dummy ptr;
  7403.  
  7404. $Insert *>insert>common.ins.plp
  7405. $Insert *>insert>kermit.ins.plp
  7406.  
  7407. /* ************************************************************************* */
  7408.  
  7409.    /* We first of all get our users environment variables again, just in
  7410.       case he/she changed them when they were at Primos command level.
  7411.  
  7412.       "ren_lbl" is a label variable which is set to a local label
  7413.       in COMND. This enables us to create the on-unit once at startup
  7414.       yet have it return to a sub-procedure when the condition arises.
  7415.    */
  7416.  
  7417.    call get_user_info;
  7418.  
  7419.    goto ren_lbl;
  7420.  
  7421.    end;       /* Ren_hndlr */
  7422. -------------------------------------------------------------------------------
  7423.  
  7424. /* SEND_AMLC -- Send characters along an asynchronous line. */
  7425.  
  7426. Send_amlc : proc (line, buffer, bufferlen) returns (fixed bin);
  7427.  
  7428. Dcl (line, bufferlen) fixed bin,
  7429.     buffer char (256);
  7430.  
  7431. $Insert *>insert>common.ins.plp
  7432. $Insert *>insert>kermit.ins.plp
  7433. $Insert *>insert>primos.ins.plp
  7434.  
  7435. Dcl code fixed bin,
  7436.     statv (2) fixed bin,
  7437.     tempbuff char (256) var;
  7438.  
  7439. /* ************************************************************************* */
  7440.  
  7441.    if ^do_transparent then
  7442.       do;
  7443.          tempbuff = set8str (substr (buffer, 1, bufferlen));
  7444.          substr (buffer, 1, bufferlen) = substr (tempbuff, 1, bufferlen);
  7445.       end;
  7446.  
  7447.    call t$amlc (line, addr (buffer), bufferlen, 3, statv, 1, code);
  7448.  
  7449.    return (code);
  7450.  
  7451.    end;     /* Send_amlc */
  7452. -------------------------------------------------------------------------------
  7453.  
  7454. /* SEND_PACKET -- Send Kermit packet to user. */
  7455.  
  7456. Send_packet : proc (type, pkt_len, seq_num);
  7457.  
  7458. Dcl type        char (1),    /* Type of packet to send. */
  7459.     pkt_len     fixed bin,   /* Length of packet to send. */
  7460.     seq_num     fixed bin;   /* Sequence number of packet. */
  7461.  
  7462. $Insert *>insert>common.ins.plp
  7463. $Insert *>insert>kermit.ins.plp
  7464. $Insert *>insert>primos.ins.plp
  7465. $Insert *>insert>constants.ins.plp
  7466. $Insert syscom>keys.ins.pl1
  7467.  
  7468. Dcl msg char (max_msg) var,
  7469.     (temp, msg_length, chksum, code) fixed bin,
  7470.     statv (2) fixed bin;
  7471.  
  7472. /* ************************************************************************* */
  7473.  
  7474.    if rem_npad > 0 then          /* Do any packet filling required. */
  7475.       if use_amlc_line then
  7476.          do;
  7477.             code = send_amlc (amlc_line, rem_padchar, rem_npad);
  7478.             if code ^= 0 then
  7479.                call tnou ('Unable to send padding characters.', 34);
  7480.          end;
  7481.       else
  7482.          call tnoua (rem_pad_chars, rem_npad);
  7483.  
  7484.    /* Store the header information into the message. */
  7485.  
  7486.    char2_ptr -> fb15_based = pkt_len + pkt_ovr_head + 32;
  7487.    msg = ctrl_a_8bit_asc || char2(2);
  7488.  
  7489.    char2_ptr -> fb15_based = seq_num + 32;
  7490.    msg = msg || char2(2) || type;
  7491.  
  7492.    if pkt_len > 0 then
  7493.       msg = msg || snd_msg;
  7494.  
  7495.    msg_length = length (msg);
  7496.  
  7497.    if do_transparent then   /* If transparent, then clear all the high bits. */
  7498.       do;
  7499.          if type = msg_data then
  7500.             temp = pkt_type;
  7501.          else
  7502.             temp = msg_length;
  7503.  
  7504.          substr (msg, 1, temp) = clr8str (substr (msg, 1, temp));
  7505.       end;
  7506.  
  7507.    temp = 0;               /* Do the initial checksum calculation. */
  7508.    if do_8bit_chks then
  7509.       temp = 1;
  7510.  
  7511.    chksum = chks (temp, msg);
  7512.  
  7513.    char2_ptr -> fb15_based = chksum + 32;
  7514.    msg = msg || char2(2) || rem_eol;
  7515.  
  7516.    msg_length = msg_length + 2;
  7517.  
  7518.    if do_flush then            /* Flush the input buffer. */
  7519.       if use_amlc_line then
  7520.          do;
  7521.             call t$amlc (amlc_line, addr (temp), 0, 8, statv, 1, code);
  7522.             if code ^= 0 then
  7523.                call tnou ('Unable to flush asynchronous input buffer.', 42);
  7524.          end;
  7525.       else
  7526.          call tty$rs (k$inb, temp);
  7527.  
  7528.    if use_amlc_line then
  7529.       do;
  7530.          code = send_amlc (amlc_line, (msg), msg_length);
  7531.          if code ^= 0 then
  7532.             call tnou ('Unable to send asynchronous data.', 33);
  7533.       end;
  7534.    else
  7535.       call tnoua ((msg), msg_length);           /* Now send the message. */
  7536.  
  7537.    if packet_log_opened then                 /* Log the packet if necessary. */
  7538.       do;
  7539.          if pkt_len > 0 then
  7540.             msg = snd_msg;
  7541.          else
  7542.             msg = '';
  7543.  
  7544.          call log_packet (type, seq_num, msg);
  7545.       end;
  7546.  
  7547.    return;
  7548.  
  7549.    end;         /* Send_packet */
  7550. -------------------------------------------------------------------------------
  7551.  
  7552. /* SEND_SWITCH -- Handles Kermit file send protocol. */
  7553.  
  7554. Send_switch : proc;
  7555.  
  7556. $Insert *>insert>common.ins.plp
  7557. $Insert *>insert>kermit.ins.plp
  7558. $Insert *>insert>primos.ins.plp
  7559. $Insert *>insert>constants.ins.plp
  7560.  
  7561. Dcl (stop_xfer, stop_trans, test_flag) bit (1) aligned,
  7562.     (code, temp) fixed bin;
  7563.  
  7564. /* ************************************************************************* */
  7565.  
  7566.    num_retries = 0;                 /* Initialize number of retries. */
  7567.    msg_number = 0;                  /* Initial message number. */
  7568.    do_flush = true;
  7569.    test_flag = false;
  7570.  
  7571.    if packet_log_opened then
  7572.       do;
  7573.          call log_info (packet_log, '');
  7574.          call log_info (packet_log, kversion || ' sending ' || path_name ||'.');
  7575.       end;
  7576.  
  7577.    if delay ^= 0 then                   /* Sleep if we need to. */
  7578.       call sleep$ (1000 * delay);
  7579.  
  7580.    do until (test_flag);
  7581.  
  7582.       select (state);
  7583.  
  7584.          when (state_s, state_x)
  7585.             state = send_init ();
  7586.  
  7587.          when (state_sf, state_xf)
  7588.             state = send_file ();
  7589.  
  7590.          when (state_sa)
  7591.             state = send_attrib ();
  7592.  
  7593.          when (state_sdw)
  7594.             state = send_windowing ();
  7595.  
  7596.          when (state_sz)
  7597.             state = send_eof ();
  7598.  
  7599.          when (state_sb)
  7600.             state = send_break ();
  7601.  
  7602.          when (state_c)
  7603.             test_flag = true;
  7604.  
  7605.          otherwise               /* Includes state_a. */
  7606.             do;
  7607.               do_flush = true;
  7608.               test_flag = true;
  7609.               if file_opened then
  7610.                  call close_input;
  7611.             end;
  7612.  
  7613.       end;      /* select */
  7614.  
  7615.    end;      /* loop */
  7616.  
  7617.    return;
  7618.  
  7619. /* ****************************** Send_init ******************************** */
  7620.  
  7621. Send_init : proc returns (fixed bin);
  7622.  
  7623. Dcl eol_bin fixed bin,
  7624.     eol char (1);
  7625.  
  7626. /* ************************************************************************* */
  7627.  
  7628.    /* Setup our send_init parameters, and set the printable bit. */
  7629.  
  7630.    char2(1) = nul_7bit_asc;
  7631.    char2(2) = loc_eol;
  7632.    char2_ptr -> fb15_based = char2_ptr -> fb15_based + 32;
  7633.    eol = char2(2);
  7634.  
  7635.    eol_bin = loc_pkt_size + 32;
  7636.    temp = loc_timeout + 32;
  7637.  
  7638.    snd_msg = substr (addr (eol_bin) -> char2_based, 2, 1) ||
  7639.              substr (addr (temp) -> char2_based, 2, 1);
  7640.  
  7641.    eol_bin = loc_npad + 32;
  7642.    temp = loc_capas1 + 32;
  7643.  
  7644.    snd_msg = snd_msg || substr (addr (eol_bin) -> char2_based, 2, 1) ||
  7645.              ctl (loc_padchar) || eol || loc_quote_chr || loc_8quote_chr ||
  7646.              loc_chk_type || loc_rep_chr || substr (addr (temp) -> char2_based,
  7647.                                                     2, 1);
  7648.  
  7649.    temp = loc_max_wsize + 32;
  7650.    snd_msg = snd_msg || substr (addr (temp) -> char2_based, 2, 1);
  7651.  
  7652.    loc_file_attrib = addr (loc_capas1) -> capas.file_attributes;
  7653.  
  7654.    /* Now send the packet. */
  7655.  
  7656.    call send_packet (msg_snd_init, length (snd_msg), msg_number);
  7657.  
  7658.    if ^get_response () then          /* Get a response from the remote side. */
  7659.       return (state);
  7660.  
  7661.    call prs_send_init;           /* Process ACK response. */
  7662.    call set_params;
  7663.  
  7664.    if state = state_x then  /* Text transfer : the file is already open. */
  7665.       return (state_xf);
  7666.  
  7667.    temp = match_file ();
  7668.    if temp ^= 0 then
  7669.       do;
  7670.          call get_error_msg (temp);
  7671.          snd_msg = 'Unable to match files on remote system. ' || errmsg;
  7672.          call send_packet (msg_error, length (snd_msg), msg_number);
  7673.          return (state_a);
  7674.       end;
  7675.  
  7676.    if num_matches = 0 then           /* Check for no matching files. */
  7677.       do;
  7678.          snd_msg = 'No matching files on remote system.';
  7679.          call send_packet (msg_error, length (snd_msg), msg_number);
  7680.          return (state_a);
  7681.       end;
  7682.  
  7683.    file_idx = 1;           /* Send the first file. */
  7684.  
  7685.    return (state_sf);
  7686.  
  7687.    end;             /* Send_init */
  7688.  
  7689. /* ******************************* Send_file ******************************* */
  7690.  
  7691. Send_file : proc returns (fixed bin);
  7692.  
  7693. Dcl test_flag bit (1) aligned,
  7694.     rec_file_name char (32) var;
  7695.  
  7696. /* ************************************************************************* */
  7697.  
  7698.    stop_xfer = false;       /* Initialize the file interrupt flags. */
  7699.    stop_trans = false;
  7700.    test_flag = true;
  7701.    saved_msg = '';          /* Initialize any saved packet characters. */
  7702.    saved_char = '';
  7703.  
  7704.    do temp = 0 to 63;
  7705.       msg_table.slot(temp).acked = false;
  7706.       msg_table.slot(temp).retries = 0;
  7707.    end;
  7708.  
  7709.    if state = state_sf then      /* File transfer : send the file name. */
  7710.       if next_file () ^= ker_normal then
  7711.          return (state_sb);
  7712.       else
  7713.          snd_msg = clr8str (file_name);
  7714.  
  7715.    do while (test_flag);
  7716.  
  7717.       if state = state_sf then
  7718.          call send_packet (msg_file, length (file_name), msg_number);
  7719.       else
  7720.          call send_packet (msg_text, 0, msg_number);
  7721.  
  7722.       if ^get_response () then      /* Get a response from the remote side. */
  7723.          if state = state_a then
  7724.             return (state_a);
  7725.          else
  7726.             ;
  7727.       else
  7728.          test_flag = false;
  7729.    end;
  7730.  
  7731.    if packet_log_opened then        /* See if our file name was acceptable. */
  7732.       if length (trim (rec_msg, '11'b)) > pkt_msg then
  7733.          do;
  7734.             rec_file_name = trim (set8str (substr (rec_msg, pkt_msg,
  7735.                                           length (rec_msg) - pkt_msg)), '11'b);
  7736.             if rec_file_name ^= file_name then
  7737.                call log_info (packet_log, 'The file will be received as ' ||
  7738.                               rec_file_name || '.');
  7739.          end;
  7740.  
  7741.    call setup_trans_char;    /* Setup the character translation table. */
  7742.  
  7743.    tab_first = msg_number;   /* Initialise these just in case. */
  7744.    tab_next = msg_number;
  7745.    do_flush = false;
  7746.  
  7747.    /* If this is a file transfer, and attributes are expected, send them. */
  7748.  
  7749.    if (state = state_sf) & rem_file_attrib then
  7750.       return (state_sa);
  7751.  
  7752.    return (state_sdw);
  7753.  
  7754.    end;         /* Send_file */
  7755.  
  7756. /* ****************************** Send_attrib ****************************** */
  7757.  
  7758. Send_attrib : proc returns (fixed bin);
  7759.  
  7760. Dcl test_flag bit (1) aligned;
  7761.  
  7762. /* ************************************************************************* */
  7763.  
  7764.    test_flag = true;
  7765.  
  7766.    call get_attr;            /* Form the attribute packet. */
  7767.  
  7768.    do while (test_flag);     /* Send the data packet. */
  7769.  
  7770.       call send_packet (msg_attrib, length (snd_msg), msg_number);
  7771.  
  7772.       if ^get_response () then    /* Get a response from the remote side. */
  7773.          if state = state_a then
  7774.             return (state_a);
  7775.          else
  7776.             ;
  7777.       else
  7778.          test_flag = false;
  7779.    end;
  7780.  
  7781.    if length (rec_msg) > pkt_msg then
  7782.       rec_msg = substr (rec_msg, pkt_msg, 1);
  7783.    else
  7784.       rec_msg = '';
  7785.  
  7786.    if rec_msg = 'N' then      /* We cannot send this file for some reason. */
  7787.       do;
  7788.          stop_xfer = true;
  7789.          return (state_sz);
  7790.       end;
  7791.  
  7792.    tab_first = msg_number;   /* Initialise these just in case. */
  7793.    tab_next = msg_number;
  7794.  
  7795.    return (state_sdw);       /* Send the first data packet. */
  7796.  
  7797.    end;     /* Send_attrib */
  7798.  
  7799. /* ***************************** Send_windowing **************************** */
  7800.  
  7801. Send_windowing : proc returns (fixed bin);
  7802.  
  7803. Dcl status fixed bin;
  7804.  
  7805. /* ************************************************************************* */
  7806.  
  7807.    status = read_input (code);   /* Get the next buffer of data. */
  7808.  
  7809.    select (status);
  7810.  
  7811.       when (ker_normal)
  7812.          ;
  7813.  
  7814.       when (ker_eof)
  7815.          if ^prs_input (true) then
  7816.             return (state_a);
  7817.          else
  7818.             return (state_sz);
  7819.  
  7820.       otherwise
  7821.          do;
  7822.             call get_error_msg (code);
  7823.             snd_msg = 'Error reading file on remote system. ' || errmsg;
  7824.             call send_packet (msg_error, length (snd_msg), msg_number);
  7825.             return (state_a);
  7826.          end;
  7827.    end;
  7828.  
  7829.    msg_table.slot(msg_number).msg = snd_msg;       /* Update the table. */
  7830.    msg_table.slot(msg_number).acked = false;
  7831.    msg_table.slot(msg_number).retries = 0;
  7832.  
  7833.    /* Now we can send the packet. */
  7834.  
  7835.    call send_packet (msg_data, length (snd_msg), msg_number);
  7836.  
  7837.    msg_number = mod (msg_number + 1, 64);   /* Increment the message number. */
  7838.    tab_next = msg_number;
  7839.  
  7840.    if ^prs_input (false) then     /* Get a response from the remote side. */
  7841.       return (state_a);
  7842.  
  7843.    if stop_xfer | stop_trans then  /* Check for file transfer interruption. */
  7844.       return (state_sz);
  7845.  
  7846.    return (state_sdw);
  7847.  
  7848.    end;               /* Send_windowing */
  7849.  
  7850. /* ******************************* Send_eof ******************************** */
  7851.  
  7852. Send_eof : proc returns (fixed bin);
  7853.  
  7854. /* ************************************************************************* */
  7855.  
  7856.    do_flush = true;         /* Start flushing input before each output. */
  7857.  
  7858.    call close_input;
  7859.  
  7860.    if stop_xfer | stop_trans then  /* Check for file transfer interruption. */
  7861.       do;
  7862.          call log_info (packet_log, 'File transfer interrupted.');
  7863.  
  7864.          snd_msg = 'D';           /* Discard indication. */
  7865.          call sleep$ (5000); /* Wait 5 secs to allow receiver to flush input. */
  7866.          call send_packet (msg_eof, length (snd_msg), msg_number);
  7867.       end;
  7868.    else         /* A normal EOF : send end-of-file indicator packet. */
  7869.       call send_packet (msg_eof, 0, msg_number);
  7870.  
  7871.    if ^get_response () then       /* Get a response from the remote side. */
  7872.       return (state);
  7873.  
  7874.    if stop_trans then
  7875.       return (state_sb);
  7876.  
  7877.    return (state_sf);
  7878.  
  7879.    end;           /* Send_eof */
  7880.  
  7881. /* ******************************* Send_break ****************************** */
  7882.  
  7883. Send_break : proc returns (fixed bin);
  7884.  
  7885. /* ************************************************************************* */
  7886.  
  7887.    /* First send end-of-file-set indicator packet. */
  7888.  
  7889.    call send_packet (msg_break, 0, msg_number);
  7890.  
  7891.    if ^get_response () then    /* Get a response from the remote side. */
  7892.       return (state);
  7893.  
  7894.    return (state_c);
  7895.  
  7896.    end;            /* Send_break */
  7897.  
  7898. /* ******************************* Prs_input ******************************* */
  7899.  
  7900. Prs_input : proc (eof) returns (bit (1) aligned);
  7901.  
  7902. Dcl eof bit (1) aligned;
  7903.  
  7904. Dcl i fixed bin;
  7905.  
  7906. /* ************************************************************************* */
  7907.  
  7908. Get_pkt :
  7909.  
  7910.    if eof then   /* Wait for a packet until all are acknowledged. */
  7911.       if tab_first = tab_next then
  7912.          return (true);
  7913.       else
  7914.          goto rec_pkt;
  7915.  
  7916.    /* If the window is not blocked, make sure there is input. */
  7917.  
  7918.    if tab_next ^= mod (tab_first + window_size, 64) then
  7919.       if ^tty$in () then
  7920.           return (true);
  7921.       else
  7922.          goto rec_pkt;
  7923.  
  7924.    /* Window is blocked : Check for special case. */
  7925.  
  7926.    if msg_table.slot(tab_first).retries = 0 then
  7927.       do;
  7928.          i = mod (tab_first + 1, 64);  /* If some later packet has been
  7929.                                           received then resend earliest one. */
  7930.  
  7931.          do while (i ^= mod (tab_first + window_size, 64));
  7932.             if msg_table.slot(i).acked then
  7933.                do;
  7934.                   i = tab_first;
  7935.                   call log_info (packet_log, 'Resend - window blocked.');
  7936.                   goto resend;
  7937.                end;
  7938.             i = mod (i + 1, 64);
  7939.          end;
  7940.       end;
  7941.  
  7942. Rec_pkt :                /* Receive a packet from the remote side. */
  7943.  
  7944.    call rec_packet;
  7945.  
  7946.    select (rec_pkt_type);          /* Check the packet type. */
  7947.  
  7948.       when (msg_timeout)
  7949.          do;
  7950.             i = tab_first;         /* Resend oldest unacked packet. */
  7951.             do while (msg_table.slot(i).acked);
  7952.                i = mod (i + 1, 64);
  7953.                if i = tab_next then
  7954.                   return (true);
  7955.             end;
  7956.  
  7957.             call log_info (packet_log, 'Resend - timeout.');
  7958.          end;
  7959.  
  7960.       when (msg_check_err)
  7961.          do;
  7962.             call log_info (packet_log, 'Checksum error - ignore packet.');
  7963.             goto get_pkt;
  7964.          end;
  7965.  
  7966.       when (msg_ack)
  7967.          do;               /* Check for ACK/Interrupt packets. */
  7968.             if length (rec_msg) > pkt_msg then
  7969.                rec_msg = set8 (substr (rec_msg, pkt_msg, 1));
  7970.             else
  7971.                rec_msg = '';
  7972.  
  7973.             stop_xfer = (rec_msg = 'X');
  7974.             stop_trans = (rec_msg = 'Z');
  7975.  
  7976.             if stop_xfer | stop_trans then
  7977.                return (true);
  7978.  
  7979.             /* If the ACK is within bounds, process it. */
  7980.  
  7981.             if between (rec_seq, tab_first, mod (tab_next - 1, 64)) then
  7982.                do;
  7983.                   msg_table.slot(rec_seq).acked = true;
  7984.                   i = tab_first;
  7985.  
  7986.                   do while (msg_table.slot(i).acked);
  7987.                      i = mod (i + 1, 64);
  7988.                      if i = tab_next then
  7989.                         leave;
  7990.                   end;
  7991.  
  7992.                   tab_first = i;
  7993.                end;
  7994.  
  7995.             goto get_pkt;
  7996.  
  7997.          end;
  7998.  
  7999.       when (msg_nak)
  8000.  
  8001.          /* If the NAK is within window, resend requested packet,
  8002.             otherwise resend earliest, hoping for an ACK. */
  8003.  
  8004.          if between (rec_seq, tab_first, mod (tab_next - 1, 64)) then
  8005.             do;
  8006.                call log_info (packet_log, 'NAK - resend packet.');
  8007.                i = rec_seq;
  8008.             end;
  8009.          else
  8010.             do;
  8011.                call log_info (packet_log, 'NAK - resend earliest packet.');
  8012.                i = tab_first;
  8013.             end;
  8014.  
  8015.       when (msg_error)
  8016.          do;                 /* Error type. */
  8017.             state = state_a;
  8018.             return (false);
  8019.          end;
  8020.  
  8021.       otherwise
  8022.          do;
  8023.             snd_msg = 'Unexpected packet type "' || rec_pkt_type ||
  8024.                       '" received on remote system.';
  8025.             call send_packet (msg_error, length (snd_msg), msg_number);
  8026.             state = state_a;
  8027.             return (false);
  8028.          end;
  8029.    end;        /* Select */
  8030.  
  8031. Resend :                   /* Resend the packet. */
  8032.  
  8033.    msg_table.slot(i).acked = false;
  8034.    if msg_table.slot(i).retries > max_retries then
  8035.       do;
  8036.          snd_msg = 'Retry limit exceeded on remote system.';
  8037.          call send_packet (msg_error, length (snd_msg), msg_number);
  8038.          return (false);
  8039.       end;
  8040.  
  8041.    snd_msg = msg_table.slot(i).msg;
  8042.    msg_table.slot(i).retries =  msg_table.slot(i).retries + 1;
  8043.    call send_packet (msg_data, length (snd_msg), i);
  8044.  
  8045.    goto get_pkt;
  8046.  
  8047.    end;          /* Prs_input */
  8048.  
  8049.    end;        /* Send_switch */
  8050. -------------------------------------------------------------------------------
  8051.  
  8052. /* SERVER -- Kermit server process. */
  8053.  
  8054. Server : proc;
  8055.  
  8056. $Insert *>insert>common.ins.plp
  8057. $Insert *>insert>kermit.ins.plp
  8058. $Insert *>insert>constants.ins.plp
  8059.  
  8060. Dcl (rep_count, temp, i) fixed bin,
  8061.     new_path char (128) var,
  8062.     chr char (1);
  8063.  
  8064. /* ************************************************************************* */
  8065.  
  8066.    num_retries = 0;         /* Initialize retry count. */
  8067.  
  8068.    do while (true);         /* Main server loop. */
  8069.  
  8070.       msg_number = 0;       /* Reinitialize sequence numbering. */
  8071.  
  8072.       call rec_packet;      /* Get input from line. */
  8073.  
  8074.       select (rec_pkt_type);   /* Process message type. */
  8075.  
  8076.          when (msg_init_info)
  8077.             call ack_send_init;
  8078.  
  8079.          when (msg_snd_init)
  8080.             do;
  8081.                call ack_send_init;
  8082.                msg_number = mod (msg_number + 1, 64);
  8083.                state = state_rf;
  8084.                call set_path ('');
  8085.                call rec_switch;
  8086.             end;
  8087.  
  8088.          when (msg_rcv_init)
  8089.             do;
  8090.                if rec_length > pkt_msg then
  8091.                   do;
  8092.                      path_name = set8str (substr (rec_msg, pkt_msg,
  8093.                                                   length (rec_msg) - pkt_msg));
  8094.                      path_name = trim (path_name, '11'b);
  8095.  
  8096.                   /* The pathname may have repeat character processing in it,
  8097.                      so we must handle this. 8-bit quoting and control quoting
  8098.                      are not allowed in path names, and so will be caught
  8099.                      later on. */
  8100.  
  8101.                      if do_repeats then
  8102.                         if index (path_name, loc_rep_chr) ^= 0 then
  8103.                            do;
  8104.                               new_path = '';
  8105.  
  8106.                               do i = 1 to length (path_name);
  8107.                                  chr = substr (path_name, i, 1);
  8108.  
  8109.                                  if chr = loc_rep_chr then
  8110.                                     do;
  8111.                                        i = i + 1;
  8112.                                        rep_count = knum (substr (path_name, i,
  8113.                                                                  1));
  8114.  
  8115.                                        i = i + 1;
  8116.                                        chr = substr (path_name, i, 1);
  8117.                                     end;
  8118.                                  else
  8119.                                     rep_count = 1;
  8120.  
  8121.                                  do temp = 1 to rep_count;
  8122.                                     new_path = new_path || chr;
  8123.                                  end;
  8124.  
  8125.                               end;
  8126.  
  8127.                               path_name = new_path;
  8128.  
  8129.                            end;
  8130.  
  8131.                      call set_path (path_name);
  8132.                   end;
  8133.  
  8134.                i = delay;         /* Save this old value for later. */
  8135.                delay = 0;         /* No delay time for the server. */
  8136.                state = state_s;
  8137.  
  8138.                call send_switch;
  8139.                delay = i;         /* Now restore the old delay time. */
  8140.             end;
  8141.  
  8142.          when (msg_kermit_generic)          /* Generic kermit commands. */
  8143.             if generic_cmd () = ker_exit then
  8144.                return;
  8145.  
  8146.          when (msg_timeout)                 /* Ignore timeouts. */
  8147.             ;
  8148.  
  8149.          otherwise                          /* Capture all other commands. */
  8150.             do;
  8151.                snd_msg = 'Unimplemented server command.';
  8152.                call send_packet (msg_error, length (snd_msg), msg_number);
  8153.             end;
  8154.  
  8155.       end;      /* select */
  8156.  
  8157.    end;      /* do while */
  8158.  
  8159.    return;
  8160.  
  8161.    end;      /* Server */
  8162. -------------------------------------------------------------------------------
  8163.  
  8164. /* SETUP_TRANS_CHAR -- Builds the character translation table. */
  8165.  
  8166. /* This routine sets up the trans_char character translation table
  8167.    for either ASCII or binary files. The table is used to translate
  8168.    each character of file data to a representation suitable for
  8169.    transmission. The QUOTE8_CHAR determines whether the data receives
  8170.    8-bit quoting in addition to control character quoting. */
  8171.  
  8172. Setup_trans_char : proc;
  8173.  
  8174. $Insert *>insert>common.ins.plp
  8175. $Insert *>insert>kermit.ins.plp
  8176.  
  8177. Dcl (c, sq_bin, s8q_bin, rep_bin) fixed bin,
  8178.     c_ptr ptr,
  8179.     conv_chrs char (3) var,
  8180.     (sq, chr) char (1);
  8181.  
  8182. /* ************************************************************************* */
  8183.  
  8184.    c_ptr = addr (c);
  8185.    char2(1) = nul_7bit_asc;
  8186.  
  8187.    sq = clr8 (loc_quote_chr);      /* Control quote character. */
  8188.    char2(2) = sq;
  8189.    sq_bin = char2_ptr -> fb15_based;
  8190.  
  8191.    char2(2) = clr8 (quote8_char);  /* 8-bit quote character. */
  8192.    s8q_bin = char2_ptr -> fb15_based;
  8193.  
  8194.    char2(2) = clr8 (loc_rep_chr);  /* Repeat character prefix. */
  8195.    rep_bin = char2_ptr -> fb15_based;
  8196.  
  8197.    do c = 0 to 255;
  8198.       chr = substr (c_ptr -> char2_based, 2, 1);
  8199.  
  8200.       if (c < 32) | ((c >= 127) & (c < 160)) | (c = 255) then
  8201.          conv_chrs = sq || ctl (chr);
  8202.       else
  8203.          if (c = sq_bin) | (c = sq_bin + 128) then  /* Control prefix. */
  8204.             conv_chrs = sq || chr;
  8205.          else
  8206.             if (quote8_char ^= 'N') & ((c = s8q_bin) | (c = s8q_bin + 128)) then
  8207.                conv_chrs = sq || chr;       /* 8-bit quote prefix. */
  8208.             else
  8209.                if do_repeats & ((c = rep_bin) | (c = rep_bin + 128)) then
  8210.                   conv_chrs = sq || chr;    /* Repeat character prefix. */
  8211.                else
  8212.                   conv_chrs = chr;  /* Normal character. */
  8213.  
  8214.       if (quote8_char ^= 'N') & (c >= 128) then  /* Apply 8-bit quoting. */
  8215.          trans_char(c) = quote8_char || trans_char(c - 128);
  8216.       else
  8217.          trans_char(c) = conv_chrs;
  8218.  
  8219.    end;
  8220.  
  8221.    if pound_conversion then
  8222.       trans_char(28) = trans_char(156);  /* Pound sign conversion for DOS. */
  8223.  
  8224.    return;
  8225.  
  8226.    end;       /* Setup_trans_char */
  8227. -------------------------------------------------------------------------------
  8228.  
  8229. /* SET_PARAMS -- determine the file transfer parameters. */
  8230.  
  8231. Set_params : proc;
  8232.  
  8233. $Insert *>insert>common.ins.plp
  8234. $Insert *>insert>kermit.ins.plp
  8235. $Insert *>insert>constants.ins.plp
  8236.  
  8237. Dcl rem_8q char (1);
  8238.  
  8239. /* ************************************************************************* */
  8240.  
  8241.    rem_8q = set8 (rem_8quote_chr);  /* Set the top bit for local processing. */
  8242.  
  8243.    quote8_char = 'N';     /* Assume no 8-bit quoting at first. */
  8244.  
  8245.    if loc_8quote_chr = 'Y' then
  8246.       if quote8_ok (rem_8q) then           /* Check on the remote side. */
  8247.          quote8_char = rem_8quote_chr;
  8248.       else
  8249.          ;
  8250.    else
  8251.       if quote8_ok (loc_8quote_chr) then    /* See if the remote side agrees. */
  8252.          if rem_8q = 'Y' | rem_8q = loc_8quote_chr then
  8253.             quote8_char = loc_8quote_chr;
  8254.  
  8255.    do_repeats = (loc_rep_chr = set8 (rem_rep_chr)) &
  8256.                 (loc_rep_chr ^= space_8bit_asc);
  8257.  
  8258.    /* Determine the window size to use. */
  8259.  
  8260.    if loc_max_wsize <= rem_max_wsize then
  8261.       window_size = loc_max_wsize;
  8262.    else
  8263.       window_size = rem_max_wsize;
  8264.  
  8265.    return;
  8266.  
  8267. /* ******************************* Quote8_ok ******************************* */
  8268.  
  8269. Quote8_ok : proc (c) returns (bit (1) aligned);
  8270.  
  8271. Dcl c char (1);
  8272.  
  8273. Dcl n fixed bin;
  8274.  
  8275. /* ************************************************************************* */
  8276.  
  8277.    char2(1) = nul_7bit_asc;
  8278.    char2(2) = c;
  8279.    n = char2_ptr -> fb15_based;
  8280.  
  8281.    if n > 128 then
  8282.       n = n - 128;
  8283.  
  8284.    if ((n >= 33) & (n <= 62)) | ((n >= 96) & (n <= 126)) then
  8285.       return (true);
  8286.    else
  8287.       return (false);
  8288.  
  8289.    end;        /* Quote8_ok */
  8290.  
  8291.    end;     /* Set_params */
  8292. -------------------------------------------------------------------------------
  8293.  
  8294. /* SET_PATH -- Set the pathname, directory name, and file name variables. */
  8295.  
  8296. Set_path : proc (treename);
  8297.  
  8298. Dcl treename char (128) var;
  8299.  
  8300. $Insert *>insert>common.ins.plp
  8301. $Insert *>insert>primos.ins.plp
  8302. $Insert *>insert>constants.ins.plp
  8303. $Insert syscom>keys.ins.pl1
  8304.  
  8305. Dcl (funit, new_dir_len, code) fixed bin,
  8306.     temp_path char (128) var,
  8307.     new_dir_name char (128);
  8308.  
  8309. /* ************************************************************************* */
  8310.  
  8311.    dir_name = '';
  8312.    file_name = '';
  8313.    non_null_dir = false;
  8314.    path_name = trim (treename, '11'b);
  8315.  
  8316.    if path_name = '*' then
  8317.       path_name = '';
  8318.  
  8319.    if length (path_name) = 0 then
  8320.       return;
  8321.  
  8322.    temp_path = reverse (path_name);
  8323.    file_name = reverse (before (temp_path, '>'));
  8324.    dir_name = reverse (after (temp_path, '>'));
  8325.  
  8326.    if dir_name = '*' then
  8327.       dir_name = '';
  8328.  
  8329.    if length (dir_name) > 0 then
  8330.       if substr (dir_name, 1, 1) = '<' & index (dir_name, '>') = 0 then
  8331.          dir_name = dir_name || '>MFD';      /* Correct for MFD level files. */
  8332.  
  8333.    non_null_dir = (length (dir_name) ^= 0);
  8334.  
  8335.    if non_null_dir then    /* We need to do this to get the partition name. */
  8336.       do;
  8337.          call at$ (k$setc, dir_name, code);
  8338.          if code = 0 then
  8339.             do;
  8340.                call gpath$ (k$cura, funit, new_dir_name, 128, new_dir_len,
  8341.                             code);
  8342.                if code = 0 then
  8343.                   do;
  8344.                      dir_name = substr (new_dir_name, 1, new_dir_len);
  8345.                      path_name = dir_name || '>' || file_name;
  8346.  
  8347.                      call finfo$ (current_attach_point, file_info_ptr, code);
  8348.                      if code ^= 0 then
  8349.                         file_info.ldevno = -1;
  8350.                   end;
  8351.             end;
  8352.  
  8353.          call at$hom (code);
  8354.  
  8355.       end;
  8356.  
  8357.    return;
  8358.  
  8359.    end;       /* Set_path */
  8360. -------------------------------------------------------------------------------
  8361.  
  8362. /* TIMEOUT_HNDLR -- On_unit for receive timeout (ALARM$ condition). */
  8363.  
  8364. Timeout_hndlr : proc (dummy);
  8365.  
  8366. Dcl dummy ptr;
  8367.  
  8368. $Insert *>insert>common.ins.plp
  8369.  
  8370. /* ************************************************************************* */
  8371.  
  8372.    /* "timeout" is a label variable which is set to a local label
  8373.       in REC_PACKET every time that routine is called. This enables
  8374.       us to create the on-unit once at startup yet have it return to
  8375.       a sub-procedure when the condition arises.
  8376.    */
  8377.  
  8378.    goto timeout;
  8379.  
  8380.    end;       /* Timeout_hndlr */
  8381. -------------------------------------------------------------------------------
  8382.  
  8383. /* UTILITIES -- These are a collection of frequently used subroutines. */
  8384.  
  8385. /* ********************************* Ctl *********************************** */
  8386.  
  8387. /* CTL -- Toggle character's "control" bit. */
  8388.  
  8389. Ctl : proc (char_str) returns (char (1));
  8390.  
  8391. Dcl char_str char (1);
  8392.  
  8393. $Insert *>insert>common.ins.plp
  8394. $Insert *>insert>primos.ins.plp
  8395. $Insert *>insert>kermit.ins.plp
  8396. $Insert *>insert>constants.ins.plp
  8397.  
  8398. Dcl bit8 bit (8) aligned,
  8399.     bit8_ptr ptr,
  8400.     fb fixed bin;
  8401.  
  8402. Dcl 1 b8 based,
  8403.       2 high_bit bit (1),
  8404.       2 ctrl_bit bit (1),
  8405.       2 b6 bit (6);
  8406.  
  8407. /* ************************************************************************* */
  8408.  
  8409.    bit8_ptr = addr (bit8);
  8410.    bit8_ptr -> char1_based = char_str;
  8411.    bit8_ptr -> b8.ctrl_bit = ^(bit8_ptr -> b8.ctrl_bit);
  8412.  
  8413.    return (bit8_ptr -> char1_based);
  8414.  
  8415. /* ********************************* Knum ********************************** */
  8416.  
  8417. /* KNUM -- Kermit function to make character a number. */
  8418.  
  8419. Knum : entry (char_k) returns (fixed bin);
  8420.  
  8421. Dcl char_k char (1);
  8422.  
  8423. /* ************************************************************************* */
  8424.  
  8425.    fb = 0;
  8426.    substr (addr (fb) -> char2_based, 2, 1) = char_k;
  8427.  
  8428.    if fb >= 128 then
  8429.       fb = fb - 128;
  8430.  
  8431.    fb = fb - 32;              /* Turn off "printable" bit. */
  8432.  
  8433.    return (fb);
  8434.  
  8435. /* ********************************* Set8 ********************************** */
  8436.  
  8437. /* SET8 -- Set high bit on a character. */
  8438.  
  8439. Set8 : entry (ch1) returns (char (1));
  8440.  
  8441. Dcl ch1 char (1);
  8442.  
  8443. /* ************************************************************************* */
  8444.  
  8445.    bit8_ptr = addr (bit8);
  8446.    bit8_ptr -> char1_based = ch1;
  8447.    bit8_ptr -> b8.high_bit = '1'b;
  8448.  
  8449.    return (bit8_ptr -> char1_based);
  8450.  
  8451. /* ********************************* Clr8 ********************************** */
  8452.  
  8453. /* CLR8 -- Clear high bit on a character. */
  8454.  
  8455. Clr8 : entry (ch1) returns (char (1));
  8456.  
  8457. /* ************************************************************************* */
  8458.  
  8459.    bit8_ptr = addr (bit8);
  8460.    bit8_ptr -> char1_based = ch1;
  8461.    bit8_ptr -> b8.high_bit = '0'b;
  8462.  
  8463.    return (bit8_ptr -> char1_based);
  8464.  
  8465. /* ******************************** Set8str ******************************** */
  8466.  
  8467. /* SET8STR -- Set high bit on all characters in a string. */
  8468.  
  8469. Set8str : entry (str1) returns (char (ibuffer_size) var);
  8470.  
  8471. Dcl str1 char (ibuffer_size) var;
  8472.  
  8473. Dcl str2 char (ibuffer_size) var,
  8474.     (str_ptr, str_ptr2) ptr,
  8475.     (i, j) fixed bin;
  8476.  
  8477. /* ************************************************************************* */
  8478.  
  8479.    str2 = '';
  8480.    j = length (str1);
  8481.    str_ptr = addrel (addr (str1), 1);
  8482.    str_ptr2 = addr (str2);
  8483.    str_ptr2 -> fb15_based = j;             /* Set the string length. */
  8484.    str_ptr2 = addrel (str_ptr2, 1);
  8485.  
  8486.    do i = 1 to j by 2;       /* Process the string 2 characters at a time. */
  8487.       str_ptr2 -> bit16_based = str_ptr -> bit16_based | '8080'b4;
  8488.       str_ptr = addrel (str_ptr, 1);
  8489.       str_ptr2 = addrel (str_ptr2, 1);
  8490.    end;
  8491.  
  8492.    if mod (j, 2) ^= 0 then    /* We mustn't forget the last odd character. */
  8493.       str_ptr2 -> bit8_based = str_ptr -> bit8_based | '80'b4;
  8494.  
  8495.    return (str2);
  8496.  
  8497. /* ******************************** Clr8str ******************************** */
  8498.  
  8499. /* CLR8STR -- Clear high bit on all characters in a string. */
  8500.  
  8501. Clr8str : entry (str1) returns (char (ibuffer_size) var);
  8502.  
  8503. /* ************************************************************************* */
  8504.  
  8505.    str2 = '';
  8506.    j = length (str1);
  8507.    str_ptr = addrel (addr (str1), 1);
  8508.    str_ptr2 = addr (str2);
  8509.    str_ptr2 -> fb15_based = j;             /* Set the string length. */
  8510.    str_ptr2 = addrel (str_ptr2, 1);
  8511.  
  8512.    do i = 1 to j by 2;       /* Process the string 2 characters at a time. */
  8513.       str_ptr2 -> bit16_based = str_ptr -> bit16_based & '7F7F'b4;
  8514.       str_ptr = addrel (str_ptr, 1);
  8515.       str_ptr2 = addrel (str_ptr2, 1);
  8516.    end;
  8517.  
  8518.    if mod (j, 2) ^= 0 then    /* We mustn't forget the last odd character. */
  8519.       str_ptr2 -> bit8_based = str_ptr -> bit8_based & '7F'b4;
  8520.  
  8521.    return (str2);
  8522.  
  8523. /* ******************************** Between ******************************** */
  8524.  
  8525. Between : entry (num, lo, hi) returns (bit (1) aligned);
  8526.  
  8527. Dcl (num, lo, hi) fixed bin;
  8528.  
  8529. /* ************************************************************************* */
  8530.  
  8531.    if lo <= hi then
  8532.       return ((num >= lo) & (num <= hi));
  8533.    else
  8534.       return ((num <= hi) | (num >= lo));
  8535.  
  8536. /* ******************************* Ctl_trans ******************************* */
  8537.  
  8538. /* CTL_TRANS -- Translate ^n to ctl ('n'), \n to CR, and \xxx to ASCII #xxx */
  8539.  
  8540. Ctl_trans : entry (str_okay, str) returns (char (128) var);
  8541.  
  8542. Dcl str_okay bit (1) aligned,
  8543.     str char (128) var;
  8544.  
  8545. Dcl (tempstr, retstr) char (128) var,
  8546.     (idx1, idx2) fixed bin,
  8547.     idx1_ptr ptr,
  8548.     ctrl_chars char (58);
  8549.  
  8550. /* ************************************************************************* */
  8551.  
  8552.    retstr = '';
  8553.    tempstr = trim (str, '11'b);
  8554.    str_okay = true;
  8555.    idx1_ptr = addr (idx1);
  8556.    ctrl_chars = uppercase || lowercase || '@[\]^_';
  8557.  
  8558.    do while (length (tempstr) ^= 0);
  8559.  
  8560.       idx1 = index (tempstr, '/');
  8561.       idx2 = index (tempstr, '^');
  8562.  
  8563.       if idx2 = 0 | (idx1 < idx2 & idx1 ^= 0) then
  8564.          idx2 = idx1;
  8565.  
  8566.       if idx2 = 0 then
  8567.          do;
  8568.             retstr = retstr || tempstr;
  8569.             tempstr = '';
  8570.          end;
  8571.       else
  8572.          do;
  8573.             if idx2 > 1 then
  8574.                do;
  8575.                   retstr = retstr || substr (tempstr, 1, idx2 - 1);
  8576.                   tempstr = substr (tempstr, idx2, length (tempstr) - idx2+1);
  8577.                end;
  8578.  
  8579.             if substr (tempstr, 1, 1) = '/' then
  8580.                if length (tempstr) >= 2 & substr (tempstr, 2, 1) = 'n' then
  8581.                   do;
  8582.                      retstr = retstr || cr_8bit_asc;
  8583.                      tempstr = after (tempstr, '/n');
  8584.                   end;
  8585.                else
  8586.                   if length (tempstr) >= 2 & substr (tempstr, 2, 1) = '/' then
  8587.                      do;
  8588.                         retstr = retstr || '/';
  8589.                         tempstr = after (tempstr, '//');
  8590.                      end;
  8591.                   else
  8592.                      if length (tempstr) >= 4 &
  8593.                         verify (substr (tempstr, 2, 3), '01234567') = 0 &
  8594.                         bin (substr (tempstr, 2, 3), 15) <= 377 then
  8595.                         do;
  8596.                            idx1 = bin (substr (tempstr, 2, 1), 15) * 64 +
  8597.                                   bin (substr (tempstr, 3, 1), 15) * 8 +
  8598.                                   bin (substr (tempstr, 4, 1), 15);
  8599.                            retstr = retstr || substr (
  8600.                                               idx1_ptr -> char2_based, 2, 1);
  8601.                            tempstr = after (tempstr, substr (tempstr, 1, 4));
  8602.                         end;
  8603.                else
  8604.                   do;      /* Illegal '/' usage. */
  8605.                      retstr = '';
  8606.                      tempstr = '';
  8607.                      str_okay = false;
  8608.                   end;
  8609.             else           /* A control character ? */
  8610.                if length (tempstr) >= 2 &
  8611.                   verify (substr (tempstr, 2, 1), ctrl_chars) = 0 then
  8612.                   do;
  8613.                      retstr = retstr ||
  8614.                         ctl (translate (substr (tempstr, 2, 1), uppercase,
  8615.                                                                 lowercase));
  8616.                      tempstr = after (tempstr, substr (tempstr, 2, 1));
  8617.                   end;
  8618.                else
  8619.                   do;      /* Illegal '^' usage. */
  8620.                      retstr = '';
  8621.                      tempstr = '';
  8622.                      str_okay = false;
  8623.                   end;
  8624.          end;
  8625.    end;   /* Do while */
  8626.  
  8627.    return (retstr);
  8628.  
  8629. /* ********************************* More ********************************** */
  8630.  
  8631. More : entry returns (bit (1) aligned);
  8632.  
  8633. Dcl ans char (16) var,
  8634.     code fixed bin;
  8635.  
  8636. /* ************************************************************************* */
  8637.  
  8638.    ans = '';
  8639.    call tnoua ('More ? ', 7);
  8640.    call cl$get (ans, 16, code);
  8641.    if code ^= 0 then
  8642.       return (false);
  8643.  
  8644.    if length (ans) = 0 then
  8645.       return (true);
  8646.  
  8647.    ans = translate (substr (trim (ans, '10'b), 1, 1), uppercase, lowercase);
  8648.  
  8649.    return (ans = 'Y');
  8650.  
  8651.    end;       /* Utilities */
  8652. -------------------------------------------------------------------------------
  8653.  
  8654. /* WRITE_IBUF -- Write intermediate buffer to disk file. */
  8655.  
  8656. Write_ibuf : proc (key, code);
  8657.  
  8658. Dcl (key, code) fixed bin;
  8659.  
  8660. $Insert *>insert>common.ins.plp
  8661. $Insert *>insert>kermit.ins.plp
  8662. $Insert *>insert>primos.ins.plp
  8663. $Insert *>insert>constants.ins.plp
  8664. $Insert syscom>keys.ins.pl1
  8665.  
  8666. Dcl rnw fixed bin;
  8667.  
  8668. /* ************************************************************************* */
  8669.  
  8670.    code = 0;
  8671.  
  8672.    /* Initially we try to write the file out as an ASCII file, unless the
  8673.       file type has been set or any 8-bit characters are seen. */
  8674.  
  8675.    if file_type ^= binary_ft then
  8676.       call write_text;
  8677.  
  8678.    /* If write_text decides it's actually a binary file,
  8679.       then it will change FILE_TYPE. */
  8680.  
  8681.    if file_type = binary_ft then
  8682.       call write_binary;
  8683.  
  8684.    return;
  8685.  
  8686. /* ***************************** Write_binary ****************************** */
  8687.  
  8688. Write_binary : proc;
  8689.  
  8690. Dcl rwl_key (2) fixed bin,
  8691.     odd bit (1) aligned;
  8692.  
  8693. /* ************************************************************************* */
  8694.  
  8695.    /* This code adds an extra CTRL-Z to ibuffer if the file length is odd,
  8696.       this enables us to write out an even number of characters and not lose
  8697.       the last character. The file read/write lock is set to NONE to show this.
  8698.       The file length is decremented by 1 in OPEN_INPUT (downloading) if the
  8699.       rwlock is set to NONE (3). Note : this scheme for preserving the exact
  8700.       character length of the file will only work if the uploading process has
  8701.       OWNER (O) or PROTECT (P) access to the file. Otherwise the lock is not
  8702.       changed and the extra CTRL-Z will be downloaded. The error is not
  8703.       reported. */
  8704.  
  8705.    odd = (mod (ibuf_ptr, 2) ^= 0);
  8706.  
  8707.    if key = 1 then     /* If key indicates this is the end of the file ... */
  8708.       if odd then
  8709.          do;
  8710.             ibuf_ptr = ibuf_ptr + 1;
  8711.             substr (ibuffer, ibuf_ptr, 1) = ctrl_z_7bit_asc;
  8712.  
  8713.             if non_null_dir then
  8714.                call at$ (k$setc, dir_name, code);
  8715.  
  8716.             rwl_key(1) = k$none;
  8717.             rwl_key(2) = 0;
  8718.  
  8719.             if code = 0 then
  8720.                call satr$$ (k$rwlk, (file_name), length (file_name),
  8721.                             addr (rwl_key) -> fb31_based, code);
  8722.  
  8723.             if non_null_dir then
  8724.                call at$hom (code);
  8725.          end;
  8726.  
  8727.    call prwf$$ (k$writ, file_unit, ibuffer_ptr, divide (ibuf_ptr, 2, 15), 0,
  8728.                 rnw, code);
  8729.  
  8730.    if odd then
  8731.       do;                /* Keep the last odd character. */
  8732.          substr (ibuffer, 1, 1) = substr (ibuffer, ibuf_ptr, 1);
  8733.          ibuf_ptr = 1;
  8734.       end;
  8735.    else
  8736.       ibuf_ptr = 0;      /* Reset position pointer to start of ibuffer. */
  8737.  
  8738.    return;
  8739.  
  8740.    end;       /* Write_binary */
  8741.  
  8742. /* ******************************* Write_text ****************************** */
  8743.  
  8744. Write_text : proc;
  8745.  
  8746. Dcl tbuffer char (2048),
  8747.     (i, tbuf_ptr, save_cnt) fixed bin,
  8748.     (character, prev_char) char (1),
  8749.     char_ptr ptr,
  8750.     (cr_seen, crlf_seen, store_char) bit (1) aligned;
  8751.  
  8752. Dcl 1 bit_char based,
  8753.       2 high_bit bit (1),
  8754.       2 next_bits bit (7);
  8755.  
  8756. /* ************************************************************************* */
  8757.  
  8758.    tbuf_ptr = 0;
  8759.    cr_seen = false;
  8760.    crlf_seen = false;
  8761.    store_char = true;
  8762.    prev_char = nul_7bit_asc;
  8763.    char_ptr = addr (character);
  8764.  
  8765.    /* Now set the top bit on all the characters,
  8766.       and convert the EOL sequences. */
  8767.  
  8768.    do i = 1 to ibuf_ptr;
  8769.       character = substr (ibuffer, i, 1);
  8770.       if prev_char ^= dc1_8bit_asc then
  8771.          char_ptr -> bit_char.high_bit = '1'b;
  8772.  
  8773.       store_char = true;       /* Assume we want to store this character. */
  8774.  
  8775.       if character = cr_8bit_asc then
  8776.          do;
  8777.             store_char = cr_seen;       /* Store CR if we had one before. */
  8778.             cr_seen = true;
  8779.          end;
  8780.       else
  8781.          do;
  8782.             if character = lf_8bit_asc then
  8783.                do;
  8784.                   if cr_seen then
  8785.                      crlf_seen = true;      /* So we really do have CRLF. */
  8786.  
  8787.                   if mod (tbuf_ptr, 2) = 0 then
  8788.                      do;
  8789.                         tbuf_ptr = tbuf_ptr + 1;
  8790.                         substr (tbuffer, tbuf_ptr, 1) = lf_8bit_asc;
  8791.  
  8792.                         character = nul_7bit_asc;     /* Now store a NUL. */
  8793.                      end;
  8794.                end;
  8795.             else
  8796.                if cr_seen then   /* Keep any previous CR we may have had. */
  8797.                   do;
  8798.                      tbuf_ptr = tbuf_ptr + 1;
  8799.                      substr (tbuffer, tbuf_ptr, 1) = cr_8bit_asc;
  8800.                   end;
  8801.  
  8802.             cr_seen = false;               /* We don't have a CR anymore. */
  8803.          end;
  8804.  
  8805.       if store_char then
  8806.          do;
  8807.             tbuf_ptr = tbuf_ptr + 1;
  8808.             substr (tbuffer, tbuf_ptr, 1) = character;
  8809.          end;
  8810.  
  8811.       prev_char = character;
  8812.  
  8813.    end;
  8814.  
  8815.    if cr_seen then      /* Keep any final CR we may have had. */
  8816.       do;
  8817.          tbuf_ptr = tbuf_ptr + 1;
  8818.          substr (tbuffer, tbuf_ptr, 1) = cr_8bit_asc;
  8819.       end;
  8820.  
  8821.    if tbuf_ptr = 0 then
  8822.       return;
  8823.  
  8824.    save_cnt = 0;
  8825.  
  8826.    if key = 0 then            /* Save the CTRL-Z or CR or odd character. */
  8827.       do;
  8828.          character = substr (tbuffer, tbuf_ptr, 1);
  8829.          if character = ctrl_z_8bit_asc | character = cr_8bit_asc then
  8830.             save_cnt = 1;
  8831.  
  8832.          if mod (tbuf_ptr - save_cnt, 2) ^= 0 then
  8833.             do;
  8834.                save_cnt = save_cnt + 1;
  8835.  
  8836.                if substr (tbuffer, tbuf_ptr - save_cnt, 1) = dc1_8bit_asc then
  8837.                   save_cnt = save_cnt + 2;
  8838.             end;
  8839.  
  8840.          if save_cnt > 0 then
  8841.             do;
  8842.                substr (ibuffer, 1, save_cnt) = substr (tbuffer,
  8843.                                              tbuf_ptr - save_cnt + 1, save_cnt);
  8844.                tbuf_ptr = tbuf_ptr - save_cnt;
  8845.             end;
  8846.  
  8847.          ibuf_ptr = save_cnt;
  8848.       end;
  8849.    else
  8850.       do;                /* Last write to file. */
  8851.          if rec_file_type = automatic_ft & first_write & ^crlf_seen then
  8852.             do;
  8853.                rec_file_type = binary_ft;  /* If the file is read in one go, */
  8854.                file_type = binary_ft;      /* and doesn't end in CRLF,
  8855.                                               then it's BINARY. */
  8856.                if packet_log_opened then
  8857.                   call log_info (packet_log,
  8858.                   'BINARY file type has been detected, and will now be used.');
  8859.                return;
  8860.             end;
  8861.  
  8862.          if substr (tbuffer, tbuf_ptr, 1) = ctrl_z_8bit_asc then
  8863.             tbuf_ptr = tbuf_ptr - 1;        /* Remove the last CTRL-Z. */
  8864.  
  8865.          if tbuf_ptr > 0 then
  8866.             if substr (tbuffer, tbuf_ptr, 1) ^= lf_8bit_asc then
  8867.                if tbuf_ptr > 1 then
  8868.                   if substr (tbuffer, tbuf_ptr - 1, 2) ^= lf_8bit_asc ||
  8869.                                                           nul_7bit_asc then
  8870.                      do;
  8871.                         tbuf_ptr = tbuf_ptr + 1;
  8872.                         substr (tbuffer, tbuf_ptr, 1) = lf_8bit_asc;
  8873.                      end;
  8874.                   else
  8875.                      ;
  8876.                else
  8877.                   do;
  8878.                      tbuf_ptr = tbuf_ptr + 1;
  8879.                      substr (tbuffer, tbuf_ptr, 1) = lf_8bit_asc;
  8880.                   end;
  8881.  
  8882.          if mod (tbuf_ptr, 2) ^= 0 then
  8883.             do;
  8884.                tbuf_ptr = tbuf_ptr + 1;
  8885.                substr (tbuffer, tbuf_ptr, 1) = nul_7bit_asc;
  8886.             end;
  8887.  
  8888.          ibuf_ptr = 0;
  8889.       end;
  8890.  
  8891.    first_write = false;
  8892.  
  8893.    call prwf$$ (k$writ, file_unit, addr (tbuffer), divide (tbuf_ptr, 2, 15), 0,
  8894.                 rnw, code);
  8895.  
  8896.    return;
  8897.  
  8898.    end;            /* Write_text */
  8899.  
  8900.    end;        /* Write_ibuf */
  8901. -------------------------------------------------------------------------------
  8902.  
  8903. /* WRITE_OUTPUT -- Write data to output file. */
  8904.  
  8905. Write_output : proc returns (fixed bin);
  8906.  
  8907. $Insert *>insert>kermit.ins.plp
  8908. $Insert *>insert>common.ins.plp
  8909. $Insert *>insert>constants.ins.plp
  8910.  
  8911. Dcl (counter, rec_msg_len, code, rep_count, next, end) fixed bin,
  8912.     (character, chr) char (1),
  8913.     rem_pound_str char (2),
  8914.     (do_8bit_quoting, parity, compress_spaces) bit (1) aligned;
  8915.  
  8916. /* ************************************************************************* */
  8917.  
  8918.    code = 0;
  8919.    char2(1) = nul_7bit_asc;
  8920.    rec_msg_len = length (rec_msg) - 1;
  8921.    do_8bit_quoting = (quote8_char ^= 'N');
  8922.    rem_pound_str = rem_quote_chr || '\';
  8923.  
  8924.    do counter = pkt_msg to rec_msg_len until (code ^= 0);
  8925.  
  8926.       character = substr (rec_msg, counter, 1);
  8927.       rep_count = 1;
  8928.       parity = false;
  8929.  
  8930.       if do_repeats then              /* Process repeat characters. */
  8931.          if set8 (character) = loc_rep_chr then
  8932.             do;
  8933.                counter = counter + 1;
  8934.                rep_count = knum (substr (rec_msg, counter, 1));
  8935.  
  8936.                counter = counter + 1;
  8937.                character = substr (rec_msg, counter, 1);
  8938.             end;
  8939.  
  8940.       if do_8bit_quoting then         /* Process 8-bit quoting. */
  8941.          if character = quote8_char then
  8942.             do;
  8943.                parity = true;
  8944.                counter = counter + 1;
  8945.                character = substr (rec_msg, counter, 1);
  8946.                if rec_file_type = automatic_ft & (substr (rec_msg, counter, 2)
  8947.                                                   ^= rem_pound_str) then
  8948.                   do;
  8949.                      rec_file_type = binary_ft;
  8950.                      file_type = binary_ft;       /* It's a BINARY file. */
  8951.                      if packet_log_opened then
  8952.                         call log_info (packet_log,
  8953.                   'BINARY file type has been detected, and will now be used.');
  8954.                   end;
  8955.             end;
  8956.  
  8957.       /* Process control character quoting. */
  8958.  
  8959.       if set8 (character) = set8 (rem_quote_chr) then
  8960.          do;
  8961.             counter = counter + 1;
  8962.             character = substr (rec_msg, counter, 1);
  8963.             chr = clr8 (character);
  8964.             if chr >= query_7bit_asc & chr < grave_7bit_asc then
  8965.                character = ctl (character);
  8966.          end;
  8967.  
  8968.       if do_8bit_quoting then        /* Now we can add the parity. */
  8969.          if parity then
  8970.             character = set8 (character);
  8971.          else
  8972.             character = clr8 (character);
  8973.       else
  8974.          if do_transparent then
  8975.             if rec_file_type = automatic_ft & character >= nul_8bit_asc then
  8976.                do;
  8977.                   rec_file_type = binary_ft;
  8978.                   file_type = binary_ft;    /* It's a BINARY file. */
  8979.                   if packet_log_opened then
  8980.                      call log_info (packet_log,
  8981.                   'BINARY file type has been detected, and will now be used.');
  8982.                end;
  8983.  
  8984.       /* Store in intermediate buffer. */
  8985.  
  8986.       if file_type = ascii_ft & character = space_7bit_asc & rep_count > 2 then
  8987.          do;         /* Spaces are a special case, allow for 2 characters. */
  8988.             next = 2;
  8989.             compress_spaces = true;
  8990.          end;
  8991.       else
  8992.          do;
  8993.             next = rep_count;
  8994.             compress_spaces = false;
  8995.          end;
  8996.  
  8997.       if ibuf_ptr + next > ibuffer_size then
  8998.          call write_ibuf (0, code);       /* Make some space if necessary. */
  8999.  
  9000.       if compress_spaces then
  9001.          do;
  9002.             ibuf_ptr = ibuf_ptr + 1;
  9003.             substr (ibuffer, ibuf_ptr, 1) = dc1_8bit_asc;
  9004.             char2_ptr -> fb15_based = rep_count;
  9005.             character = char2(2);
  9006.             rep_count = 1;
  9007.          end;
  9008.  
  9009.       next = ibuf_ptr + 1;
  9010.       end = ibuf_ptr + rep_count;
  9011.  
  9012.       do ibuf_ptr = next to end;
  9013.          substr (ibuffer, ibuf_ptr, 1) = character;
  9014.       end;
  9015.  
  9016.       ibuf_ptr = ibuf_ptr - 1;     /* Adjustment for the do loop. */
  9017.  
  9018.       if ibuf_ptr >= ibuffer_size then  /* Write out the buffer if its full. */
  9019.          call write_ibuf (0, code);
  9020.  
  9021.    end;            /* do until */
  9022.  
  9023.    return (code);
  9024.  
  9025.    end;         /* Write_output */
  9026. -------------------------------------------------------------------------------
  9027.  
  9028. /* XFER_MODE -- Set or reset packet transfer mode. */
  9029.  
  9030. Xfer_mode : proc (key, code);
  9031.  
  9032. Dcl (key, code) fixed bin;
  9033.  
  9034. $Insert *>insert>common.ins.plp
  9035. $Insert *>insert>kermit.ins.plp
  9036. $Insert *>insert>primos.ins.plp
  9037. $Insert *>insert>constants.ins.plp
  9038. $Insert syscom>keys.ins.pl1
  9039.  
  9040. /* ************************************************************************* */
  9041.  
  9042.    code = 0;
  9043.  
  9044.    select (key);
  9045.  
  9046.       when (0)          /* Reset to interactive use. */
  9047.          do;
  9048.             if ^do_transparent then
  9049.                addr (code) -> bit16_based = duplx$ (my_duplex);
  9050.  
  9051.             call erkl$$ (k$writ, my_erase, my_kill, code);
  9052.  
  9053.             call mgset$ (my_msg_state, code);
  9054.          end;
  9055.  
  9056.       when (1)               /* Set up for packet transfer. */
  9057.          do;
  9058.             if ^do_transparent then           /* Set to half duplex. */
  9059.                addr (code) -> bit16_based = duplx$ (my_half_duplex);
  9060.  
  9061.             /* Set the erase and kill characters to non-printing. */
  9062.  
  9063.             call erkl$$ (k$writ, my_new_erase, my_new_kill, code);
  9064.  
  9065.             /* Reject any messages we may receive. */
  9066.  
  9067.             call mgset$ (k$rjct, code);
  9068.  
  9069.             auto_sum = do_transparent;   /* Set if we have no parity. */
  9070.          end;
  9071.  
  9072.       otherwise
  9073.          code = -1;
  9074.  
  9075.    end;
  9076.  
  9077.    return;
  9078.  
  9079.    end;      /* Xfer_mode */
  9080.  
  9081.