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