home *** CD-ROM | disk | FTP | other *** search
/ Columbia Kermit / kermit.zip / old / misc / prime / prime800.src < prev    next >
Text File  |  2020-01-01  |  221KB  |  7,098 lines
  1. -------------------------------------------------------------------------------
  2. /*
  3. /*   Build file for PRIME Kermit-R21.
  4. /*
  5. &severity &error &routine err
  6. /*
  7. &args rest_of_line : uncl; compile : -c, -comp, -compile fn : entry = @.plp; ~
  8.       como : -como como_file : tree = kermit.build.como; load : -l, -load; ~
  9.       no_compress : -noc, -no_compress; rebuild : -r, -reb, -rebuild; ~
  10.       help : -h, -help, -u, -usage
  11. /*
  12. &if [null %compile%%load%%rebuild%] &then ~
  13.     &s help := HELP
  14. /*
  15. &if ^ [null %help%] &then ~
  16.     &do
  17.        &call print_help
  18.        &stop
  19.     &end
  20. /*
  21. &if ^ [null %rebuild%] &then ~
  22.     &do
  23.        &s compile := true
  24.        &s load := true
  25.     &end
  26. /*
  27. &if [null %no_compress%] & [index %rest_of_line% -debug] = 0 &then ~
  28.     &s compress := compress
  29. &else ~
  30.     &s compress :=
  31. /*
  32. &if ^ [null %como%] &then ~
  33.     &do
  34.        &debug &echo com
  35.        como %como_file%
  36.        date
  37.     &end
  38. /*
  39. &if ^ [null %compile%] &then ~
  40.     &do
  41.        &if ^ [exists *>obj -dir] &then ~
  42.            create *>obj
  43.        &else ~
  44.            &if ^ [null %rebuild%] &then ~
  45.                delete  *>obj>@@ -nvfy -force
  46. /*
  47.        &if [entryname %fn%] = %fn% &then   /* [dir %fn%] = *, doesn't work. ~
  48.            &s fn := *>source>%fn%
  49. /*
  50.        plp %fn% -b *>obj>=.+bin %rest_of_line%
  51.     &end
  52. /*
  53. &if ^ [null %load%] &then ~
  54.     &data bind
  55.           lo *>obj>kermit
  56.           lo *>obj>kermit_init
  57.           lo *>obj>bk_hndlr
  58.           lo *>obj>timeout_hndlr
  59.           lo *>obj>ren_hndlr
  60.           lo *>obj>comnd
  61.           lo *>obj>server
  62.           lo *>obj>generic_cmd
  63.           lo *>obj>rec_switch
  64.           lo *>obj>rec_packet
  65.           lo *>obj>send_switch
  66.           lo *>obj>send_packet
  67.           lo *>obj>utilities
  68.           lo *>obj>chks
  69.           lo *>obj>ack_send_init
  70.           lo *>obj>prs_send_init
  71.           lo *>obj>set_params
  72.           lo *>obj>set_path
  73.           lo *>obj>read_input
  74.           lo *>obj>write_output
  75.           lo *>obj>write_ibuf
  76.           lo *>obj>log_packet
  77.           lo *>obj>log_info
  78.           lo *>obj>next_file
  79.           lo *>obj>setup_trans_char
  80.           lo *>obj>get_attr
  81.           lo *>obj>get_dtc
  82.           lo *>obj>get_len
  83.           lo *>obj>change_dir
  84.           lo *>obj>open_input
  85.           lo *>obj>open_output
  86.           lo *>obj>close_input
  87.           lo *>obj>close_output
  88.           lo *>obj>discard_output
  89.           lo *>obj>open_log
  90.           lo *>obj>match_file
  91.           lo *>obj>xfer_mode
  92.           lo *>obj>get_error_msg
  93.           lo *>obj>convert_file
  94.           li
  95.           rdc
  96.           nwc
  97.           &if ^ [null %compress%] &then ~
  98.           %compress%
  99.           map -undefined
  100.           file
  101.     &end
  102. /*
  103. &if ^ [null %como%] &then ~
  104.     como -e
  105. /*
  106. &stop
  107. /*
  108. &routine err
  109. /*
  110. type Error detected in Kermit build.
  111. /*
  112. &if ^ [null %como%] &then ~
  113.     como -e
  114. /*
  115. &stop
  116. /*
  117. &routine print_help
  118. /*
  119. type
  120. ~type '   Usage : CPL KERMIT.BUILD  [-Compile [path_name]]  [-Load]  [-Rebuild]'
  121. ~type '                             [-COMO [como_file]]  [-NO_Compress]  [-Help]'
  122. type
  123. type '           Where "path_name" is a Kermit source file path name which'
  124. type '           defaults to "*>SOURCE>@.PLP", and "como_file" is a COMO path'
  125. type '           name which defaults to "*>KERMIT.BUILD.COMO".'
  126. type
  127. /*
  128. &return
  129. -------------------------------------------------------------------------------
  130.  
  131. /* COMMON.INS.PLP -- Variables held in common storage for Kermit. */
  132.  
  133. %nolist;
  134.  
  135. %Replace max_msg by 100,
  136.          max_msg_less1 by 99,
  137.          max_matches by 100,
  138.          max_rem_pad_chrs by 255,
  139.          ibuffer_size by 1024,
  140.          ibuffer_size_wds by 512,
  141.          max_take_level by 25;
  142.  
  143.                      /* Message variables. */
  144.  
  145. Dcl snd_msg char (max_msg) var external,
  146.     msg_number fixed bin external,
  147.  
  148.     rec_msg char (max_msg) var external,
  149.     rec_pkt_type char (1) aligned external,   /* Type of message received. */
  150.     rec_seq fixed bin external,
  151.     rec_length fixed bin external,
  152.  
  153.     rec_file_size fixed bin (31) external,    /* Received file attributes. */
  154.     rec_file_dtc fixed bin (31) external,
  155.     rec_file_type fixed bin external,
  156.     use_attributes bit (1) aligned external,  /* Do we use the attributes ? */
  157.  
  158.     1 msg_table external,           /* Packet table for windowing. */
  159.       2 slot (0 : 63),
  160.         3 msg char (max_msg) var,
  161.         3 acked bit (1) aligned,
  162.         3 retries fixed bin,
  163.  
  164.     tab_first fixed bin external,       /* First msg in the table. */
  165.     tab_next fixed bin external;        /* Position of next msg. */
  166.  
  167.                /* File transfer status variables. */
  168.  
  169. Dcl state fixed bin external,              /* Current state. */
  170.     delay fixed bin external,              /* Amount of time to delay. */
  171.     num_retries fixed bin external,        /* Number of retries. */
  172.     quote8_char char (1) external,         /* 8-bit quoting character. */
  173.     file_type fixed bin external,          /* File storage type. */
  174.     explicit_ft_set bit (1) aligned external, /* File type has been set. */
  175.     first_read bit (1) aligned external,   /* First read of the data. */
  176.     filename_warning bit (1) aligned external, /* File re-naming warning. */
  177.     do_repeats bit (1) aligned external,   /* TRUE if repeat processing. */
  178.     do_windowing bit (1) aligned external, /* TRUE when windowing. */
  179.     do_transparent bit (1) aligned external, /* TRUE when transparent. */
  180.     do_flush bit (1) aligned external,     /* Flush rcv buffer when sending. */
  181.     do_8bit_chks bit (1) aligned external, /* TRUE for none parity. */
  182.     auto_sum bit (1) aligned external,     /* Try 7 and 8-bit checksums. */
  183.     log_opened bit (1) aligned external,   /* Log file opened. */
  184.     log_unit fixed bin external,           /* Log file unit. */
  185.     window_size fixed bin external,        /* Transmission window size. */
  186.     errmsg char (128) var external,        /* Error message buffer. */
  187.  
  188.     timeout label external,                /* Return point on timeout. */
  189.     brk_lbl label external,                /* Return point on break. */
  190.     ren_lbl label external,                /* Return point on re-enter. */
  191.  
  192.     take_level fixed bin external,         /* Current number of TAKE files open. */
  193.     take_unit (max_take_level) fixed bin external; /* TAKE file units used. */
  194.  
  195.                      /* Local parameters. */
  196.  
  197. Dcl loc_pkt_size fixed bin external,        /* Receive packet size. */
  198.     loc_npad fixed bin external,            /* Padding length. */
  199.     loc_padchar char (1) external,          /* Padding character. */
  200.     loc_timeout fixed bin external,         /* Time out. */
  201.     loc_eol char (1) external,              /* Eol character. */
  202.     loc_quote_chr char (1) external,        /* Quote character. */
  203.     loc_8quote_chr char (1) external,       /* 8-bit quoting character. */
  204.     loc_chk_type char (1) external,         /* Checksum type. */
  205.     loc_rep_chr char (1) external,          /* Repeat character. */
  206.     loc_capas1 fixed bin external,          /* Capabilities byte 1. */
  207.     loc_file_attrib bit (1) aligned external, /* Ability to rcv attributes. */
  208.     loc_windowing bit (1) aligned external, /* Ability to do windowing. */
  209.     loc_max_wsize fixed bin external;       /* Max window size. */
  210.  
  211.                     /* Remote parameters. */
  212.  
  213. Dcl rem_pkt_size fixed bin external,        /* Send packet size. */
  214.     rem_npad fixed bin external,            /* Padding length. */
  215.     rem_padchar char (1) external,          /* Padding character. */
  216.     rem_pad_chars char (max_rem_pad_chrs) external, /* String of padding characters. */
  217.     rem_timeout fixed bin external,         /* Time out. */
  218.     rem_eol char (1) external,              /* Eol character. */
  219.     rem_quote_chr char (1) external,        /* Quote character. */
  220.     rem_8quote_chr char (1) external,       /* 8-bit quoting character. */
  221.     rem_chk_type char (1) external,         /* Checksum type. */
  222.     rem_rep_chr char (1) external,          /* Repeat character. */
  223.     rem_capas1 fixed bin external,          /* Capabilities byte 1. */
  224.     rem_file_attrib bit (1) aligned external, /* Ability to rcv attributes. */
  225.     rem_windowing bit (1) aligned external, /* Ability to do windowing. */
  226.     rem_max_wsize fixed bin external;       /* Max window size. */
  227.  
  228.                     /* User Interface. */
  229.  
  230. Dcl kversion char (32) var external,
  231.     kprompt char (32) var external,
  232.     uppercase char (26) static external init ('ABCDEFGHIJKLMNOPQRSTUVWXYZ'),
  233.     lowercase char (26) static external init ('abcdefghijklmnopqrstuvwxyz');
  234.  
  235.                     /* File Variables. */
  236.  
  237. Dcl path_name char (128) var external,       /* Current path name. */
  238.     dir_name char (128) var external,        /* Current directory name. */
  239.     non_null_dir bit (1) aligned external,   /* Directory name is not null ? */
  240.     file_name char (32) var external,        /* Current file name. */
  241.     alternate_fname char (32) var external,  /* Alternate file name. */
  242.     file_unit fixed bin external,            /* File unit. */
  243.     file_opened bit (1) aligned external,    /* Flag for open files. */
  244.     file_len fixed bin (31) external,        /* File length (bytes). */
  245.     file_pos fixed bin (31) external,        /* File position (bytes). */
  246.  
  247.     matches(max_matches) char (128) var external, /* Pathname list. */
  248.     num_matches fixed bin external,          /* Number matches found. */
  249.     file_idx fixed bin external,             /* Index into matches. */
  250.  
  251.     del_incomplete bit (1) aligned external, /* Delete incomplete files. */
  252.     ibuffer char (ibuffer_size) external,    /* Intermediate file buffer. */
  253.     ibuffer_ptr ptr external,                /* Pointer to int_buffer. */
  254.     ibuflen fixed bin external,              /* Length of int_buffer. */
  255.     ibuf_ptr fixed bin external,             /* Pointer into int_buffer. */
  256.     eol_flag fixed bin external,             /* Detector for cr lf seqs. */
  257.     char2 (2) char (1) unal external,        /* Two character buffer. */
  258.     char2_ptr ptr external,                  /* And its pointer. */
  259.     pound_conversion bit (1) aligned external, /* Convert DOS pound signs. */
  260.     explicit_pound_set bit (1) aligned external, /* True if SET POUND used. */
  261.     trans_char (0 : 255) char (3) var external; /* Translation table. */
  262.  
  263.                       /* User Environment. */
  264.  
  265. Dcl my_msg_state fixed bin external,
  266.     my_duplex bit (16) aligned external,
  267.     my_erase char (2) external,
  268.     my_kill char (2) external;
  269.  
  270.                        /* Character codes. */
  271.  
  272. Dcl nul_7bit_asc char (1) external,
  273.     nul_8bit_asc char (1) external,
  274.     ctrl_a_7bit_asc char (1) external,
  275.     ctrl_a_8bit_asc char (1) external,
  276.     bs_7bit_asc char (1) external,
  277.     cr_7bit_asc char (1) external,
  278.     cr_8bit_asc char (1) external,
  279.     lf_7bit_asc char (1) external,
  280.     lf_8bit_asc char (1) external,
  281.     ff_7bit_asc char (1) external,
  282.     dc1_8bit_asc char (1) external,
  283.     ctrl_z_7bit_asc char (1) external,
  284.     ctrl_z_8bit_asc char (1) external,
  285.     query_7bit_asc char (1) external,
  286.     grave_7bit_asc char (1) external;
  287.  
  288. %list;
  289.  
  290. /* End of COMMON.INS.PLP */
  291. -------------------------------------------------------------------------------
  292.  
  293. /* CONSTANTS.INS.PLP -- Constant values used by KERMIT. */
  294.  
  295. %nolist;
  296.  
  297. %Replace                                 /* Protocol states. */
  298.  
  299.     state_s by 1,                        /* Send init state. */
  300.     state_sf by 2,                       /* Send file header. */
  301.     state_sd by 3,                       /* Send file data packet. */
  302.     state_sz by 4,                       /* Send EOF packet. */
  303.     state_sb by 5,                       /* Send break. */
  304.     state_r by 6,                        /* Receive send_init. */
  305.     state_rf by 7,                       /* Receive file header packet. */
  306.     state_rd by 8,                       /* Receive file data packet. */
  307.     state_x by 9,                        /* Text send init. */
  308.     state_xf by 10,                      /* Text header. */
  309.     state_c by 11,                       /* Send complete. */
  310.     state_a by 12,                       /* Abort. */
  311.     state_ra by 13,                      /* Receive attributes. */
  312.     state_sa by 14,                      /* Send attributes. */
  313.     state_rdw by 15,                     /* Rec data windowing. */
  314.     state_sdw by 16;                     /* Send data windowing. */
  315.  
  316. %Replace                                 /* Status codes. */
  317.  
  318.     ker_normal by 0,
  319.     ker_internalerr by 1,
  320.     ker_eof by 2,
  321.     ker_nomorfiles by 3,
  322.     ker_illfiltyp by 4,
  323.     ker_exit by 5,
  324.     ker_unimplgen by 6,
  325.     ker_protoerr by 7;
  326.  
  327. %Replace                                 /* Message constants. */
  328.  
  329.     pkt_count by 2,                      /* <CHAR(Count)> */
  330.     pkt_seq by 3,                        /* <CHAR(Seq)> */
  331.     pkt_type by 4,                       /* <Message type> */
  332.     pkt_msg by 5,                        /* <MESSAGE-DEPENDENT INFORMATION> */
  333.  
  334.     pkt_ovr_head by 3,                   /* Overhead added to data length. */
  335.     pkt_tot_ovr_head by 6;               /* Total overhead of the message. */
  336.  
  337. %Replace                                 /* Message types. */
  338.  
  339.     msg_data by 'D',                     /* Data packet. */
  340.     msg_attrib by 'A',                   /* File attributes. */
  341.     msg_ack by 'Y',                      /* Acknowledgement. */
  342.     msg_nak by 'N',                      /* Negative acknowledgement. */
  343.     msg_snd_init by 'S',                 /* Send initiate. */
  344.     msg_break by 'B',                    /* Break transmission. */
  345.     msg_file by 'F',                     /* File header. */
  346.     msg_eof by 'Z',                      /* End of file (EOF). */
  347.     msg_error by 'E',                    /* Error. */
  348.     msg_rcv_init by 'R',                 /* Receive initiate. */
  349.     msg_host_command by 'C',             /* Host command. */
  350.     msg_text by 'X',                     /* Plain Text. */
  351.     msg_init_info by 'I',                /* Initialize parameters. */
  352.     msg_kermit by 'K',                   /* Interactive KERMIT command. */
  353.     msg_kermit_generic by 'G',           /* Generic KERMIT command. */
  354.     msg_timeout by 'T',                  /* Timeout. */
  355.     msg_check_err by 'Q';                /* Checksum error. */
  356.  
  357. %Replace                                 /* Generic commands. */
  358.  
  359.     msg_gen_login by 'I',                /* Login. */
  360.     msg_gen_finish by 'F',               /* Finish (exit to OS). */
  361.     msg_gen_cwd by 'C',                  /* Change Working Directory. */
  362.     msg_gen_logout by 'L',               /* Logout. */
  363.     msg_gen_directory by 'D',            /* List the directory. */
  364.     msg_gen_disk_usage by 'U',           /* Disk usage. */
  365.     msg_gen_delete by 'E',               /* Delete a file. */
  366.     msg_gen_type by 'T',                 /* Type a file. */
  367.     msg_gen_rename by 'R',               /* Rename file. */
  368.     msg_gen_copy by 'K',                 /* Copy file. */
  369.     msg_gen_program by 'P',              /* Program invocation. */
  370.     msg_gen_who by 'W',                  /* Who's logged in. */
  371.     msg_gen_send by 'M',                 /* Send a message to a user. */
  372.     msg_gen_help by 'H',                 /* Help. */
  373.     msg_gen_query by 'Q',                /* Query status. */
  374.     msg_gen_journal by 'J',              /* Transaction Journal. */
  375.     msg_gen_variable by 'V';             /* Set/Read Variables. */
  376.  
  377. /*
  378.  *                    INITIALIZATION PACKET FORMAT.
  379.  *
  380.  *           The following describes the send initiate packet.
  381.  *           All fields in the message data area are optional.
  382.  *
  383.  * <"S"><CHAR(Bufsiz)><CHAR(Timeout)><CHAR(npad)><CTL(pad)><CHAR(Eol)><Quote>
  384.  *       <8-bit-quote><Repeat><Reserved><Reserved><Reserved>
  385.  *
  386.  * Bufsiz
  387.  *       Sending Kermit's maximum buffer size.
  388.  *
  389.  * Timeout
  390.  *       Number of seconds after which the sending Kermit wishes to be timed out.
  391.  *
  392.  * Npad
  393.  *       Number of padding characters the sending Kermit needs before each packet.
  394.  *
  395.  * PAD
  396.  *       Padding character.
  397.  *
  398.  * EOL
  399.  *       A line terminator required on all packets set by the receiving Kermit.
  400.  *
  401.  * Quote
  402.  *       The printable ASCII character the sending Kermit will use when quoting
  403.  *       the control characters. Default is "#".
  404.  *
  405.  * 8-bit-quote
  406.  *       Specify quoting mechanism for 8-bit quantities. A quoting mechanism is
  407.  *       necessary when sending to hosts which prevent the use of the 8th bit
  408.  *       for data. When elected, the quoting mechanism will be used by both
  409.  *       hosts, and the quote character must be in the range of 41-76 or 140-176
  410.  *       octal, but different from the control-quoting character. This field is
  411.  *       interpreted as follows :
  412.  *
  413.  *       "Y" - I agree to 8-bit quoting if you request it,
  414.  *       "N" - I will not do 8-bit quoting,
  415.  *       "&" - (or any other character in the range of 41-76 or 140-176) I want
  416.  *             to do 8-bit quoting using this character (it will be done if the
  417.  *             other Kermit puts a "Y" in this field),
  418.  *       Anything else : Quoting will not be done.
  419.  *
  420.  * Repeat
  421.  *       A printable ASCII character for compressing repeated characters.
  422.  *       The default is "~". A " " means no repeat character processing, also
  423.  *       it will only be done if both sides request it with the same character.
  424.  */
  425.  
  426. %Replace                                 /* Positions within the packet. */
  427.  
  428.     p_si_bufsiz by 0,                    /* Buffer size. */
  429.     p_si_timout by 1,                    /* Time out. */
  430.     p_si_npad by 2,                      /* Number of padding characters. */
  431.     p_si_pad by 3,                       /* Padding character. */
  432.     p_si_eol by 4,                       /* End of line character. */
  433.     p_si_quote by 5,                     /* Quoting character. */
  434.     p_si_8quote by 6,                    /* 8-bit quoting character. */
  435.     p_si_chk by 7,                       /* Checksum type. */
  436.     p_si_rep by 8,                       /* Repeat character. */
  437.     p_si_capas by 9;                     /* Capabilities. */
  438.  
  439. %Replace                                 /* My default initialization values. */
  440.  
  441.     my_pkt_size by 94,                   /* My packet size. */
  442.     my_timeout by 15,                    /* My time out. */
  443.     my_npad by 0,                        /* Amount of padding I require. */
  444.     my_pad_chr by '00'b4,                /* My pad character. */
  445.     my_eol_chr by '8D'b4,                /* My EOL character. <CR> */
  446.     my_quote_chr by '#',                 /* My quoting character. */
  447.     my_8quote_chr by '&',                /* My 8-bit quote character. */
  448.     my_chk_type by '1',                  /* My checksum type => single char. */
  449.     my_rep_chr by '~',                   /* My repeat character prefix. */
  450.     my_capas1 by '0C'b4,                 /* My capabilities => attr. + windows. */
  451.     my_max_wsize by 16;                  /* My maximum window size. */
  452.  
  453. %Replace                                 /* File types. */
  454.  
  455.     automatic_ft by -1,                  /* AUTOMATIC file type detection. */
  456.     illegal_ft by 0,                     /* An ILLEGAL file type. */
  457.     ascii_ft by 1,                       /* ASCII/TEXT files. */
  458.     binary_ft by 2;                      /* BINARY/IMAGE files. */
  459.  
  460. %Replace                                 /* Miscellaneous values. */
  461.  
  462.     true by '1'b,                        /* Logical .TRUE. */
  463.     false by '0'b,                       /* Logical .FALSE. */
  464.     init_delay by 5,                     /* Initial delay time. */
  465.     max_retries by 5,                    /* Maximum number of retries. */
  466.     bignum by 2147483647,                /* The biggest fixed bin number. */
  467.  
  468.     ctrl_a_7bit_dec by '01'b4,           /* Control-A */
  469.     ctrl_a_8bit_dec by '81'b4,
  470.     cr_7bit_dec by '0D'b4,               /* Carriage Return */
  471.     cr_8bit_dec by '8D'b4,
  472.     lf_7bit_dec by '0A'b4,               /* Line Feed */
  473.     lf_8bit_dec by '8A'b4,
  474.  
  475.     query_8bit_asc by '?',
  476.     grave_8bit_asc by '`';
  477.  
  478. %list;
  479.  
  480. /* End of CONSTANTS.INS.PLP */
  481. -------------------------------------------------------------------------------
  482.  
  483. /* PRIMOS.INS.PLP -- Declarations for PRIMOS subroutines and the directory entries. */
  484.  
  485. %nolist;
  486.  
  487. Dcl at$ entry (fixed bin, char (*) var, fixed bin),
  488.     at$hom entry (fixed bin),
  489.     at$or entry (fixed bin, fixed bin),
  490.     c1in entry (fixed bin),
  491.     cl$get entry (char (*) var, fixed bin, fixed bin),
  492.     cl$pix entry (bit (16) aligned, char (*) var, ptr, fixed bin, char (*) var,
  493.                   ptr, fixed bin, fixed bin, fixed bin),
  494.     clo$fu entry (fixed bin, fixed bin),
  495.     cnam$$ entry (char (*), fixed bin, char (*), fixed bin, fixed bin, fixed bin),
  496.     cnin$ entry (char (*), fixed bin, fixed bin),
  497.     comi$$ entry (char (*), fixed bin, fixed bin, fixed bin),
  498.     comlv$ entry,
  499.     cv$dtb entry (char (*) var, fixed bin (31), fixed bin),
  500.     cv$fda entry (fixed bin (31), fixed bin, char (21)),
  501.     dir$rd entry (fixed bin, fixed bin, ptr, fixed bin, fixed bin),
  502.     duplx$ entry (bit (16) aligned) returns (bit (16) aligned),
  503.     ent$rd entry (fixed bin, char (*) var, ptr, fixed bin, fixed bin),
  504.     erkl$$ entry (fixed bin, char (2), char (2), fixed bin),
  505.     ertxt$ entry (fixed bin, char (*) var),
  506.     fil$dl entry (char (*) var, fixed bin),
  507.     fnchk$ entry (fixed bin, char (*) var) returns (bit (1) aligned),
  508.     gpath$ entry (fixed bin, fixed bin, char (128), fixed bin, fixed bin, fixed bin),
  509.     ioa$ entry options (variable),
  510.     ioa$rs entry options (variable),
  511.     limit$ entry (fixed bin, fixed bin (31), fixed bin, fixed bin),
  512.     logo$$ entry (fixed bin, fixed bin, char (*), fixed bin, fixed bin (31), fixed bin),
  513.     mgset$ entry (fixed bin, fixed bin),
  514.     mkonu$ entry (char (*) var, entry) options (shortcall (20)),
  515.     msg$st entry (fixed bin, fixed bin, char (*), fixed bin, char (*), fixed bin, fixed bin),
  516.     prwf$$ entry (fixed bin, fixed bin, ptr options (short), fixed bin,
  517.                   fixed bin (31), fixed bin, fixed bin),
  518.     q$read entry (char (*) var, (4) fixed bin (31), fixed bin, fixed bin, fixed bin),
  519.     rdlin$ entry (fixed bin, char (*), fixed bin, fixed bin),
  520.     satr$$ entry (fixed bin, char (*), fixed bin, fixed bin (31), fixed bin),
  521.     sleep$ entry (fixed bin (31)),
  522.     smsg$ entry (fixed bin, char (32), fixed bin, fixed bin, char (*),
  523.                  fixed bin, char (*), fixed bin, (4) fixed bin),
  524.     srch$$ entry (fixed bin, char (*), fixed bin, fixed bin, fixed bin, fixed bin),
  525.     srsfx$ entry (fixed bin, char (*) var, fixed bin, fixed bin, fixed bin,
  526.                   char (*) var, char (*) var, fixed bin, fixed bin),
  527.     tnchk$ entry (fixed bin, char (*) var) returns (bit (1) aligned),
  528.     tnou entry (char (*), fixed bin),
  529.     tnoua entry (char (*), fixed bin),
  530.     tonl entry,
  531.     tty$in entry returns (bit (1) aligned),
  532.     tty$rs entry (fixed bin, fixed bin),
  533.     uid$bt entry (char (6) aligned),
  534.     uid$ch entry (char (6) aligned, char (13)),
  535.     user$ entry (fixed bin, fixed bin),
  536.     wild$ entry (char (*) var, char (*) var, fixed bin) returns (bit (1) aligned),
  537.     wtlin$ entry (fixed bin, char (*), fixed bin, fixed bin);
  538.  
  539. %Replace dir_entry_size by 37;   /* Correct size at PRIMOS revision 22.0.1a. */
  540.  
  541. Dcl dir_entry_ptr ptr external;  /* Pointer to the following structure. */
  542.  
  543. Dcl 1 dir_entry external,        /* PRIMOS directory entry structure. */
  544.       2 ecw,
  545.         3 type bit (8),
  546.         3 len bit (8),
  547.       2 entryname char (32),
  548.       2 pw_protection bit (16) aligned,
  549.       2 non_dflt_protection bit (1) aligned,
  550.       2 file_info,
  551.         3 (long_rat_hdr, dumped, dos_mod, special) bit (1),
  552.         3 rwlock bit (2),
  553.         3 pad1 bit (2),
  554.         3 type bit (8),
  555.       2 dtm,
  556.         3 date,
  557.           4 year bit (7),
  558.           4 month bit (4),
  559.           4 day bit (5),
  560.         3 time fixed bin,
  561.       2 spare (2) fixed bin,
  562.       2 trunc bit (1) aligned,
  563.       2 (dtb, dtc, dta) fixed bin (31),
  564.       2 bra fixed bin (31),
  565.       2 fileid char (8);
  566.  
  567. %list;
  568.  
  569. /* End of PRIMOS.INS.PLP */
  570. -------------------------------------------------------------------------------
  571.  
  572. /* KERMIT.INS.PLP -- Declarations for KERMIT subroutines,
  573.                      Utilities, and some based variables. */
  574.  
  575. %nolist;
  576.  
  577. Dcl ack_send_init entry,
  578.     bk_hndlr entry (ptr),
  579.     change_dir entry (char (128) var, fixed bin),
  580.     chks entry (fixed bin, char (*) var) returns (fixed bin),
  581.     close_input entry,
  582.     close_output entry returns (fixed bin),
  583.     comnd entry,
  584.     convert_file entry returns (fixed bin),
  585.     discard_output entry (fixed bin),
  586.     generic_cmd entry returns (fixed bin),
  587.     get_attr entry,
  588.     get_dtc entry returns (char (32) var),
  589.     get_error_msg entry (fixed bin),
  590.     get_len entry returns (fixed bin),
  591.     log_info entry (char (256) var),
  592.     log_packet entry (char (1), fixed bin, char (*) var),
  593.     match_file entry returns (fixed bin),
  594.     kermit_init entry,
  595.     next_file entry returns (fixed bin),
  596.     open_input entry returns (fixed bin),
  597.     open_log entry (char (128) var) returns (fixed bin),
  598.     open_output entry returns (fixed bin),
  599.     prs_send_init entry,
  600.     read_input entry (fixed bin) returns (fixed bin),
  601.     rec_packet entry,
  602.     rec_switch entry,
  603.     ren_hndlr entry (ptr),
  604.     send_packet entry (char (1), fixed bin, fixed bin),
  605.     send_switch entry,
  606.     server entry,
  607.     set_params entry,
  608.     set_path entry (char (128) var),
  609.     setup_trans_char entry,
  610.     timeout_hndlr entry (ptr),
  611.     write_ibuf entry (fixed bin, fixed bin),
  612.     write_output entry returns (fixed bin),
  613.     xfer_mode entry (fixed bin, fixed bin);
  614.  
  615.                     /* Kermit utilities. */
  616.  
  617. Dcl between entry (fixed bin, fixed bin, fixed bin) returns (bit (1) aligned),
  618.     clr8 entry (char (1)) returns (char (1)),
  619.     clr8str entry (char (*) var) returns (char (1024) var),
  620.     ctl entry (char (1)) returns (char (1)),
  621.     knum entry (char (1)) returns (fixed bin),
  622.     set8 entry (char (1)) returns (char (1)),
  623.     set8str entry (char (*) var) returns (char (1024) var);
  624.  
  625.                     /* Based variables. */
  626.  
  627. Dcl fb15_based fixed bin (15) based,
  628.     fb31_based fixed bin (31) based,
  629.     char1_based char (1) based,
  630.     char2_based char (2) based,
  631.     bit8_based bit (8) aligned based,
  632.     bit16_based bit (16) aligned based,
  633.  
  634.     1 capas based,                     /* Capability structure. */
  635.       2 rsv2 bit (12),
  636.       2 file_attributes bit (1),
  637.       2 windowing bit (1),
  638.       2 rsv1 bit (1),
  639.       2 continues bit (1);
  640.  
  641. %list;
  642.  
  643. /* End of KERMIT.INS.PLP */
  644. -------------------------------------------------------------------------------
  645.  
  646. /* ACK_SEND_INIT -- Setup our SND_INIT packet to send to other Kermit. */
  647.  
  648. Ack_send_init : proc;
  649.  
  650. $Insert *>insert>common.ins.plp
  651. $Insert *>insert>kermit.ins.plp
  652. $Insert *>insert>constants.ins.plp
  653.  
  654. Dcl (eol_bin, temp) fixed bin,
  655.     eol char (1),
  656.     capa_ptr ptr;
  657.  
  658. /* ************************************************************************* */
  659.  
  660.    call prs_send_init;       /* Extract the fields from the init packet. */
  661.  
  662.    capa_ptr = addr (loc_capas1);      /* Set parameters for file transfer. */
  663.    loc_file_attrib = capa_ptr -> capas.file_attributes;
  664.    loc_windowing = capa_ptr -> capas.windowing;
  665.  
  666.    call set_params;
  667.  
  668.    /* Build our ACK packet. */
  669.  
  670.    char2(1) = nul_7bit_asc;
  671.    char2(2) = loc_eol;
  672.    char2_ptr -> fb15_based = char2_ptr -> fb15_based + 32;  /* Set the printable bit. */
  673.    eol = char2(2);
  674.  
  675.    eol_bin = loc_pkt_size + 32;
  676.    temp = loc_timeout + 32;
  677.  
  678.    snd_msg = substr (addr (eol_bin) -> char2_based, 2, 1) ||
  679.              substr (addr (temp) -> char2_based, 2, 1);
  680.  
  681.    eol_bin = loc_npad + 32;
  682.    temp = loc_capas1 + 32;
  683.  
  684.    snd_msg = snd_msg || substr (addr (eol_bin) -> char2_based, 2, 1) ||
  685.              ctl (loc_padchar) || eol || loc_quote_chr ||
  686.              quote8_char || loc_chk_type || loc_rep_chr ||
  687.              substr (addr (temp) -> char2_based, 2, 1);
  688.  
  689.    temp = loc_max_wsize + 32;
  690.    snd_msg = snd_msg || substr (addr (temp) -> char2_based, 2, 1);
  691.  
  692.    call send_packet (msg_ack, length (snd_msg), rec_seq); /* Send the packet. */
  693.  
  694.    return;
  695.  
  696.    end;       /* Ack_send_init */
  697. -------------------------------------------------------------------------------
  698.  
  699. /* BK_HNDLR -- Break handler for Kermit. */
  700.  
  701. Bk_hndlr : proc (point);
  702.  
  703. Dcl point ptr;
  704.  
  705. $Insert *>insert>common.ins.plp
  706. $Insert *>insert>kermit.ins.plp
  707. $Insert *>insert>primos.ins.plp
  708. $Insert *>insert>constants.ins.plp
  709.  
  710. Dcl code fixed bin;
  711.  
  712. /* ************************************************************************* */
  713.  
  714.    call limit$ ('0602'b4, 0, 0, code);    /* Turn off watchdog timer. */
  715.  
  716.    call log_info ('.BREAK. received!');       /* Log the break. */
  717.  
  718.    call xfer_mode (0, code);            /* Reset the user's environment. */
  719.  
  720.    call tnou ('QUIT.',5);
  721.  
  722.    goto brk_lbl;
  723.  
  724.    end;      /* Bk_hndlr */
  725. -------------------------------------------------------------------------------
  726.  
  727. /* CHANGE_DIR -- Change current directory. */
  728.  
  729. Change_dir : proc (treename, code);
  730.  
  731. Dcl treename char (128) var,
  732.     code fixed bin;
  733.  
  734. $Insert *>insert>common.ins.plp
  735. $Insert *>insert>primos.ins.plp
  736. $Insert syscom>keys.ins.pl1
  737.  
  738. Dcl pathlen fixed bin,
  739.     new_dir char (128);
  740.  
  741. /* ************************************************************************* */
  742.  
  743.    code = 0;
  744.  
  745.    if treename = '' then     /* Attach to the origin if no treename given. */
  746.       do;
  747.          call at$or (k$seth, code);
  748.          if code = 0 then
  749.             snd_msg = 'Now in your origin directory.';
  750.       end;
  751.    else
  752.       do;
  753.          call at$ (k$seth, treename, code);   /* Don't forget we may have had */
  754.          if code = 0 then             /* passwords, so we can't use SET_PATH. */
  755.             do;
  756.                if substr (treename, 1, 2) = '*>' then
  757.                   do;                   /* Find out where we are! */
  758.                      call gpath$ (k$homa, 0, new_dir, 128, pathlen, code);
  759.                      if code = 0 then
  760.                         treename = substr (new_dir, 1, pathlen);
  761.                      else
  762.                         code = 0;          /* We do this for later. */
  763.                   end;
  764.  
  765.                snd_msg = 'Now in directory ' || before (treename, ' ') || '.';
  766.             end;
  767.       end;
  768.  
  769.    return;
  770.  
  771.    end;       /* Change_dir */
  772. -------------------------------------------------------------------------------
  773.  
  774. /* CHKS -- Subroutine to compute Kermit checksum. */
  775.  
  776. Chks : proc (key, str) returns (fixed bin);
  777.  
  778. Dcl key fixed bin,
  779.     str char (96) var;
  780.  
  781. $Insert *>insert>constants.ins.plp
  782.  
  783. Dcl topbyte bit (1) aligned,
  784.     str_ptr ptr,
  785.     (i, str_len, total, word_index) fixed bin;
  786.  
  787. Dcl 1 non_trans_data (1) based,
  788.       2 a1skip bit (1),
  789.       2 a1 bit (7),
  790.       2 a2skip bit (1),
  791.       2 a2 bit (7);
  792.  
  793. Dcl 1 trans_data (1) based,
  794.       2 a1 bit (8),
  795.       2 a2 bit (8);
  796.  
  797. Dcl 1 checksum_format based,
  798.       2 s1 bit (8),
  799.       2 s2 bit (2),
  800.       2 s3 bit (6);
  801.  
  802. /* ************************************************************************* */
  803.  
  804.    topbyte = false;   /* Skip first char (mark), take low order byte. */
  805.    word_index = 2;    /* Word index into char var string (skip length). */
  806.    total = 0;
  807.    str_len = length (str);
  808.    str_ptr = addr (str);
  809.  
  810.    do i = 2 to str_len;
  811.  
  812.       if topbyte then
  813.          do;
  814.             word_index = word_index + 1;
  815.  
  816.             if key = 1 then
  817.                total = total + str_ptr -> trans_data(word_index).a1;  /* Parity NONE, 8 bit data, transparent mode. */
  818.             else
  819.                total = total + str_ptr -> non_trans_data(word_index).a1;   /* 7 bit data, non-transparent mode. */
  820.          end;
  821.       else
  822.          if key = 1 then
  823.             total = total + str_ptr -> trans_data(word_index).a2;
  824.          else
  825.             total = total + str_ptr -> non_trans_data(word_index).a2;
  826.  
  827.       topbyte = ^topbyte;
  828.  
  829.    end;
  830.  
  831.    /* Compute checksum from total of character values,
  832.       (Add bits 6 - 7 to bits 0 - 5 then return 6-bit value). */
  833.  
  834.    total = total + addr (total) -> checksum_format.s2;
  835.    total = addr (total) -> checksum_format.s3;
  836.  
  837.    return (total);
  838.  
  839.    end;         /* Chks */
  840. -------------------------------------------------------------------------------
  841.  
  842. /* CLOSE_INPUT -- Close an input file. */
  843.  
  844. Close_input : proc;
  845.  
  846. $Insert *>insert>common.ins.plp
  847. $Insert *>insert>kermit.ins.plp
  848. $Insert *>insert>primos.ins.plp
  849. $Insert *>insert>constants.ins.plp
  850. $Insert syscom>errd.ins.pl1
  851.  
  852. Dcl code fixed bin;
  853.  
  854. /* ************************************************************************* */
  855.  
  856.    if ^explicit_ft_set then
  857.       file_type = automatic_ft;  /* Now we have finished, reset this. */
  858.  
  859.    if ^explicit_pound_set then   /* This may have changed for BINARY files. */
  860.       pound_conversion = true;
  861.  
  862.    if file_opened then
  863.       do;
  864.          call clo$fu (file_unit, code);
  865.          if code ^= 0 & code ^= e$unop then
  866.             do;
  867.                call get_error_msg (code);
  868.                snd_msg = 'Unable to close the input file on remote system. ' || errmsg;
  869.                call send_packet (msg_error, length (snd_msg), msg_number);
  870.             end;
  871.  
  872.          file_opened = false;
  873.  
  874.       end;
  875.  
  876.    return;
  877.  
  878.    end;       /* Close_input */
  879. -------------------------------------------------------------------------------
  880.  
  881. /* CLOSE_OUTPUT -- Close an output file. */
  882.  
  883. Close_output : proc returns (fixed bin);
  884.  
  885. $Insert *>insert>common.ins.plp
  886. $Insert *>insert>kermit.ins.plp
  887. $Insert *>insert>primos.ins.plp
  888. $Insert *>insert>constants.ins.plp
  889. $Insert syscom>keys.ins.pl1
  890. $Insert syscom>errd.ins.pl1
  891.  
  892. Dcl (code, code2) fixed bin;
  893.  
  894. /* ************************************************************************* */
  895.  
  896.    code = 0;
  897.  
  898.    if ^file_opened then
  899.       do;
  900.          rec_file_type = automatic_ft;
  901.          if ^explicit_ft_set then
  902.             file_type = automatic_ft;
  903.  
  904.          return (code);
  905.       end;
  906.  
  907.    call write_ibuf (1, code);        /* Write the buffer to the file first. */
  908.  
  909.    rec_file_type = automatic_ft;     /* We MUST do this before returning. */
  910.    if ^explicit_ft_set then
  911.       file_type = automatic_ft;
  912.  
  913.    if code ^= 0 then
  914.       return (code);
  915.  
  916.    call clo$fu (file_unit, code);
  917.  
  918.    if code = e$unop then
  919.       code = 0;
  920.  
  921.    if use_attributes & (rec_file_dtc ^= 0 & rec_file_dtc ^= -1) & code = 0 then
  922.       do;
  923.          code2 = 0;
  924.  
  925.          if non_null_dir then
  926.             call at$ (k$setc, dir_name, code2);
  927.  
  928.          if code2 = 0 then
  929.             call satr$$ (k$dtc, (file_name), length (file_name), rec_file_dtc, code2);
  930.  
  931.          if non_null_dir then
  932.             call at$hom (code2);
  933.  
  934.       end;
  935.  
  936.    file_opened = false;
  937.  
  938.    call set_path ('');
  939.  
  940.    return (code);
  941.  
  942.    end;       /* Close_output */
  943. -------------------------------------------------------------------------------
  944.  
  945. /* COMND -- Kermit command level processor. */
  946.  
  947. Comnd : proc;
  948.  
  949. $Insert *>insert>common.ins.plp
  950. $Insert *>insert>kermit.ins.plp
  951. $Insert *>insert>primos.ins.plp
  952. $Insert *>insert>constants.ins.plp
  953. $Insert syscom>keys.ins.pl1
  954. $Insert syscom>errd.ins.pl1
  955.  
  956. %Replace num_tokens by 3;
  957.  
  958. Dcl token (num_tokens) char (128) var,
  959.     (num_tok, command, prompt_len, i, code) fixed bin,
  960.     from_comi_hndlr bit (1) aligned,
  961.     kermit_state_ptr ptr,
  962.     (reenter, comi_eof) char (10) var,
  963.     cmd_option char (128) var,
  964.     prompt char (32) var,
  965.     cmd_buf char (160) var;
  966.  
  967. %Replace kermit_len by 16,
  968.          ambiguous_cmd by -1;
  969.  
  970. Dcl kermit_state (kermit_len) char (16) var static init (
  971.           'EXIT',
  972.           'HELP',
  973.           'QUIT',
  974.           'RECEIVE',
  975.           'SET',
  976.           'SEND',
  977.           'SERVER',
  978.           'SHOW',
  979.           'TAKE',
  980.           'VERSION',
  981.           'CONVERT',
  982.           'LOG',
  983.           'CLOSE',
  984.           'PUSH',
  985.           'STOP',
  986.           'POP');
  987.  
  988. %Replace cmd_exit by 1,
  989.          cmd_help by 2,
  990.          cmd_quit by 3,
  991.          cmd_receive by 4,
  992.          cmd_set by 5,
  993.          cmd_send by 6,
  994.          cmd_server by 7,
  995.          cmd_show by 8,
  996.          cmd_take by 9,
  997.          cmd_version by 10,
  998.          cmd_convert by 11,
  999.          cmd_log by 12,
  1000.          cmd_close by 13,
  1001.          cmd_push by 14,
  1002.          cmd_stop by 15,
  1003.          cmd_pop by 16;
  1004.  
  1005. %Replace show_len by 12;
  1006.  
  1007. Dcl show_state (show_len) char (16) var static init (
  1008.           'ALL',
  1009.           'DELAY',
  1010.           'PARITY',
  1011.           'QUOTE',
  1012.           '8QUOTE',
  1013.           'REPEAT',
  1014.           'WINDOW',
  1015.           'STORAGE_TYPE',
  1016.           'INCOMPLETE',
  1017.           'POUND',
  1018.           'ATTRIBUTES',
  1019.           'WARNING');
  1020.  
  1021. %Replace show_all by 1,
  1022.          show_delay by 2,
  1023.          show_parity by 3,
  1024.          show_quote by 4,
  1025.          show_8quote by 5,
  1026.          show_repeat by 6,
  1027.          show_wsize by 7,
  1028.          show_store by 8,
  1029.          show_incomplete by 9,
  1030.          show_pound by 10,
  1031.          show_attributes by 11,
  1032.          show_warning by 12;
  1033.  
  1034. /* ************************************************************************* */
  1035.  
  1036.    code = 0;
  1037.    from_comi_hndlr = false;
  1038.    prompt = kprompt || '> ';
  1039.    prompt_len = length (prompt);
  1040.    kermit_state_ptr = addr (kermit_state);
  1041.  
  1042.    reenter = 'REENTER$';
  1043.    ren_lbl = ren_point;
  1044.    call mkonu$ (reenter, ren_hndlr);
  1045.  
  1046.    comi_eof = 'COMI_EOF$';
  1047.    call mkonu$ (comi_eof, comi_hndlr);
  1048.  
  1049. Ren_point :
  1050.  
  1051.    do while (true);
  1052.  
  1053.       do until (((length (cmd_buf) ^= 0) & substr (cmd_buf, 1, 1) ^= ctrl_a_8bit_asc) | (code ^= 0));
  1054.          call tnoua ((prompt), prompt_len);
  1055.  
  1056. Comi_restart :
  1057.  
  1058.          call cl$get (cmd_buf, 160, code);
  1059.       end;
  1060.  
  1061.       if code ^= 0 then
  1062.          do;
  1063.             call get_error_msg (code);
  1064.             call ioa$ ('Error reading the command line. %v%.', 99, errmsg);
  1065.             return;
  1066.          end;
  1067.  
  1068.       call tokenize (cmd_buf);
  1069.       command = type (token(1), kermit_state_ptr, kermit_len);
  1070.       cmd_option = token(2);
  1071.  
  1072.       select (command);        /* Now process the command. */
  1073.  
  1074.          when (cmd_take)       /* TAKE input from a file. */
  1075.             if num_tok < 2 then
  1076.                call tnou ('No pathname given for TAKE command.', 35);
  1077.             else
  1078.                if cmd_option = 'TTY' | cmd_option = 'PAUSE' |
  1079.                   cmd_option = substr ('CONTINUE', 1, length (cmd_option)) then
  1080.                   call ioa$ ('The filename "%v" is NOT allowed for the TAKE command. %.',
  1081.                              99, cmd_option);
  1082.                else
  1083.                   if take_level + 1 > max_take_level then
  1084.                      call ioa$ ('You have reached the maximum number (%d) of nested TAKE files.%.', 99, max_take_level);
  1085.                   else
  1086.                      do;
  1087.                         i = get_unit (code);
  1088.                         if i > 0 then
  1089.                            call comi$$ ((cmd_option), length (cmd_option), i, code);
  1090.                         if code = 0 then
  1091.                            do;
  1092.                               take_level = take_level + 1;
  1093.                               take_unit(take_level) = i;
  1094.                            end;
  1095.                         else
  1096.                            do;
  1097.                               call get_error_msg (code);
  1098.                               call ioa$ ('Error opening file %v. %v%.', 99, cmd_option, errmsg);
  1099.                            end;
  1100.                      end;
  1101.  
  1102.          when (cmd_version)          /* Display the current VERSION number. */
  1103.             call tnou ((kversion), length (kversion));
  1104.  
  1105.          when (cmd_help)                /* Display HELP information. */
  1106.             call comnd_help;
  1107.  
  1108.          when (cmd_set)                 /* SET parameter. */
  1109.             if num_tok < 2 then
  1110.                call tnou ('No SET option specified.', 24);
  1111.             else
  1112.                call comnd_set;
  1113.  
  1114.          when (cmd_show)                /* SHOW parameter. */
  1115.             do;
  1116.                if num_tok < 2 then
  1117.                   cmd_option = 'ALL';
  1118.  
  1119.                call tonl;
  1120.                call comnd_show (type (cmd_option, addr (show_state), show_len));
  1121.                call tonl;
  1122.             end;
  1123.  
  1124.          when (cmd_server)               /* SERVER. */
  1125.             do;
  1126.                call xfer_mode (1, code);
  1127.                call tnou ('Kermit server started.', 22);
  1128.                call server;
  1129.                call xfer_mode (0, code);
  1130.                return;
  1131.             end;
  1132.  
  1133.          when (cmd_send)                 /* SEND. */
  1134.             if num_tok < 2 then
  1135.                call tnou ('No pathname(s) given for SEND command.', 38);
  1136.             else
  1137.                if tnchk$ (k$uprc + k$wldc, cmd_option) then
  1138.                   do;
  1139.                      call set_path (cmd_option);
  1140.                      state = state_s;
  1141.                      call xfer_mode (1, code);
  1142.                      call tnou ('Kermit send started.', 20);
  1143.                      call send_switch;
  1144.                      call xfer_mode (0, code);
  1145.                   end;
  1146.                else
  1147.                   call ioa$ ('Invalid SEND pathname(s) "%v".%.', 99, cmd_option);
  1148.  
  1149.          when (cmd_receive)              /* RECEIVE. */
  1150.             do;
  1151.                state = state_r;
  1152.                call set_path (cmd_option);
  1153.                call xfer_mode (1, code);
  1154.                call tnou ('Kermit receive started.', 23);
  1155.                call rec_switch;
  1156.                call xfer_mode (0, code);
  1157.             end;
  1158.  
  1159.          when (cmd_convert)              /* CONVERT a file. */
  1160.             if num_tok < 2 then
  1161.                call tnou ('No filename given for CONVERT command.', 38);
  1162.             else
  1163.                do;
  1164.                   call set_path (cmd_option);
  1165.                   code = convert_file ();
  1166.                   if code ^= 0 then
  1167.                      do;
  1168.                         call get_error_msg (code);
  1169.                         call ioa$ ('%v. %v%.', 99, snd_msg, errmsg);
  1170.                      end;
  1171.                   else
  1172.                      call ioa$ ('Conversion of file %v successful.%.', 99, cmd_option);
  1173.                end;
  1174.  
  1175.          when (cmd_log)                  /* LOG command. */
  1176.             if log_opened then
  1177.                call tnou ('Log file already opened.', 24);
  1178.             else
  1179.                do;
  1180.                   code = open_log (cmd_option);
  1181.                   if code ^= 0 then
  1182.                      do;
  1183.                         call get_error_msg (code);
  1184.                         call ioa$ ('Error opening log file. %v%.', 99, errmsg);
  1185.                      end;
  1186.                   else
  1187.                      call tnou ('Log file opened.', 16);
  1188.                end;
  1189.  
  1190.          when (cmd_close)                /* CLOSE the log file. */
  1191.             if log_opened then
  1192.                do;
  1193.                   log_opened = false;
  1194.                   call clo$fu (log_unit, code);
  1195.                   if code ^= 0 & code ^= e$unop then
  1196.                      do;
  1197.                         call get_error_msg (code);
  1198.                         call ioa$ ('Error closing the log file. %v%.', 99, errmsg);
  1199.                      end;
  1200.                   else
  1201.                      call tnou ('Log file closed.', 16);
  1202.                end;
  1203.             else
  1204.                call tnou ('Log file not opened.', 20);
  1205.  
  1206.          when (cmd_push)             /* PUSH to a new command level. */
  1207.             call comlv$;
  1208.  
  1209.          when (cmd_pop)
  1210.             if take_level > 0 then
  1211.                do;
  1212. Comi_point :
  1213.                   call comi$$ ('TTY', 3, take_unit(take_level), code);
  1214.  
  1215.                   take_unit(take_level) = 0;
  1216.                   take_level = take_level - 1;
  1217.  
  1218.                   if code = 0 then
  1219.                      if take_level > 0 then
  1220.                         do;
  1221.                            call comi$$ ('CONTINUE', 8, take_unit(take_level), code);
  1222.                            if code ^= 0 then
  1223.                               do;
  1224.                                  call get_error_msg (code);
  1225.                                  call ioa$ ('Unable to continue the previous TAKE file. %v%.', 99, errmsg);
  1226.                                  go to comi_point;
  1227.                               end;
  1228.                         end;
  1229.                      else
  1230.                         ;
  1231.                   else
  1232.                      do;
  1233.                         call get_error_msg (code);
  1234.                         call ioa$ ('Error closing the current TAKE file. %v%.', errmsg);
  1235.                      end;
  1236.  
  1237.                   if from_comi_hndlr then
  1238.                      do;
  1239.                         from_comi_hndlr = false;
  1240.                         go to comi_restart;
  1241.                      end;
  1242.  
  1243.                end;
  1244.  
  1245.          when (cmd_stop)
  1246.             if take_level > 0 then
  1247.                do;
  1248.                   call comi$$ ('TTY', 3, take_unit(take_level), code);  /* If this fails then the on-unit should catch EOF. */
  1249.                   take_unit(take_level) = 0;
  1250.  
  1251.                   take_level = take_level - 1;
  1252.                   do i = 1 to take_level;
  1253.                      call clo$fu (take_unit(i), code);
  1254.                      take_unit(i) = 0;
  1255.                   end;
  1256.  
  1257.                   take_level = 0;
  1258.                end;
  1259.  
  1260.          when (cmd_quit, cmd_exit)   /* EXIT to PRIMOS. */
  1261.             return;
  1262.  
  1263.          when (ambiguous_cmd)
  1264.             call ioa$ ('Ambiguous command "%v". Type HELP for a list of commands.%.',
  1265.                        99, token(1));
  1266.  
  1267.          otherwise
  1268.             call ioa$ ('Unrecognized command "%v". Type HELP for a list of commands.%.',
  1269.                        99, token(1));
  1270.  
  1271.       end;        /* select */
  1272.  
  1273.    end;        /* do while */
  1274.  
  1275.    return;
  1276.  
  1277. /* ******************************* Comnd_help ****************************** */
  1278.  
  1279. Comnd_help : proc;
  1280.  
  1281. Dcl ans char (16) var;
  1282.  
  1283. /* ************************************************************************* */
  1284.  
  1285.    call ioa$ ('%/Interactive mode commands : %/%.', 99);
  1286.    call ioa$ ('Commands may be abbreviated to those letters in uppercase.%/%.', 99);
  1287.    call ioa$ ('  Receive [pathname]                 Upload a file.%.', 99);
  1288.    call ioa$ ('  SENd wildcard                      Download file(s) using wildcards.%.', 99);
  1289.    call ioa$ ('  SERver                             Start Kermit server.%/%.', 99);
  1290.  
  1291.    call ioa$ ('  CLose                              Close the log file.%.', 99);
  1292.    call ioa$ ('  COnvert pathname                   Converts a file to PRIME ASCII.%.', 99);
  1293.    call ioa$ ('  Exit or Quit                       Leave Kermit.%.', 99);
  1294.    call ioa$ ('  Help                               Display this message.%.', 99);
  1295.    call ioa$ ('  Log [pathname]                     Start a log file. Default is KERMIT.LOG%.', 99);
  1296.    call ioa$ ('  POp                                Close the current TAKE file.%.', 99);
  1297.    call ioa$ ('  PUsh                               Return to PRIMOS, and may re-enter Kermit.%.', 99);
  1298.    call ioa$ ('  SHow [{parameter | ALL}]           Display the required parameter.%.', 99);
  1299.    call ioa$ ('  STop                               Close all TAKE files, and return to Kermit.%.', 99);
  1300.    call ioa$ ('  Take pathname                      Execute commands from a file.%.', 99);
  1301.    call ioa$ ('  Version                            Display the current version number.%/%.', 99);
  1302.  
  1303.    ans = '';
  1304.    call tnoua ('More ? ', 7);
  1305.    call cl$get (ans, 16, code);
  1306.    if code ^= 0 then
  1307.       do;
  1308.          call get_error_msg (code);
  1309.          call ioa$ ('Error reading the command line. %v%.', 99, errmsg);
  1310.          return;
  1311.       end;
  1312.  
  1313.    if length (ans) > 0 then
  1314.       ans = translate (substr (trim (ans, '11'b), 1, 1), uppercase, lowercase);
  1315.    if ans ^= 'Y' & ans ^= '' then
  1316.       return;
  1317.  
  1318.    call ioa$ ('%/  SET parameter                      Set one of the following parameters :%.', 99);
  1319.    call ioa$ ('      Attributes {ON | OFF}             Use the received file attributes. DTC%.', 99);
  1320.    call ioa$ ('%40xand file type are used. Default is ON.%.', 99);
  1321.    call ioa$ ('      Delay n                           Delay time in seconds before sending a%.', 99);
  1322.    call ioa$ ('%40xfile. Default is %d seconds.%.', 99, init_delay);
  1323.    call ioa$ ('      File_Type {AUTO | TEXT | BINARY}  Set the type of file(s) to be sent or%.', 99);
  1324.    call ioa$ ('%40xreceived. Default is AUTO.%.', 99);
  1325.    call ioa$ ('      Incomplete {SAVE | DELETE}        Keep or delete incompletely received%.', 99);
  1326.    call ioa$ ('%40xfiles. Default is DELETE.%.', 99);
  1327.    call ioa$ ('      PArity {MARK | NONE}              Set the character parity type.%.', 99);
  1328.    call ioa$ ('%40xDefault parity is MARK.%.', 99);
  1329.    call ioa$ ('      POUnd {ON | OFF}                  Sets the conversion of DOS pound%.', 99);
  1330.    call ioa$ ('%40xsigns. Default is ON.%.', 99);
  1331.    call ioa$ ('      Quote char                        Control quoting character to use.%.', 99);
  1332.    call ioa$ ('%40x("char" = ASCII printable character).%.', 99);
  1333.    call ioa$ ('      8Quote char                       8-bit quoting character to use.%.', 99);
  1334.    call ioa$ ('%40x("char" = ASCII grammatical character).%.', 99);
  1335.    call ioa$ ('      Repeat char                       Repeat character prefix to use.%.', 99);
  1336.    call ioa$ ('%40x("char" = ASCII printable character).%.', 99);
  1337.    call ioa$ ('      WArning {ON | OFF}                File name collision warning. Prevents%.', 99);
  1338.    call ioa$ ('%40xoverwriting of files. Default is ON.%.', 99);
  1339.    call ioa$ ('      WIndow n                          File transfer window size.%.', 99);
  1340.    call ioa$ ('%40x(0 <= "n" <= 31, 0 = no windowing).%.', 99);
  1341.  
  1342.    return;
  1343.  
  1344.    end;      /* Comnd_help */
  1345.  
  1346. /* ******************************* Comnd_show ****************************** */
  1347.  
  1348. Comnd_show : proc (option);
  1349.  
  1350. Dcl option fixed bin;
  1351.  
  1352. /* ************************************************************************* */
  1353.  
  1354.    select (option);
  1355.  
  1356.       when (show_all)
  1357.          do i = 2 to show_len;
  1358.             call comnd_show (i);
  1359.          end;
  1360.  
  1361.       when (show_delay)
  1362.          call ioa$ ('Time delay before sending a file is %d seconds.%.', 99, delay);
  1363.  
  1364.       when (show_parity)
  1365.          do;
  1366.             call tnoua ('Character parity I will use ......... ', 38);
  1367.             if do_transparent then
  1368.                call tnou ('NONE', 4);
  1369.             else
  1370.                call tnou ('MARK', 4);
  1371.          end;
  1372.  
  1373.       when (show_quote)
  1374.          call ioa$ ('Quoting character I will use ........ "%c"%.', 99, loc_quote_chr, 1);
  1375.  
  1376.       when (show_8quote)
  1377.          do;
  1378.             call ioa$ ('8-Bit quoting character I want to use "%c"%$', 99, loc_8quote_chr, 1);
  1379.             if loc_8quote_chr = 'N' then
  1380.                call tnou ('   (No 8-bit quoting.)', 22);
  1381.             else
  1382.                call tonl;
  1383.          end;
  1384.  
  1385.       when (show_repeat)
  1386.          do;
  1387.             call ioa$ ('Repeat character prefix I want to use "%c"%$', 99, loc_rep_chr, 1);
  1388.             if loc_rep_chr = ' ' then
  1389.                call tnou ('   (No repeat character processing.)', 36);
  1390.             else
  1391.                call tonl;
  1392.          end;
  1393.  
  1394.       when (show_wsize)
  1395.          call ioa$ ('Window size I want to use ........... %d%.', 99, loc_max_wsize);
  1396.  
  1397.       when (show_store)
  1398.          do;
  1399.             call tnoua ('File storage type is ................ ', 38);
  1400.  
  1401.             select (file_type);
  1402.                when (automatic_ft)
  1403.                   call tnou ('AUTOMATIC', 9);
  1404.  
  1405.                when (ascii_ft)
  1406.                   call tnou ('TEXT', 4);
  1407.  
  1408.                when (binary_ft)
  1409.                   call tnou ('BINARY', 6);
  1410.  
  1411.                otherwise
  1412.                   call tnou ('ILLEGAL', 7);
  1413.  
  1414.             end;
  1415.  
  1416.          end;
  1417.  
  1418.       when (show_incomplete)
  1419.          do;
  1420.             call tnoua ('Incomplete files are ................ ', 38);
  1421.             if del_incomplete then
  1422.                call tnou ('DELETED', 7);
  1423.             else
  1424.                call tnou ('SAVED', 5);
  1425.          end;
  1426.  
  1427.       when (show_pound)
  1428.          do;
  1429.             call tnoua ('DOS pound sign conversion is ........ ', 38);
  1430.             if pound_conversion then
  1431.                call tnou ('ON', 2);
  1432.             else
  1433.                call tnou ('OFF', 3);
  1434.          end;
  1435.  
  1436.       when (show_attributes)
  1437.          do;
  1438.             call tnoua ('Use of the file attributes is ....... ', 38);
  1439.             if use_attributes then
  1440.                call tnou ('ON', 2);
  1441.             else
  1442.                call tnou ('OFF', 3);
  1443.          end;
  1444.  
  1445.       when (show_warning)
  1446.          do;
  1447.             call tnoua ('File name collision warning is ...... ', 38);
  1448.             if filename_warning then
  1449.                call tnou ('ON', 2);
  1450.             else
  1451.                call tnou ('OFF', 3);
  1452.          end;
  1453.  
  1454.       when (ambiguous_cmd)
  1455.          call ioa$ ('Ambiguous SHOW option "%v". Type HELP for a list of options.%.', 99, cmd_option);
  1456.  
  1457.       otherwise
  1458.          call ioa$ ('Unrecognized SHOW option "%v". Type HELP for a list of options.%.', 99, cmd_option);
  1459.  
  1460.    end;      /* select */
  1461.  
  1462.    return;
  1463.  
  1464.    end;    /* Comnd_show */
  1465.  
  1466. /* ******************************* Comnd_set ******************************* */
  1467.  
  1468. Comnd_set : proc;
  1469.  
  1470. %Replace set_len by 11;
  1471.  
  1472. Dcl set_state (set_len) char (16) var static init (
  1473.           'DELAY',
  1474.           'PARITY',
  1475.           'QUOTE',
  1476.           '8QUOTE',
  1477.           'WINDOW',
  1478.           'FILETYPE',
  1479.           'POUND',
  1480.           'INCOMPLETE',
  1481.           'ATTRIBUTES',
  1482.           'REPEAT',
  1483.           'WARNING');
  1484.  
  1485. %Replace set_delay by 1,
  1486.          set_parity by 2,
  1487.          set_quote by 3,
  1488.          set_8quote by 4,
  1489.          set_wsize by 5,
  1490.          set_store by 6,
  1491.          set_pound by 7,
  1492.          set_incomplete by 8,
  1493.          set_attributes by 9,
  1494.          set_repeat by 10,
  1495.          set_warning by 11;
  1496.  
  1497. /* ************************************************************************* */
  1498.  
  1499.    command = type (cmd_option, addr (set_state), set_len);
  1500.    cmd_option = token(3);
  1501.  
  1502.    select (command);
  1503.  
  1504.       when (set_delay)
  1505.          if num_tok < 3 then
  1506.             call ioa$ ('No DELAY time given, the current value of %d seconds will be unchanged.%.',
  1507.                        99, delay);
  1508.          else
  1509.             if verify (cmd_option, '0123456789') ^= 0 then
  1510.                call ioa$ ('Invalid DELAY time given "%v".%.', 99, cmd_option);
  1511.             else                 /* Everything is okay at this point. */
  1512.                do;
  1513.                   delay = bin (cmd_option, 15);
  1514.                   call comnd_show (show_delay);
  1515.                end;
  1516.  
  1517.       when (set_parity)
  1518.          if cmd_option = 'M' | cmd_option = 'MARK' then
  1519.             do;
  1520.                do_transparent = false;
  1521.                do_8bit_chks = false;
  1522.                if loc_8quote_chr = 'Y' | loc_8quote_chr = 'N' then
  1523.                   do;
  1524.                      call tnou ('WARNING : 8-bit quoting MUST be used with MARK parity for binary file transfers.', 80);
  1525.                      call comnd_show (show_8quote);
  1526.                   end;
  1527.                call comnd_show (show_parity);
  1528.             end;
  1529.          else
  1530.             if cmd_option = 'N' | cmd_option = 'NONE' then
  1531.                do;
  1532.                   do_transparent = true;
  1533.                   do_8bit_chks = true;
  1534.                   call comnd_show (show_parity);
  1535.                end;
  1536.             else
  1537.                if cmd_option = '' then
  1538.                   do;
  1539.                      call tnou ('No PARITY option given. The current setting will be unchanged.', 62);
  1540.                      call comnd_show (show_parity);
  1541.                   end;
  1542.                else
  1543.                   call ioa$ ('Invalid PARITY option given "%v".%.', 99, cmd_option);
  1544.  
  1545.       when (set_quote)
  1546.          if length (cmd_option) > 1 then
  1547.             call ioa$ ('Invalid control quoting character given "%v".%/Only one character may be specified.%.', 99, cmd_option);
  1548.          else
  1549.             select (cmd_option);
  1550.  
  1551.                when ('')
  1552.                   do;
  1553.                      call tnou ('No control quoting character given. The current setting will be unchanged.', 74);
  1554.                      call comnd_show (show_quote);
  1555.                   end;
  1556.  
  1557.                when (loc_8quote_chr)
  1558.                   call ioa$ ('Invalid control quoting character given "%v".%/It is the same as the 8-bit quoting character.%.', 99, cmd_option);
  1559.  
  1560.                when (loc_rep_chr)
  1561.                   call ioa$ ('Invalid control quoting character given "%v".%/It is the same as the repeat character prefix.%.', 99, cmd_option);
  1562.  
  1563.                otherwise
  1564.                   if cmd_option < ' ' | cmd_option > '~' then
  1565.                      call tnou ('Invalid control quoting character given. It must be a printable ASCII character.', 80);
  1566.                   else
  1567.                      do;
  1568.                         loc_quote_chr = cmd_option;
  1569.                         call comnd_show (show_quote);
  1570.                      end;
  1571.             end;
  1572.  
  1573.       when (set_8quote)
  1574.          if length (cmd_option) > 1 then
  1575.             call ioa$ ('Invalid 8-bit quoting character given "%v".%/Only one character may be specified.%.', 99, cmd_option);
  1576.          else
  1577.             select (cmd_option);
  1578.  
  1579.                when ('')
  1580.                   do;
  1581.                      call tnou ('No 8-bit quoting character given. The current setting will be unchanged.', 72);
  1582.                      call comnd_show (show_8quote);
  1583.                   end;
  1584.  
  1585.                when (loc_quote_chr)
  1586.                   call ioa$ ('Invalid 8-bit quoting character given "%v".%/It is the same as the control quoting character.%.', 99, cmd_option);
  1587.  
  1588.                when (loc_rep_chr)
  1589.                   call ioa$ ('Invalid 8-bit quoting character given "%v".%/It is the same as the repeat character prefix.%.', 99, cmd_option);
  1590.  
  1591.                otherwise
  1592.                   do;
  1593.                      loc_8quote_chr = cmd_option;
  1594.                      if ^do_transparent & (cmd_option <= ' ' | (cmd_option > '>' &
  1595.                                            cmd_option < '`') | cmd_option > '~') then
  1596.                         do;
  1597.                            call tnou ('WARNING : 8-bit quoting MUST be used with MARK parity for binary file transfers.', 80);
  1598.                            call comnd_show (show_parity);
  1599.                         end;
  1600.                      call comnd_show (show_8quote);
  1601.                   end;
  1602.             end;
  1603.  
  1604.       when (set_repeat)
  1605.          if length (cmd_option) > 1 then
  1606.             call ioa$ ('Invalid repeat character prefix given "%v".%/Only one character may be specified.%.', 99, cmd_option);
  1607.          else
  1608.             select (cmd_option);
  1609.  
  1610.                when (loc_quote_chr)
  1611.                   call ioa$ ('Invalid repeat character prefix given "%v".%/It is the same as the control quoting character.%.', 99, cmd_option);
  1612.  
  1613.                when (loc_8quote_chr)
  1614.                   call ioa$ ('Invalid repeat character prefix given "%v".%/It is the same as the 8-bit quoting character.%.', 99, cmd_option);
  1615.  
  1616.                otherwise
  1617.                   if (cmd_option  < ' ' | (cmd_option > '>' & cmd_option < '`') | cmd_option > '~') & cmd_option ^= '' then
  1618.                      call tnou ('Invalid repeat character prefix given. It must be a printable ASCII character.', 78);
  1619.                   else
  1620.                      do;
  1621.                         if cmd_option = '' then
  1622.                            cmd_option = ' ';
  1623.  
  1624.                         loc_rep_chr = cmd_option;
  1625.                         call comnd_show (show_repeat);
  1626.                      end;
  1627.             end;
  1628.  
  1629.       when (set_wsize)
  1630.          if num_tok < 3 then
  1631.             do;
  1632.                call tnou ('No WINDOW size given, the current value will be unchanged.', 58);
  1633.                call comnd_show (show_wsize);
  1634.             end;
  1635.          else
  1636.             if verify (cmd_option, '0123456789') ^= 0 then
  1637.                call ioa$ ('Invalid WINDOW size given "%v".', 99, cmd_option);
  1638.             else
  1639.                do;
  1640.                   i = bin (cmd_option, 15);
  1641.                   if i < 0 | i > 31 then
  1642.                      call tnou ('Specified WINDOW size out of range. It must be between 0 and 31 inclusive.', 74);
  1643.                   else
  1644.                      do;
  1645.                         loc_max_wsize = i;
  1646.                         addr (loc_capas1) -> capas.windowing = (loc_max_wsize > 0);
  1647.                         call comnd_show (show_wsize);
  1648.                      end;
  1649.                end;
  1650.  
  1651.       when (set_store)
  1652.          select (cmd_option);
  1653.  
  1654.             when ('AU', 'AUTO', 'AUTOMATIC')
  1655.                do;
  1656.                   file_type = automatic_ft;
  1657.                   explicit_ft_set = false;
  1658.                   if ^explicit_pound_set then  /* Reset this in case it got set before. */
  1659.                      pound_conversion = true;
  1660.                   call comnd_show (show_store);
  1661.                end;
  1662.  
  1663.             when ('AS', 'ASCII', 'T', 'TEXT')
  1664.                do;
  1665.                   file_type = ascii_ft;
  1666.                   explicit_ft_set = true;
  1667.                   if ^explicit_pound_set then
  1668.                      pound_conversion = true;
  1669.                   call comnd_show (show_store);
  1670.                end;
  1671.  
  1672.             when ('B', 'BIN', 'BINARY', 'I', 'IMAGE')
  1673.                do;
  1674.                   file_type = binary_ft;
  1675.                   explicit_ft_set = true;
  1676.                   if ^explicit_pound_set then
  1677.                      pound_conversion = false;
  1678.                   call comnd_show (show_store);
  1679.                end;
  1680.  
  1681.             when ('')
  1682.                do;
  1683.                   call tnou ('No storage type given. The current setting will be unchanged.', 61);
  1684.                   call comnd_show (show_store);
  1685.                end;
  1686.  
  1687.             otherwise
  1688.                call ioa$ ('Invalid storage type "%v".%.', 99, cmd_option);
  1689.  
  1690.          end;
  1691.  
  1692.       when (set_pound)
  1693.          select (cmd_option);
  1694.  
  1695.             when ('ON', 'Y', 'YES')
  1696.                do;
  1697.                   pound_conversion = true;
  1698.                   explicit_pound_set = true;
  1699.                   call comnd_show (show_pound);
  1700.                end;
  1701.  
  1702.             when ('OFF', 'N', 'NO')
  1703.                do;
  1704.                   pound_conversion = false;
  1705.                   explicit_pound_set = true;
  1706.                   call comnd_show (show_pound);
  1707.                end;
  1708.  
  1709.             when ('')
  1710.                do;
  1711.                   call tnou ('No POUND option given. The current setting will be unchanged.', 61);
  1712.                   call comnd_show (show_pound);
  1713.                end;
  1714.  
  1715.             otherwise
  1716.                call ioa$ ('Invalid POUND option "%v".%.', 99, cmd_option);
  1717.  
  1718.          end;
  1719.  
  1720.       when (set_incomplete)
  1721.          select (cmd_option);
  1722.  
  1723.             when ('D', 'DEL', 'DELETE', 'DISCARD')
  1724.                do;
  1725.                   del_incomplete = true;
  1726.                   call comnd_show (show_incomplete);
  1727.                end;
  1728.  
  1729.             when ('S', 'SAVE', 'KEEP')
  1730.                do;
  1731.                   del_incomplete = false;
  1732.                   call comnd_show (show_incomplete);
  1733.                end;
  1734.  
  1735.             when ('')
  1736.                do;
  1737.                   call tnou ('No INCOMPLETE option given, the current setting will be unchanged.', 66);
  1738.                   call comnd_show (show_incomplete);
  1739.                end;
  1740.  
  1741.             otherwise
  1742.                call ioa$ ('Invalid INCOMPLETE option "%v".%.', 99, cmd_option);
  1743.  
  1744.          end;
  1745.  
  1746.       when (set_attributes)
  1747.          select (cmd_option);
  1748.  
  1749.             when ('ON', 'Y', 'YES')
  1750.                use_attributes = true;
  1751.  
  1752.             when ('OFF', 'N', 'NO')
  1753.                use_attributes = false;
  1754.  
  1755.             when ('')
  1756.                do;
  1757.                   call tnou ('No ATTRIBUTES option given, the current setting will be unchanged.', 66);
  1758.                   call comnd_show (show_attributes);
  1759.                end;
  1760.  
  1761.             otherwise
  1762.                call ioa$ ('Invalid ATTRIBUTES option "%v".%.', 99, cmd_option);
  1763.  
  1764.          end;
  1765.  
  1766.       when (set_warning)
  1767.          select (cmd_option);
  1768.  
  1769.             when ('ON', 'Y', 'YES')
  1770.                filename_warning = true;
  1771.  
  1772.             when ('OFF', 'N', 'NO')
  1773.                filename_warning = false;
  1774.  
  1775.             when ('')
  1776.                do;
  1777.                   call tnou ('No file name WARNING option given, the current setting will be unchanged.', 73);
  1778.                   call comnd_show (show_warning);
  1779.                end;
  1780.  
  1781.             otherwise
  1782.                call ioa$ ('Invalid file name WARNING option "%v".%.', 99, cmd_option);
  1783.  
  1784.          end;
  1785.  
  1786.       when (ambiguous_cmd)
  1787.          call ioa$ ('Ambiguous SET option "%v". Type HELP for a list of options.%.', 99, token(2));
  1788.  
  1789.       otherwise
  1790.          call ioa$ ('Unrecognized SET option "%v". Type HELP for a list of options.%.', 99, token(2));
  1791.  
  1792.    end;     /* select */
  1793.  
  1794.    return;
  1795.  
  1796.    end;   /* Comnd_set */
  1797.  
  1798. /* ********************************* Type ********************************** */
  1799.  
  1800. /* TYPE -- determine command type from a list of possibilities. */
  1801.  
  1802. Type : proc (str, table_ptr, table_len) returns (fixed bin);
  1803.  
  1804. Dcl str char (128) var,
  1805.     table_ptr ptr,
  1806.     table_len fixed bin;
  1807.  
  1808. Dcl (str_len, entry_found, i) fixed bin,
  1809.     table_entry char (16) var,
  1810.     table (1) char (16) var based;
  1811.  
  1812. /* ************************************************************************* */
  1813.  
  1814.    entry_found = 0;
  1815.    str_len = length (str);
  1816.  
  1817.    do i = 1 to table_len;
  1818.       table_entry = table_ptr -> table(i);
  1819.  
  1820.       if length (table_entry) >= str_len then
  1821.          if substr (table_entry, 1, str_len) = str then
  1822.             if entry_found ^= 0 then
  1823.                return (ambiguous_cmd);   /* More than one match found! */
  1824.             else
  1825.                entry_found = i;
  1826.    end;
  1827.  
  1828.    return (entry_found);
  1829.  
  1830.    end;          /* Type */
  1831.  
  1832. /* ******************************* Tokenize ******************************** */
  1833.  
  1834. Tokenize : proc (buff);
  1835.  
  1836. Dcl buff char (160) var;
  1837.  
  1838. /* ************************************************************************* */
  1839.  
  1840.    /* A command line is passed back split up into tokens. The code
  1841.       only expects and handles 3 options, any others are ignored. */
  1842.  
  1843.    do num_tok = 1 to num_tokens;
  1844.       token(num_tok) = '';
  1845.    end;
  1846.  
  1847.    buff = translate (buff, uppercase || ' ', lowercase || ',');
  1848.  
  1849.    buff = trim (buff, '11'b);
  1850.  
  1851.    do num_tok = 1 to num_tokens while (buff ^= '');
  1852.       token(num_tok) = before (buff, ' ');
  1853.       buff = trim (after (buff, ' '), '11'b);
  1854.    end;
  1855.  
  1856.    num_tok = num_tok - 1;
  1857.  
  1858.    return;
  1859.  
  1860.    end;           /* Tokenize */
  1861.  
  1862. /* ****************************** Comi_hndlr ******************************* */
  1863.  
  1864. Comi_hndlr : proc (point);
  1865.  
  1866. Dcl point ptr;
  1867.  
  1868. /* ************************************************************************* */
  1869.  
  1870.    /* This on-unit for the condition COMI_EOF$ makes life easier by treating
  1871.       the condition just as if the user had issued a POP command. We must
  1872.       remember that we were here though, so that the prompts come out okay.
  1873.    */
  1874.  
  1875.    from_comi_hndlr = true;
  1876.  
  1877.    go to comi_point;
  1878.  
  1879.    end;        /* Comi_hndlr */
  1880.  
  1881. /* ******************************* Get_unit ******************************** */
  1882.  
  1883. Get_unit : proc (code) returns (fixed bin);
  1884.  
  1885. Dcl code fixed bin;
  1886.  
  1887. Dcl (unit, rnw) fixed bin,
  1888.     pos fixed bin (31);
  1889.  
  1890. /* ************************************************************************* */
  1891.  
  1892.    code = 0;
  1893.    unit = 0;
  1894.  
  1895.    /* We start the file unit numbers at 7 to allow the lower ones to be used
  1896.       by other programs and, if the user PUSHes, commands like LISTING and
  1897.       BINARY (which use units 2 and 3) may also be used. The upper limit can,
  1898.       at the moment, only be guessed at. To allow a "decent" number of TAKE's
  1899.       to be nested we have used the figure of 127. This may need to be
  1900.       changed by other sites.
  1901.    */
  1902.  
  1903.    do unit = 7 to 127 until (code = e$unop);
  1904.       call prwf$$ (k$rpos, unit, null (), 0, pos, rnw, code);
  1905.    end;
  1906.  
  1907.    if code = 0 | code = e$dire | code = e$bunt then
  1908.       code = e$fuiu;
  1909.  
  1910.    if code = e$unop then
  1911.       code = 0;
  1912.    else
  1913.       unit = 0;
  1914.  
  1915.    return (unit);
  1916.  
  1917.    end;        /* Get_unit */
  1918.  
  1919.    end;      /* Comnd */
  1920. -------------------------------------------------------------------------------
  1921.  
  1922. /* CONVERT_FILE -- Convert uploaded file to Primos text file. */
  1923.  
  1924. Convert_file : proc returns (fixed bin);
  1925.  
  1926. $Insert *>insert>common.ins.plp
  1927. $Insert *>insert>kermit.ins.plp
  1928. $Insert *>insert>primos.ins.plp
  1929. $Insert *>insert>constants.ins.plp
  1930. $Insert syscom>keys.ins.pl1
  1931. $Insert syscom>errd.ins.pl1
  1932.  
  1933. Dcl temp_pathname char (128) var,
  1934.     buffer char (ibuffer_size) var,
  1935.     (temp_filename, basename) char (32) var,
  1936.     (code, type, nw, i, unit2, rnw, sufusd) fixed bin,
  1937.     fn char (13),
  1938.     unique_bits char (6) aligned,
  1939.     char_ptr ptr,
  1940.     character char (1);
  1941.  
  1942. Dcl 1 bit_char based,
  1943.       2 high_bit bit (1),
  1944.       2 next_bits bit (7);
  1945.  
  1946. /********************************************************************/
  1947.  
  1948.    buffer = '';
  1949.    snd_msg = '';
  1950.    char_ptr = addr (character);
  1951.  
  1952.    call srsfx$ (k$read + k$getu, path_name, file_unit, type, 0, '', basename, sufusd, code);
  1953.    if type > 1 & type ^= 7 then
  1954.       do;
  1955.          call clo$fu (file_unit, code);
  1956.          code = e$wft;
  1957.       end;
  1958.  
  1959.    file_opened = (code = 0);
  1960.  
  1961.    if code ^= 0 then
  1962.       do;
  1963.          snd_msg = 'Error opening file to convert on remote system. ';
  1964.          return (code);
  1965.       end;
  1966.  
  1967.    call uid$bt (unique_bits);
  1968.    call uid$ch (unique_bits, fn);
  1969.    temp_filename = fn || '.KERMIT.CONV';
  1970.  
  1971.    if ^non_null_dir then
  1972.       temp_pathname = temp_filename;
  1973.    else
  1974.       temp_pathname = dir_name || '>' || temp_filename;
  1975.  
  1976.    i = k$writ + k$getu;
  1977.    if type = 1 then
  1978.       i = i + k$ndam;
  1979.    else
  1980.       if type = 7 then
  1981.          i = i + k$ncam;
  1982.  
  1983.    call srsfx$ (i, temp_pathname, unit2, type, 0, '', basename, sufusd, code);
  1984.    if code ^= 0 then
  1985.       do;
  1986.          file_opened = false;
  1987.          call clo$fu (file_unit, rnw);
  1988.          snd_msg = 'Error opening temporary file on remote system.';
  1989.          return (code);
  1990.       end;
  1991.  
  1992.    do until (code ^= 0);
  1993.  
  1994.       call prwf$$ (k$read, file_unit, ibuffer_ptr, ibuffer_size_wds, 0, rnw, code);
  1995.       if code = e$eof & rnw ^= 0 then
  1996.          code = 0;
  1997.  
  1998.       if code = 0 then
  1999.          do;
  2000.             ibuflen = 2 * rnw;
  2001.  
  2002.             call convert_to_ascii;
  2003.             if code ^= 0 then
  2004.                snd_msg = 'Error converting the file on the remote system.';
  2005.          end;
  2006.       else
  2007.          if code ^= e$eof then
  2008.             snd_msg = 'Error reading from the file on the remote system.';
  2009.    end;
  2010.  
  2011.    file_opened = false;
  2012.  
  2013.    call clo$fu (file_unit, rnw);
  2014.  
  2015.    call clo$fu (unit2, rnw);
  2016.  
  2017.    if code = e$eof then
  2018.       do;
  2019.          code = 0;
  2020.          snd_msg = '';
  2021.       end;
  2022.  
  2023.    if code ^= 0 then
  2024.       do;
  2025.          call fil$dl (temp_pathname, rnw);
  2026.          snd_msg = 'Error in processing file conversion on the remote system.';
  2027.          return (code);
  2028.       end;
  2029.    else
  2030.       do;
  2031.          code = rnw;
  2032.          if code ^= 0 then
  2033.             do;
  2034.                snd_msg = 'Unable to close the output file on the remote system.';
  2035.                return (code);
  2036.             end;
  2037.       end;
  2038.  
  2039.    if non_null_dir then
  2040.       do;
  2041.          call at$ (k$setc, dir_name, code);
  2042.          if code ^= 0 then
  2043.             do;
  2044.                call fil$dl (temp_pathname, rnw);
  2045.                snd_msg = 'Error attaching to upload directory on remote system.';
  2046.                return (code);
  2047.             end;
  2048.       end;
  2049.  
  2050.    call fil$dl (file_name, code);
  2051.    if code ^= 0 then
  2052.       do;
  2053.          if non_null_dir then
  2054.             call at$hom (rnw);
  2055.          snd_msg = 'Unable to delete the original file on the remote system.';
  2056.          return (code);
  2057.       end;
  2058.  
  2059.    rnw = 0;
  2060.    if length (temp_filename) = length (file_name) then
  2061.       sufusd = 1;
  2062.    else
  2063.       sufusd = 0;
  2064.  
  2065.    call cnam$$ ((temp_filename), length (temp_filename), (file_name), length (file_name), code, sufusd);
  2066.    if code ^= 0 then
  2067.       snd_msg = 'Error trying to rename the temporary file on remote system.';
  2068.  
  2069.    if non_null_dir then
  2070.       call at$hom (rnw);
  2071.  
  2072.    if code = 0 then
  2073.       code = rnw;
  2074.  
  2075.    return (code);
  2076.  
  2077. /* **************************** Convert_to_ascii *************************** */
  2078.  
  2079. Convert_to_ascii : proc;
  2080.  
  2081. /* ************************************************************************* */
  2082.  
  2083.    code = 0;
  2084.  
  2085.    do i = 1 to ibuflen;
  2086.  
  2087.       character = substr (ibuffer, i, 1);
  2088.       char_ptr -> bit_char.high_bit = '1'b;
  2089.  
  2090.       select (character);
  2091.  
  2092.          when (cr_8bit_asc)
  2093.             eol_flag = 1;
  2094.  
  2095.          when (lf_8bit_asc)
  2096.             eol_flag = eol_flag + 1;
  2097.  
  2098.          otherwise
  2099.             eol_flag = 0;
  2100.       end;
  2101.  
  2102.       if eol_flag > 1 then
  2103.          do;
  2104.             sufusd = length (buffer);
  2105.             substr (buffer, sufusd, 1) = ' ';
  2106.             call wtlin$ (unit2, (buffer), divide (sufusd, 2, 15), code);
  2107.             if code ^= 0 then
  2108.                return;
  2109.             buffer = '';
  2110.          end;
  2111.       else
  2112.          buffer = buffer || character;
  2113.    end;
  2114.  
  2115.    return;
  2116.  
  2117.    end;       /* Convert_to_ascii */
  2118.  
  2119.    end;      /* Convert_file */
  2120. -------------------------------------------------------------------------------
  2121.  
  2122. /* DISCARD_OUTPUT -- Discard an output file. */
  2123.  
  2124. Discard_output : proc (code);
  2125.  
  2126. Dcl code fixed bin;
  2127.  
  2128. $Insert *>insert>common.ins.plp
  2129. $Insert *>insert>kermit.ins.plp
  2130. $Insert *>insert>primos.ins.plp
  2131. $Insert *>insert>constants.ins.plp
  2132. $Insert syscom>errd.ins.pl1
  2133.  
  2134. /* ************************************************************************* */
  2135.  
  2136.    code = 0;
  2137.  
  2138.    rec_file_type = automatic_ft;
  2139.    if ^explicit_ft_set then
  2140.       file_type = automatic_ft;
  2141.  
  2142.    if file_opened then
  2143.       do;
  2144.          call clo$fu (file_unit, code);
  2145.          if code = e$unop then
  2146.             code = 0;
  2147.  
  2148.          if code = 0 & del_incomplete then
  2149.             call fil$dl (path_name, code);
  2150.  
  2151.          if code = e$fntf then        /* Possible if the unit wasn't open. */
  2152.             code = 0;
  2153.  
  2154.          file_opened = false;
  2155.       end;
  2156.  
  2157.    return;
  2158.  
  2159.    end;      /* Discard_output */
  2160. -------------------------------------------------------------------------------
  2161.  
  2162. /* GENERIC_CMD -- Generic server command process. */
  2163.  
  2164. Generic_cmd : proc returns (fixed bin);
  2165.  
  2166. $Insert *>insert>common.ins.plp
  2167. $Insert *>insert>kermit.ins.plp
  2168. $Insert *>insert>primos.ins.plp
  2169. $Insert *>insert>constants.ins.plp
  2170. $Insert syscom>keys.ins.pl1
  2171. $Insert syscom>errd.ins.pl1
  2172.  
  2173. %Replace maxargs by 3,
  2174.          maxalen by 96;
  2175.  
  2176. Dcl (args, nargs) char (maxalen) var,
  2177.     arg (maxargs) char (maxalen) var;
  2178.  
  2179. Dcl (treename, line) char (128) var,
  2180.     basename char (32) var,
  2181.     fn char (13),
  2182.     unique_bits char (6) aligned,
  2183.     (print_header, continue) bit (1) aligned,
  2184.     (code, rnw, funit, type, dir_type, dir_unit, code2, sufusd, key) fixed bin,
  2185.     (to_user_num, to_name_len) fixed bin,
  2186.     errvec (4) fixed bin,
  2187.     to_name char (32),
  2188.     1 quota_info,
  2189.       2 (record_size, dir_used, max_quota, quota_used) fixed bin (31),
  2190.       2 (duff1, duff2, duff3, duff4) fixed bin (31),
  2191.     inf_array (8) fixed bin (31) based;
  2192.  
  2193. /* ************************************************************************* */
  2194.  
  2195.    call parse_cmd;           /* Parse any arguments sent. */
  2196.  
  2197.    select (set8 (substr (rec_msg, pkt_msg, 1))); /* Process the message type. */
  2198.  
  2199.       when (msg_gen_cwd)          /* CWD - Change Working Directory. */
  2200.          do;
  2201.             treename = arg(1);
  2202.  
  2203.             if arg(2) ^= '' then       /* Do we have a password ? */
  2204.                treename = treename || ' ' || arg(2);
  2205.  
  2206.             call change_dir (treename, code);
  2207.  
  2208.             if code = 0 then
  2209.                call send_packet (msg_ack, length (snd_msg), rec_seq);
  2210.             else
  2211.                do;
  2212.                   call get_error_msg (code);
  2213.                   snd_msg = 'Error trying to change directory. ' || errmsg;
  2214.                   call send_packet (msg_error, length (snd_msg), msg_number);
  2215.                end;
  2216.          end;
  2217.  
  2218.       when (msg_gen_finish)          /* FINISH command. */
  2219.          do;
  2220.             call send_packet (msg_ack, 0, rec_seq);
  2221.             return (ker_exit);
  2222.          end;
  2223.  
  2224.       when (msg_gen_logout)           /* LOGOUT command. */
  2225.          do;
  2226.             call send_packet (msg_ack, 0, rec_seq);
  2227.             call logo$$ (0, 0, '', 0, 0, code);
  2228.          end;
  2229.  
  2230.       when (msg_gen_delete)           /* DELETE command. */
  2231.          do;
  2232.             treename = arg(1);
  2233.             call fil$dl (treename, code);
  2234.             if code = 0 then
  2235.                do;
  2236.                   snd_msg = 'File deleted.';
  2237.                   call send_packet (msg_ack, length (snd_msg), rec_seq);
  2238.                end;
  2239.             else
  2240.                do;
  2241.                   call get_error_msg (code);
  2242.                   snd_msg = 'Unable to delete the file. ' || errmsg;
  2243.                   call send_packet (msg_error, length (snd_msg), msg_number);
  2244.                end;
  2245.          end;
  2246.  
  2247.       when (msg_gen_directory)        /* DIRECTORY command. */
  2248.          do;
  2249.             call uid$bt (unique_bits);
  2250.             call uid$ch (unique_bits, fn);
  2251.  
  2252.             treename = arg(1);
  2253.  
  2254.             if treename = '' then
  2255.                treename = fn || '.KERMIT.DIR';
  2256.             else
  2257.                treename = treename || '>' || fn || '.KERMIT.DIR';
  2258.  
  2259.             call set_path (treename);
  2260.  
  2261.             call srch$$ (k$rdwr + k$getu, (file_name), length (file_name), file_unit, type, code);
  2262.             if code ^= 0 then
  2263.                do;
  2264.                   call get_error_msg (code);
  2265.                   snd_msg = 'Error opening a temporary file. ' || errmsg;
  2266.                   call send_packet (msg_error, length (snd_msg), msg_number);
  2267.  
  2268.                   return (ker_normal);
  2269.                end;
  2270.  
  2271.             file_opened = true;
  2272.  
  2273.             call srsfx$ (k$read + k$getu, dir_name, dir_unit, dir_type, 0, '', basename, sufusd, code);
  2274.             if code ^= 0 then
  2275.                do;
  2276.                   call get_error_msg (code);
  2277.                   snd_msg = 'Error opening the directory. ' || errmsg;
  2278.                   call send_packet (msg_error, length (snd_msg), msg_number);
  2279.  
  2280.                   file_opened = false;
  2281.                   call clo$fu (file_unit, code);
  2282.                   call fil$dl (file_name, code);
  2283.  
  2284.                   return (ker_normal);
  2285.                end;
  2286.  
  2287.             continue = false;
  2288.             print_header = true;
  2289.             call dir$rd (k$init, dir_unit, dir_entry_ptr, dir_entry_size, code);
  2290.  
  2291.             do until (code ^= 0);
  2292.                call dir$rd (k$read, dir_unit, dir_entry_ptr, dir_entry_size, code);
  2293.                if code = 0 then
  2294.                   if trim (dir_entry.entryname, '01'b) ^= file_name then
  2295.                      do;
  2296.                         if print_header then
  2297.                            do;
  2298.                               print_header = false;
  2299.                               call wtlin$ (file_unit, '*** Start of Directory Listing. *** ', 18, code);
  2300.                            end;
  2301.  
  2302.                         if ^continue then
  2303.                            line = dir_entry.entryname;
  2304.                         else
  2305.                            do;
  2306.                               line = line || '    ' || dir_entry.entryname || '  ';
  2307.                               call wtlin$ (file_unit, (line), divide (length (line), 2, 15), code);
  2308.                            end;
  2309.  
  2310.                         if code = 0 then
  2311.                            continue = ^continue;
  2312.  
  2313.                      end;
  2314.             end;
  2315.  
  2316.             call clo$fu (dir_unit, code2);
  2317.  
  2318.             if code = e$eof then
  2319.                do;
  2320.                   code = 0;
  2321.                   if continue then
  2322.                      do;
  2323.                         line = line || '  ';
  2324.                         call wtlin$ (file_unit, (line), divide (length (line), 2, 15), code);
  2325.                      end;
  2326.                   else      /* We will be here if we had an empty directory. */
  2327.                      if print_header then
  2328.                         call wtlin$ (file_unit, '*** There are NO file system objects in this directory. *** ', 30, code);
  2329.                end;
  2330.  
  2331.             if code ^= 0 then
  2332.                do;
  2333.                   call get_error_msg (code);
  2334.                   snd_msg = 'Error listing the directory. ' || errmsg;
  2335.                   call send_packet (msg_error, length (snd_msg), msg_number);
  2336.  
  2337.                   file_opened = false;
  2338.                   call clo$fu (file_unit, code);
  2339.                   call fil$dl (file_name, code);
  2340.  
  2341.                   return (ker_normal);
  2342.                end;
  2343.  
  2344.             if ^print_header then
  2345.                call wtlin$ (file_unit, '*** End of Directory Listing. *** ', 17, code);
  2346.  
  2347.             call xsend_file;
  2348.  
  2349.             file_opened = false;
  2350.  
  2351.             call clo$fu (file_unit, code);
  2352.             call fil$dl (file_name, code);
  2353.  
  2354.          end;
  2355.  
  2356.       when (msg_gen_type)             /* TYPE command. */
  2357.          do;
  2358.             treename = arg(1);
  2359.             call set_path (treename);
  2360.  
  2361.             code = open_input ();
  2362.             if code = 0 then
  2363.                do;
  2364.                   state = state_x;
  2365.                   call send_switch;
  2366.                end;
  2367.             else
  2368.                do;
  2369.                   call get_error_msg (code);
  2370.                   snd_msg = 'Error accessing the file. ' || errmsg;
  2371.                   call send_packet (msg_error, length (snd_msg), msg_number);
  2372.                end;
  2373.          end;
  2374.  
  2375.       when (msg_gen_disk_usage)              /* Disk Usage. */
  2376.          do;
  2377.             treename = arg(1); /* Anything sent will actually be a directory. */
  2378.             if treename ^= '' then
  2379.                treename = treename || '>DUMMY_FILE_NAME';
  2380.  
  2381.             call set_path (treename);
  2382.  
  2383.             call q$read (dir_name, addr (quota_info) -> inf_array, 4, type, code);
  2384.             if code ^= 0 then
  2385.                do;
  2386.                   call get_error_msg (code);
  2387.                   snd_msg = 'Error reading the disk quota. ' || errmsg;
  2388.                   call send_packet (msg_error, length (snd_msg), msg_number);
  2389.                end;
  2390.             else
  2391.                do;
  2392.                   basename = trim (char (quota_info.quota_used), '10'b);
  2393.  
  2394.                   if type = 1 then
  2395.                      snd_msg = 'Not a quota directory. (' || basename || ' records used).';
  2396.                   else
  2397.                      snd_msg = basename || ' records used out of quota of ' ||
  2398.                                trim (char (quota_info.max_quota), '10'b) || '.';
  2399.  
  2400.                   call send_packet (msg_ack, length (snd_msg), rec_seq);
  2401.                end;
  2402.  
  2403.          end;
  2404.  
  2405.       when (msg_gen_rename)               /* RENAME command. */
  2406.          do;
  2407.             code = 0;
  2408.  
  2409.             treename = arg(1);
  2410.             call set_path (treename);
  2411.  
  2412.             if non_null_dir then
  2413.                call at$ (k$setc, dir_name, code);
  2414.  
  2415.             if code = 0 then
  2416.                do;
  2417.                   rnw = length (file_name);
  2418.                   type = length (arg(2));
  2419.  
  2420.                   if rnw = type then
  2421.                      sufusd = 1;
  2422.                   else
  2423.                      sufusd = 0;
  2424.  
  2425.                   call cnam$$ ((file_name), rnw, (arg(2)), type, code, sufusd);
  2426.  
  2427.                   if non_null_dir then
  2428.                      call at$hom (code2);
  2429.                end;
  2430.  
  2431.             if code ^= 0 then
  2432.                do;
  2433.                   call get_error_msg (code);
  2434.                   snd_msg = 'Error trying to change the file name. ' || errmsg;
  2435.                   call send_packet (msg_error, length (snd_msg), msg_number);
  2436.                end;
  2437.             else
  2438.                do;
  2439.                   snd_msg = 'File renamed.';
  2440.                   call send_packet (msg_ack, length (snd_msg), rec_seq);
  2441.                end;
  2442.  
  2443.          end;
  2444.  
  2445.       when (msg_gen_copy)             /* COPY command. */
  2446.          do;
  2447.             treename = arg(1);
  2448.             line = arg(2);
  2449.  
  2450.             call srsfx$ (k$read + k$getu, treename, file_unit, type, 0, '', basename, sufusd, code);
  2451.             if type > 1 & type ^= 7 then
  2452.                do;
  2453.                   call clo$fu (file_unit, code);
  2454.                   code = e$wft;
  2455.                end;
  2456.  
  2457.             if code ^= 0 then
  2458.                do;
  2459.                   call get_error_msg (code);
  2460.                   snd_msg = 'Unable to open the file to copy from. ' || errmsg;
  2461.                   call send_packet (msg_error, length (snd_msg), msg_number);
  2462.                   return (ker_normal);
  2463.                end;
  2464.  
  2465.             key = k$writ + k$getu;
  2466.             if type = 1 then
  2467.                key = key + k$ndam;
  2468.             else
  2469.                if type = 7 then
  2470.                   key = key + k$ncam;
  2471.  
  2472.             call srsfx$ (key, line, funit, type, 0, '', basename, sufusd, code);
  2473.             if code ^= 0 then
  2474.                do;
  2475.                   call get_error_msg (code);
  2476.                   snd_msg = 'Unable to open the file to copy to. ' || errmsg;
  2477.                   call send_packet (msg_error, length (snd_msg), msg_number);
  2478.                   return (ker_normal);
  2479.                end;
  2480.  
  2481.             do until (code ^= 0);
  2482.                call rdlin$ (file_unit, ibuffer, ibuffer_size_wds, code);
  2483.                if code = 0 then
  2484.                   call wtlin$ (funit, ibuffer, ibuffer_size_wds, code);
  2485.             end;
  2486.  
  2487.             call clo$fu (file_unit, code2);
  2488.             call clo$fu (funit, code2);
  2489.  
  2490.             if code = e$eof then
  2491.                code = 0;
  2492.  
  2493.             if code ^= 0 then
  2494.                do;
  2495.                   call fil$dl (line, code2);
  2496.                   call get_error_msg (code);
  2497.                   snd_msg = 'Error copying the file. ' || errmsg;
  2498.                   call send_packet (msg_error, length (snd_msg), msg_number);
  2499.                end;
  2500.             else
  2501.                do;
  2502.                   snd_msg = 'File copied.';
  2503.                   call send_packet (msg_ack, length (snd_msg), rec_seq);
  2504.                end;
  2505.  
  2506.          end;
  2507.  
  2508.       when (msg_gen_send)             /* SEND command. */
  2509.          do;
  2510.             line = after (arg(1), ' ');
  2511.             arg(1) = translate (trim (before (arg(1), ' '), '11'b), uppercase, lowercase);
  2512.             if substr (arg(1), 1, 1) = '-' then
  2513.                arg(1) = substr (arg(1), 2);
  2514.  
  2515.             if verify (arg(1), '+-0123456789') = 0 then    /* User number given. */
  2516.                do;
  2517.                   to_name = '';
  2518.                   to_name_len = 0;
  2519.                   to_user_num = bin (arg(1), 15);
  2520.                   if to_user_num <= 0 then
  2521.                      do;
  2522.                         snd_msg = 'Invalid user-number given.';
  2523.                         call send_packet (msg_error, length (snd_msg), msg_number);
  2524.                         return (ker_normal);
  2525.                      end;
  2526.                end;
  2527.             else
  2528.                do;
  2529.                   to_name = arg(1);
  2530.                   to_name_len = length (to_name);
  2531.                   to_user_num = 0;
  2532.                end;
  2533.  
  2534.             if length (line) > 80 then
  2535.                line = substr (line, 1, 80);
  2536.             rnw = length (line);
  2537.  
  2538.             errvec(2) = 1;
  2539.             call mgset$ (k$acpt, code);
  2540.  
  2541.             call smsg$ (1, to_name, to_name_len, to_user_num, '', 0, (line), rnw, errvec);
  2542.  
  2543.             call mgset$ (my_msg_state, code);
  2544.             if errvec(1) = 0 then
  2545.                do;
  2546.                   snd_msg = 'Message sent.';
  2547.                   call send_packet (msg_ack, length (snd_msg), rec_seq);
  2548.                end;
  2549.             else
  2550.                do;
  2551.                   call get_error_msg (errvec(1));
  2552.                   snd_msg = 'Unable to send the message. ' || errmsg;
  2553.                   call send_packet (msg_error, length (snd_msg), msg_number);
  2554.                end;
  2555.  
  2556.          end;
  2557.  
  2558.       when (msg_gen_who)              /* WHO command. */
  2559.          do;
  2560.             if substr (arg(1), 1, 1) = '-' then
  2561.                arg(1) = substr (arg(1), 2);
  2562.  
  2563.             if arg(1) = '' then
  2564.                do;
  2565.                   snd_msg = 'No user-id given.';
  2566.                   call send_packet (msg_error, length (snd_msg), msg_number);
  2567.                   return (ker_normal);
  2568.                end;
  2569.  
  2570.             if verify (arg(1), '+-0123456789') = 0 then  /* User number given. */
  2571.                do;
  2572.                   key = k$read;
  2573.                   to_name = '';
  2574.                   to_name_len = 32;
  2575.                   to_user_num = bin (arg(1), 15);
  2576.                   if to_user_num <= 0 then
  2577.                      do;
  2578.                         snd_msg = 'Invalid user-number given.';
  2579.                         call send_packet (msg_error, length (snd_msg), msg_number);
  2580.                         return (ker_normal);
  2581.                      end;
  2582.                end;
  2583.             else
  2584.                do;
  2585.                   key = 2;
  2586.                   to_name = arg(1);
  2587.                   to_name_len = length (to_name);
  2588.                   to_user_num = 0;
  2589.                end;
  2590.  
  2591.             call msg$st (key, to_user_num, '', 0, to_name, to_name_len, code);
  2592.             if code = k$none then
  2593.                do;
  2594.                   snd_msg = 'User ' || arg(1) || ' is not logged in.';
  2595.                   call send_packet (msg_error, length (snd_msg), msg_number);
  2596.                end;
  2597.             else
  2598.                do;
  2599.                   snd_msg = 'User ' || trim (to_name, '11'b) ||
  2600.                             ' is currently logged in as process number ' ||
  2601.                             trim (char (to_user_num), '11'b) || '.';
  2602.                   call send_packet (msg_ack, length (snd_msg), rec_seq);
  2603.                end;
  2604.  
  2605.          end;
  2606.  
  2607.       otherwise                       /* Unknown command. */
  2608.          do;
  2609.             snd_msg = 'Unimplemented command.';
  2610.             call send_packet (msg_error, length (snd_msg), msg_number);
  2611.             return (ker_unimplgen);
  2612.          end;
  2613.  
  2614.    end;     /* select */
  2615.  
  2616.    return (ker_normal);
  2617.  
  2618. /* ******************************* Parse_cmd ******************************* */
  2619.  
  2620. Parse_cmd : proc;
  2621.  
  2622. Dcl (arg_num, arg_len, i, temp, rep_count) fixed bin,
  2623.     do_trans bit (1) aligned,
  2624.     (chr, rem_quo) char (1);
  2625.  
  2626. /* ************************************************************************* */
  2627.  
  2628.    do_repeats = (loc_rep_chr = rem_rep_chr) & (loc_rep_chr ^= ' ');
  2629.  
  2630.    do i = 1 to maxargs;
  2631.       arg(i) = '';
  2632.    end;
  2633.  
  2634.    if length (rec_msg) <= pkt_tot_ovr_head then
  2635.       return;
  2636.  
  2637.    args = set8str (substr (rec_msg, pkt_tot_ovr_head, length (rec_msg) - pkt_tot_ovr_head));
  2638.  
  2639.    nargs = '';
  2640.    rem_quo = set8 (rem_quote_chr);   /* For local processing only. */
  2641.  
  2642.    i = 0;          /* Convert any quoted and repeated characters. */
  2643.    do while (i < length (args));
  2644.       i = i + 1;
  2645.       chr = substr (args, i, 1);
  2646.       rep_count = 1;
  2647.  
  2648.       if do_repeats then
  2649.          if chr = loc_rep_chr then
  2650.             do;
  2651.                i = i + 1;
  2652.                rep_count = knum (substr (args, i, 1));
  2653.  
  2654.                i = i + 1;
  2655.                chr = substr (args, i, 1);
  2656.             end;
  2657.  
  2658.       if chr = rem_quo then
  2659.          do;
  2660.             i = i + 1;
  2661.             chr = substr (args, i, 1);
  2662.             if chr >= query_8bit_asc & chr < grave_8bit_asc then
  2663.                chr = ctl (chr);
  2664.          end;
  2665.  
  2666.       do temp = 1 to rep_count;
  2667.          nargs = nargs || chr;
  2668.       end;
  2669.  
  2670.    end;
  2671.  
  2672.    i = 0;
  2673.    arg_num = 0;
  2674.    do_trans = (set8 (substr (rec_msg, pkt_msg, 1)) ^= msg_gen_send);
  2675.  
  2676.    do while (i < length (nargs));         /* Now fill in the argument list. */
  2677.       i = i + 1;
  2678.       arg_len = knum (substr (nargs, i, 1));
  2679.       arg_num = arg_num + 1;
  2680.       arg(arg_num) = substr (nargs, i + 1, arg_len);
  2681.       if do_trans then           /* Don't do this for the SEND command. */
  2682.          arg(arg_num) = translate (trim (arg(arg_num), '11'b), uppercase, lowercase);
  2683.       i = i + arg_len;
  2684.    end;
  2685.  
  2686.    return;
  2687.  
  2688.    end;       /* Parse_cmd */
  2689.  
  2690. /* ******************************* Xsend_file ****************************** */
  2691.  
  2692. Xsend_file : proc;
  2693.  
  2694. /* ************************************************************************* */
  2695.  
  2696.    call prwf$$ (k$posn + k$prea, file_unit, null (), 0, 0, rnw, code); /* Rewind the file. */
  2697.    if code ^= 0 then
  2698.       do;
  2699.          call get_error_msg (code);
  2700.          snd_msg = 'Unable to position to the beginning of the file. ' || errmsg;
  2701.          call send_packet (msg_error, length (snd_msg), msg_number);
  2702.       end;
  2703.    else
  2704.       do;
  2705.          file_pos = 0;
  2706.          ibuflen = 0;
  2707.          ibuf_ptr = 1;
  2708.          key = file_type;     /* Keep this for later. */
  2709.          file_type = ascii_ft;
  2710.          if ^explicit_pound_set then
  2711.             pound_conversion = true;
  2712.          ibuffer = '';
  2713.  
  2714.          state = state_x;     /* Send the file as text to be typed to the user. */
  2715.          call send_switch;
  2716.  
  2717.          file_type = key;     /* Reset the file type. */
  2718.       end;
  2719.  
  2720.    return;
  2721.  
  2722.    end;       /* Xsend_file */
  2723.  
  2724.    end;    /* Generic_cmd */
  2725. -------------------------------------------------------------------------------
  2726.  
  2727. /* GET_ATTR -- Get file attributes and put them in SND_MSG. */
  2728.  
  2729. Get_attr : proc;
  2730.  
  2731. $Insert *>insert>kermit.ins.plp
  2732. $Insert *>insert>common.ins.plp
  2733. $Insert *>insert>constants.ins.plp
  2734.  
  2735. %Replace primos by 'G';
  2736.  
  2737. Dcl 1 a_sub_pkt,
  2738.       2  type char (1),
  2739.       2  pkt_len char (1),
  2740.       2  data char (32) var;
  2741.  
  2742. Dcl sub_pkt_ptr ptr;
  2743.  
  2744. /* ************************************************************************* */
  2745.  
  2746.    sub_pkt_ptr = addr (a_sub_pkt);
  2747.  
  2748.    a_sub_pkt.type = '.';              /* Set up machine/OS sub-packet. */
  2749.    char2_ptr -> fb15_based = 33;              /* i.e. 1 + 32 */
  2750.    a_sub_pkt.pkt_len = char2(2);
  2751.    a_sub_pkt.data = primos;
  2752.    snd_msg = sub_pkt_ptr -> char2_based || a_sub_pkt.data;
  2753.  
  2754.    a_sub_pkt.type = '!';              /* Set up kbyte length sub-packet. */
  2755.    a_sub_pkt.data = trim (char (divide (file_len + 1023, 1024, 31)), '11'b);
  2756.    char2_ptr -> fb15_based = length (a_sub_pkt.data) + 32;
  2757.    a_sub_pkt.pkt_len = char2(2);
  2758.    snd_msg = snd_msg || sub_pkt_ptr -> char2_based || a_sub_pkt.data;
  2759.  
  2760.    a_sub_pkt.data = get_dtc ();       /* Set up DTC sub-packet. */
  2761.    if a_sub_pkt.data ^= '' then
  2762.       do;
  2763.          a_sub_pkt.type = '#';
  2764.          char2_ptr -> fb15_based = length (a_sub_pkt.data) + 32;
  2765.          a_sub_pkt.pkt_len = char2(2);
  2766.          snd_msg = snd_msg || sub_pkt_ptr -> char2_based || a_sub_pkt.data;
  2767.       end;
  2768.  
  2769.    a_sub_pkt.type = '1';        /* Set up the byte file length sub-packet. */
  2770.    a_sub_pkt.data = trim (char (file_len), '11'b);
  2771.    char2_ptr -> fb15_based = length (a_sub_pkt.data) + 32;
  2772.    a_sub_pkt.pkt_len = char2(2);
  2773.    snd_msg = snd_msg || sub_pkt_ptr -> char2_based || a_sub_pkt.data;
  2774.  
  2775.    if file_type = ascii_ft | file_type = binary_ft then
  2776.       do;
  2777.          a_sub_pkt.type = '"';
  2778.  
  2779.          if file_type = ascii_ft then
  2780.             a_sub_pkt.data = 'A';
  2781.          else
  2782.             a_sub_pkt.data = 'B';
  2783.  
  2784.          char2_ptr -> fb15_based = 33;
  2785.          a_sub_pkt.pkt_len = char2(2);
  2786.  
  2787.          snd_msg = snd_msg || sub_pkt_ptr -> char2_based || a_sub_pkt.data;
  2788.       end;
  2789.  
  2790.    return;
  2791.  
  2792.    end;       /* Get_attr */
  2793. -------------------------------------------------------------------------------
  2794.  
  2795. /* GET_DTC -- Get the DTC of the file given by "path_name". */
  2796.  
  2797. Get_dtc : proc returns (char (32) var);
  2798.  
  2799. $Insert *>insert>common.ins.plp
  2800. $Insert *>insert>kermit.ins.plp
  2801. $Insert *>insert>primos.ins.plp
  2802. $Insert syscom>keys.ins.pl1
  2803.  
  2804. Dcl (type, code, dow, funit, sufusd) fixed bin,
  2805.     formatted_date char (21),
  2806.     (buffer, basename) char (32) var;
  2807.  
  2808. /* ************************************************************************* */
  2809.  
  2810.    buffer = '';
  2811.  
  2812.    call srsfx$ (k$read + k$getu, dir_name, funit, type, 0, '', basename, sufusd, code);
  2813.    if code ^= 0 then
  2814.       do;
  2815.          call get_error_msg (code);
  2816.          call ioa$ ('Unable to open the directory %v. %v%.', 99, dir_name, errmsg);
  2817.          return (buffer);
  2818.       end;
  2819.  
  2820.    call ent$rd (funit, file_name, dir_entry_ptr, dir_entry_size, code);
  2821.    call clo$fu (funit, sufusd);        /* We don't need this anymore. */
  2822.    if code ^= 0 then
  2823.       do;
  2824.          call get_error_msg (code);
  2825.          call ioa$ ('Unable to read the directory entry for file %v. %v%.', 99, file_name, errmsg);
  2826.          return (buffer);
  2827.       end;
  2828.  
  2829.    call cv$fda (dir_entry.dtc, dow, formatted_date);
  2830.    if dow >= 0 then
  2831.       buffer = '19' || substr (formatted_date, 1, 2) || substr (formatted_date, 4, 2) ||
  2832.                substr (formatted_date, 7, 2) || ' ' || substr (formatted_date, 10, 8);
  2833.  
  2834.    return (buffer);
  2835.  
  2836.    end;      /* Get_dtc */
  2837. -------------------------------------------------------------------------------
  2838.  
  2839. /* GET_ERROR_MSG -- Get the PRIMOS error message from the given code. */
  2840.  
  2841. Get_error_msg : proc (code);
  2842.  
  2843. Dcl code fixed bin;
  2844.  
  2845. $Insert *>insert>common.ins.plp
  2846. $Insert *>insert>primos.ins.plp
  2847.  
  2848. /* ************************************************************************* */
  2849.  
  2850.    call ertxt$ (code, errmsg);
  2851.  
  2852.    if errmsg = '' then
  2853.       errmsg = '(Code = ' || trim (char (code), '11'b) || ')';
  2854.  
  2855.    return;
  2856.  
  2857.    end;       /* Get_error_msg */
  2858. -------------------------------------------------------------------------------
  2859.  
  2860. /* GET_LEN -- Determine logical length of file in bytes. */
  2861.  
  2862. Get_len : proc returns (fixed bin);
  2863.  
  2864. $Insert *>insert>common.ins.plp
  2865. $Insert *>insert>primos.ins.plp
  2866. $Insert *>insert>constants.ins.plp
  2867. $Insert syscom>keys.ins.pl1
  2868. $Insert syscom>errd.ins.pl1
  2869.  
  2870. Dcl (unit2, sufusd, type ,code, rnw) fixed bin,
  2871.     basename char (32) var;
  2872.  
  2873. /* ************************************************************************* */
  2874.  
  2875.    file_len = 0;
  2876.    file_pos = 0;
  2877.  
  2878.    /* The following call will work, but for large SAM files
  2879.       it may hold the file system lock for a time. */
  2880.  
  2881.    call prwf$$ (k$posn + k$prea, file_unit, null (), 0, bignum, rnw, code);
  2882.    if code = 0 then
  2883.       code = e$fitb;            /* The file is too big! */
  2884.  
  2885.    if code = e$eof then         /* Determine the EOF position. */
  2886.       call prwf$$ (k$rpos, file_unit, null (), 0, file_len, rnw, code);
  2887.  
  2888.    if code = e$eof then
  2889.       do;
  2890.          code = 0;              /* This will allow for empty files. */
  2891.          file_len = 0;
  2892.  
  2893.          return (code);
  2894.       end;
  2895.  
  2896.    if code ^= 0 then
  2897.       return (code);
  2898.  
  2899.    file_len = 2 * file_len;
  2900.    file_pos = file_len;
  2901.  
  2902.    /* PRIMOS keeps the file length in 2 byte words. The Kermit upload
  2903.       process will change the files read/write lock if the last byte is
  2904.       not significant. So we must now check the files read/write lock. */
  2905.  
  2906.    call srsfx$ (k$read + k$getu, dir_name, unit2, type, 0, '', basename, sufusd, code);
  2907.    if code ^= 0 then
  2908.       return (code);
  2909.  
  2910.    call ent$rd (unit2, file_name, dir_entry_ptr, dir_entry_size, code);
  2911.    call clo$fu (unit2, sufusd);        /* We don't need this anymore. */
  2912.    if code ^= 0 then
  2913.       return (code);
  2914.  
  2915.    if dir_entry.file_info.rwlock = k$none then
  2916.       file_len = file_len - 1;
  2917.  
  2918.    call prwf$$ (k$posn + k$prea, file_unit, null (), 0, 0, rnw, code); /* Rewind the file. */
  2919.    if code = 0 then
  2920.       file_pos = 0;
  2921.  
  2922.    return (code);
  2923.  
  2924.    end;       /* Get_len */
  2925. -------------------------------------------------------------------------------
  2926.  
  2927. /* KERMIT -- Main Kermit subroutine. */
  2928.  
  2929. Kermit : proc (cmd_line, code, com_name);
  2930.  
  2931. Dcl cmd_line char (256) var,
  2932.     com_name char (32) var,
  2933.     code fixed bin;
  2934.  
  2935. $Insert *>insert>common.ins.plp
  2936. $Insert *>insert>kermit.ins.plp
  2937. $Insert *>insert>primos.ins.plp
  2938. $Insert *>insert>constants.ins.plp
  2939. $Insert syscom>keys.ins.pl1
  2940. $Insert syscom>errd.ins.pl1
  2941.  
  2942. %Replace cl_width by 64;
  2943.  
  2944. Dcl cl_pic (11) char (cl_width) var static init (
  2945.     '-r, -rec, -receive tree;',
  2946.     '-s, -send tree;',
  2947.     '-a, -as, -alt, -alternate entry;',
  2948.     '-l, -log tree;',
  2949.     '-ft, -file, -file_type, -st, -store, -storage_type char;',
  2950.     '-p, -par, -parity char;',
  2951.     '-h, -help;',
  2952.     '-u, -usage;',
  2953.     '-ser, -server;',
  2954.     '-pou, -pound char;',
  2955.     'end' );
  2956.  
  2957. Dcl 1 cl_struc external,
  2958.       2 rec_flag bit (1) aligned,
  2959.       2 rec_path char (128) var,
  2960.       2 send_flag bit (1) aligned,
  2961.       2 send_path char (128) var,
  2962.       2 alt_flag bit (1) aligned,
  2963.       2 alt_name char (32) var,
  2964.       2 log_flag bit (1) aligned,
  2965.       2 log_path char (128) var,
  2966.       2 storage_flag bit (1) aligned,
  2967.       2 storage_type char (80) var,
  2968.       2 parity_flag bit (1) aligned,
  2969.       2 parity_type char (80) var,
  2970.       2 help_flag bit (1) aligned,
  2971.       2 usage_flag bit (1) aligned,
  2972.       2 ser_flag bit (1) aligned,
  2973.       2 pound_flag bit (1) aligned,
  2974.       2 pound_option char (80) var;
  2975.  
  2976. Dcl quit char (5) var,
  2977.     alarm char (6) var,
  2978.     (pix_index, bad_index) fixed bin;
  2979.  
  2980. /* ************************************************************************* */
  2981.  
  2982.    code = 0;
  2983.  
  2984.    call kermit_init;
  2985.  
  2986.    brk_lbl = done;
  2987.    quit = 'QUIT$';
  2988.    call mkonu$ (quit, bk_hndlr);          /* On-unit for quits. */
  2989.  
  2990.    alarm = 'ALARM$';
  2991.    call mkonu$ (alarm, timeout_hndlr);    /* On-unit for timeouts. */
  2992.  
  2993.    call cl$pix ('0002'b4, com_name, addr (cl_pic), cl_width, cmd_line,
  2994.                 addr (cl_struc), pix_index, bad_index, code);
  2995.    if code ^= 0 then
  2996.       return;
  2997.  
  2998.    if cl_struc.help_flag then
  2999.       do;
  3000.          call print_cl_help;
  3001.          return;
  3002.       end;
  3003.  
  3004.    if cl_struc.usage_flag then
  3005.       do;
  3006.          call print_cl_usage;
  3007.          return;
  3008.       end;
  3009.  
  3010.    if (cl_struc.rec_flag & (cl_struc.send_flag | cl_struc.ser_flag)) |
  3011.       (cl_struc.send_flag & cl_struc.ser_flag) then
  3012.       do;
  3013.          code = e$null;
  3014.          call tnou ('Incompatible options; only ONE of SEND, RECEIVE, or SERVER may be given.', 72);
  3015.          return;
  3016.       end;
  3017.  
  3018.    explicit_pound_set = cl_struc.pound_flag;
  3019.  
  3020.    if cl_struc.pound_flag then
  3021.       select (cl_struc.pound_option);
  3022.  
  3023.          when ('OFF', 'N', 'NO')
  3024.             pound_conversion = false;
  3025.  
  3026.          when ('', 'ON', 'Y', 'YES')
  3027.             do;
  3028.                pound_conversion = true;
  3029.                if cl_struc.pound_option = '' then
  3030.                   call tnou ('No POUND option given, defaulting to ON for pound sign conversion.', 66);
  3031.             end;
  3032.  
  3033.          otherwise
  3034.             do;
  3035.                pound_conversion = true;
  3036.                call ioa$ ('Unknown POUND option "%v", defaulting to ON for pound sign conversion.%.',
  3037.                           99, cl_struc.pound_option);
  3038.             end;
  3039.  
  3040.       end;
  3041.  
  3042.    explicit_ft_set = cl_struc.storage_flag;
  3043.  
  3044.    if cl_struc.storage_flag then
  3045.       select (cl_struc.storage_type);
  3046.  
  3047.          when ('AS', 'ASC', 'ASCII', 'T', 'TEXT')
  3048.             file_type = ascii_ft;
  3049.  
  3050.          when ('B', 'BIN', 'BINARY', 'I', 'IMAGE')
  3051.             do;
  3052.                file_type = binary_ft;
  3053.                if ^explicit_pound_set then   /* We DON'T want this for binaries. */
  3054.                   pound_conversion = false;
  3055.             end;
  3056.  
  3057.          when ('', 'AU', 'AUTO', 'AUTOMATIC')
  3058.             do;
  3059.                file_type = automatic_ft;
  3060.                explicit_ft_set = false;      /* Assume we haven't set it. */
  3061.                if cl_struc.storage_type = '' then
  3062.                   call tnou ('No FILE TYPE specified, defaulting to AUTOMATIC.', 51);
  3063.             end;
  3064.  
  3065.          otherwise
  3066.             do;
  3067.                file_type = automatic_ft;
  3068.                explicit_ft_set = false;
  3069.                call ioa$ ('Unknown FILE TYPE "%v", defaulting to AUTOMATIC.%.', 99, cl_struc.storage_type);
  3070.             end;
  3071.  
  3072.       end;
  3073.  
  3074.    if cl_struc.parity_flag then
  3075.       select (cl_struc.parity_type);
  3076.  
  3077.          when ('', 'M', 'MARK')
  3078.             do;           /* No need to check the 8-bit quoting since it hasn't changed yet. */
  3079.                do_transparent = false;
  3080.                do_8bit_chks = false;
  3081.  
  3082.                if cl_struc.parity_type = '' then
  3083.                   call tnou ('No PARITY type specified, defaulting to MARK.', 45);
  3084.             end;
  3085.  
  3086.          when ('N', 'NONE')
  3087.             do;
  3088.                do_transparent = true;
  3089.                do_8bit_chks = true;
  3090.                loc_8quote_chr = 'Y';
  3091.             end;
  3092.  
  3093.          otherwise
  3094.             do;
  3095.                do_transparent = false;
  3096.                do_8bit_chks = false;
  3097.                call ioa$ ('Unknown PARITY type "%v", defaulting to MARK.%.', 99, cl_struc.parity_type);
  3098.             end;
  3099.  
  3100.       end;
  3101.  
  3102.    if cl_struc.alt_flag then
  3103.       if cl_struc.alt_name = '' then
  3104.          call tnou ('No ALTERNATE file name specified, none being used.', 50);
  3105.       else
  3106.          if fnchk$ (k$uprc, cl_struc.alt_name) then
  3107.             alternate_fname = cl_struc.alt_name;
  3108.          else
  3109.             do;
  3110.                code = e$bnam;
  3111.                call ioa$ ('Invalid ALTERNATE file name "%v".%.', 99, cl_struc.alt_name);
  3112.                return;
  3113.             end;
  3114.  
  3115.    if cl_struc.log_flag then  /* No log file opened yet, so no need to check. */
  3116.  
  3117.       call start_log_file;
  3118.  
  3119.    if cl_struc.rec_flag then
  3120.       call rec_setup;
  3121.    else
  3122.       if cl_struc.send_flag then
  3123.          if cl_struc.send_path = '' then
  3124.             do;
  3125.                call tnou ('No SEND pathname given; Interactive mode will be used.', 54);
  3126.                call comnd;
  3127.             end;
  3128.          else
  3129.             if tnchk$ (k$uprc + k$wldc, cl_struc.send_path) then
  3130.                call send_setup;
  3131.             else
  3132.                do;
  3133.                   code = e$itre;
  3134.                   call ioa$ ('Invalid SEND pathname(s) "%v".%.', 99, cl_struc.send_path);
  3135.                end;
  3136.       else
  3137.          if cl_struc.ser_flag then
  3138.             call server_setup;
  3139.          else
  3140.             call comnd;
  3141.  
  3142. Done :      /* Return point for the QUIT$ on-unit. */
  3143.             /* Since we are returning to PRIMOS we will close these files. */
  3144.  
  3145.    if take_level > 0 then
  3146.       do;
  3147.          call comi$$ ('TTY', 3, take_unit(take_level), bad_index);
  3148.  
  3149.          take_level = take_level - 1;
  3150.          do pix_index = 1 to take_level;
  3151.             call clo$fu (take_unit(pix_index), bad_index);
  3152.          end;
  3153.       end;
  3154.  
  3155.    if file_opened then
  3156.       call clo$fu (file_unit, bad_index);
  3157.  
  3158.    if log_opened then
  3159.       call clo$fu (log_unit, bad_index);
  3160.  
  3161.    return;
  3162.  
  3163. /* ******************************* Rec_setup ******************************* */
  3164.  
  3165. /* REC_SETUP -- Setup to receive a file. */
  3166.  
  3167. Rec_setup : proc;
  3168.  
  3169. /* ************************************************************************* */
  3170.  
  3171.    call xfer_mode (1, code);            /* Switch to transfer mode. */
  3172.    if code ^= 0 then
  3173.       return;
  3174.  
  3175.    state = state_r;
  3176.    call set_path (cl_struc.rec_path);
  3177.    call tnou ('Kermit receive started.', 23);
  3178.  
  3179.    call rec_switch ();         /* Start receiving now. */
  3180.  
  3181.    call xfer_mode (0, code);
  3182.  
  3183.    return;
  3184.  
  3185.    end;      /* Rec_setup */
  3186.  
  3187. /* ****************************** Send_setup ******************************* */
  3188.  
  3189. /* SEND_SETUP -- Setup to send a group of files. */
  3190.  
  3191. Send_setup : proc;
  3192.  
  3193. /* ************************************************************************* */
  3194.  
  3195.    call xfer_mode (1, code);           /* Switch to transfer mode. */
  3196.    if code ^= 0 then
  3197.       return;
  3198.  
  3199.    state = state_s;
  3200.    call set_path (cl_struc.send_path);
  3201.    call tnou ('Kermit send started.', 20);
  3202.  
  3203.    call send_switch ();                /* Start sending now. */
  3204.  
  3205.    call xfer_mode (0, code);
  3206.  
  3207.    return;
  3208.  
  3209.    end;        /* Send_setup */
  3210.  
  3211. /* ***************************** Server_setup ****************************** */
  3212.  
  3213. /* SERVER_SETUP -- Setup to start server. */
  3214.  
  3215. Server_setup : proc;
  3216.  
  3217. /* ************************************************************************* */
  3218.  
  3219.    call xfer_mode (1, code);          /* Switch to transfer mode. */
  3220.    if code ^= 0 then
  3221.       return;
  3222.  
  3223.    call tnou ('Kermit server started.', 22);
  3224.  
  3225.    call server;
  3226.  
  3227.    call xfer_mode (0, code);
  3228.  
  3229.    return;
  3230.  
  3231.    end;      /* Server_setup */
  3232.  
  3233. /* ***************************** Print_cl_usage **************************** */
  3234.  
  3235. Print_cl_usage : proc;
  3236.  
  3237. /* ************************************************************************* */
  3238.  
  3239.    bad_index = length (com_name) + 10;
  3240.  
  3241.    call ioa$ ('%/ Usage : %v [{-Receive [pathname] | -Send wildcard | -SERver}]%.', 99, com_name);
  3242.    call ioa$ ('%#x[-Alternate filename] [-Log [pathname]] [-Parity {MARK | NONE}]%.', 99, bad_index);
  3243.    call ioa$ ('%#x[-File_Type {AUTOMATIC | TEXT | BINARY}]%.', 99, bad_index);
  3244.    call ioa$ ('%#x[-POUnd {ON | OFF}] [-Help] [-Usage]%/%.', 99, bad_index);
  3245.  
  3246.    return;
  3247.  
  3248.    end;       /* Print_cl_usage */
  3249.  
  3250. /* ***************************** Print_cl_help ***************************** */
  3251.  
  3252. Print_cl_help : proc;
  3253.  
  3254. Dcl ans char (16) var;
  3255.  
  3256. /* ************************************************************************* */
  3257.  
  3258.    call print_cl_usage;
  3259.  
  3260.    call ioa$ (' The first three options are mutually exclusive, but if none are specified%.', 99);
  3261.    call ioa$ (' then the user enters an interactive mode and is prompted for commands. All%.', 99);
  3262.    call ioa$ (' of the options may be abbreviated to those letters in uppercase.%/%.', 99);
  3263.    call ioa$ (' The options are :%/%.', 99);
  3264.    call ioa$ ('%5x-Receive [pathname]%/%8xUpload ONE file with the specified name or its original filename.%.', 199);
  3265.    call ioa$ ('%/%5x-Send wildcard%/%8xDownload several files. Wildcards may be used, but the -ALTERNATE%.', 99);
  3266.    call ioa$ ('%8xoption is then ignored.%.', 99);
  3267.    call ioa$ ('%/%5x-SERver%/%8xEnter server mode. Files may be sent and received, and additional%.', 99);
  3268.    call ioa$ ('%8xcommands may be issued.%.', 99);
  3269.  
  3270.    ans = '';
  3271.    call tnoua ('More ? ', 7);
  3272.    call cl$get (ans, 16, code);
  3273.    if code ^= 0 then
  3274.       do;
  3275.          call get_error_msg (code);
  3276.          call ioa$ ('Error reading the command line. %v%.', 99, errmsg);
  3277.          return;
  3278.       end;
  3279.  
  3280.    if length (ans) > 0 then
  3281.       ans = translate (substr (trim (ans, '11'b), 1, 1), uppercase, lowercase);
  3282.    if ans ^= 'Y' & ans ^= '' then
  3283.       return;
  3284.  
  3285.    call ioa$ ('%/%5x-Alternate filename%/%8xAlternate file name for when ONE file is being sent.%.', 99);
  3286.    call ioa$ ('%/%5x-File_Type {AUTOMATIC | TEXT | BINARY}%/%8xSpecifies the type of file, %$', 99);
  3287.    call ioa$ ('or if AUTOMATIC is used then Kermit%.', 99);
  3288.    call ioa$ ('%8xwill try to determine its type. Default is AUTOMATIC.%.', 99);
  3289.    call ioa$ ('%/%5x-Parity {MARK | NONE}%/%8xSpecifies the character parity to %$', 99);
  3290.    call ioa$ ('use. Default is MARK.%.', 99);
  3291.    call ioa$ ('%/%5x-Log [pathname]%/%8xOpens a log file for recording the packets %$', 99);
  3292.    call ioa$ ('sent and received.%/%8xDefault log file name is KERMIT.LOG%.', 99);
  3293.    call ioa$ ('%/%5x-POUnd {ON | OFF}%/%8xDetermines whether to convert DOS %$', 99);
  3294.    call ioa$ ('pound signs. Default is ON.%.', 99);
  3295.    call ioa$ ('%/%5x-Help%/%8xDisplays this HELP message.%.', 99);
  3296.    call ioa$ ('%/%5x-Usage%/%8xDisplays the Kermit usage syntax only.%/%.', 99);
  3297.  
  3298.    return;
  3299.  
  3300.    end;       /* Print_cl_help */
  3301.  
  3302. /* ***************************** Start_log_file **************************** */
  3303.  
  3304. Start_log_file : proc;
  3305.  
  3306. /* ************************************************************************* */
  3307.  
  3308.    code = open_log (cl_struc.log_path);
  3309.    if code ^= 0 then
  3310.       do;
  3311.          call get_error_msg (code);
  3312.          call ioa$ ('Log file not opened. %v%.', 99, errmsg);
  3313.       end;
  3314.  
  3315.    return;
  3316.  
  3317.    end;        /* Start_log_file */
  3318.  
  3319.    end;    /* Kermit */
  3320. -------------------------------------------------------------------------------
  3321.  
  3322. /* KERMIT_INIT -- Initialize Kermit variables. */
  3323.  
  3324. Kermit_init : proc;
  3325.  
  3326. $Insert *>insert>common.ins.plp
  3327. $Insert *>insert>kermit.ins.plp
  3328. $Insert *>insert>primos.ins.plp
  3329. $Insert *>insert>constants.ins.plp
  3330. $Insert syscom>keys.ins.pl1
  3331.  
  3332. Dcl (user_num, code) fixed bin,
  3333.     b8 bit (8) aligned,
  3334.     b8_ptr ptr,
  3335.     u_name char (32);
  3336.  
  3337. /* ************************************************************************* */
  3338.  
  3339.    b8_ptr = addr (b8);
  3340.    kversion = 'Public domain version 8.00';
  3341.    kprompt = 'Kermit-R21';
  3342.  
  3343.    delay = init_delay;
  3344.    rec_seq = 0;
  3345.    msg_number = 0;
  3346.    snd_msg = '';
  3347.    rec_msg = '';
  3348.    rec_pkt_type = '';
  3349.    rec_length = 0;
  3350.  
  3351.    rec_file_size = -1;           /* Received file attributes. */
  3352.    rec_file_dtc = -1;
  3353.    rec_file_type = automatic_ft;
  3354.    use_attributes = true;
  3355.  
  3356.    do user_num = 0 to 63;
  3357.       msg_table.slot(user_num).msg = '';
  3358.       msg_table.slot(user_num).acked = false;
  3359.       msg_table.slot(user_num).retries = 0;
  3360.    end;
  3361.  
  3362.    tab_first = 0;                    /* Default transfer parameters. */
  3363.    tab_next = 0;
  3364.    state = 0;
  3365.    num_retries = 0;
  3366.    quote8_char = 'N';
  3367.    file_type = automatic_ft;         /* Unknown file type. */
  3368.    explicit_ft_set = false;
  3369.    first_read = true;
  3370.    filename_warning = true;
  3371.    do_repeats = false;
  3372.    do_windowing = false;
  3373.    do_transparent = false;
  3374.    do_flush = true;
  3375.    do_8bit_chks = false;
  3376.    auto_sum = true;
  3377.    log_opened = false;
  3378.    log_unit = 0;
  3379.    window_size = 1;
  3380.    errmsg = '';
  3381.  
  3382.    take_level = 0;
  3383.    do user_num = 1 to max_take_level;
  3384.       take_unit(user_num) = 0;
  3385.    end;
  3386.  
  3387.    loc_pkt_size = my_pkt_size;       /* Default send init parameters. */
  3388.    loc_npad = my_npad;
  3389.    b8 = my_pad_chr;
  3390.    loc_padchar = b8_ptr -> char1_based;
  3391.    loc_timeout = my_timeout;
  3392.    b8 = my_eol_chr;
  3393.    loc_eol = b8_ptr -> char1_based;
  3394.    loc_quote_chr = my_quote_chr;
  3395.    loc_8quote_chr = my_8quote_chr;
  3396.    loc_chk_type = my_chk_type;
  3397.    loc_rep_chr = my_rep_chr;
  3398.    loc_capas1 = my_capas1;
  3399.    loc_file_attrib = false;
  3400.    loc_windowing = false;
  3401.    loc_max_wsize = my_max_wsize;
  3402.  
  3403.    path_name = '';
  3404.    dir_name = '';
  3405.    non_null_dir = false;
  3406.    file_name = '';
  3407.    alternate_fname = '';
  3408.    file_unit = 0;
  3409.    file_opened = false;
  3410.    file_len = 0;
  3411.    file_pos = 0;
  3412.  
  3413.    do user_num = 1 to max_matches;
  3414.       matches(user_num) = '';
  3415.    end;
  3416.  
  3417.    num_matches = 0;
  3418.    file_idx = 0;
  3419.  
  3420.    del_incomplete = true;
  3421.    ibuffer = copy (' ', ibuffer_size);
  3422.    ibuffer_ptr = addr (ibuffer);
  3423.    ibuflen = 0;
  3424.    ibuf_ptr = 0;
  3425.    eol_flag = 0;
  3426.    char2_ptr = addr (char2);
  3427.    char2_ptr -> fb15_based = 0;
  3428.    pound_conversion = true;
  3429.    explicit_pound_set = false;
  3430.  
  3431.    do user_num = 0 to 255;
  3432.       trans_char(user_num) = '';
  3433.    end;
  3434.  
  3435.    dir_entry_ptr = addr (dir_entry);
  3436.  
  3437.    call erkl$$ (k$read, my_erase, my_kill, code); /* Keep these for our user. */
  3438.    if code ^= 0 then
  3439.       do;
  3440.          call get_error_msg (code);
  3441.          call ioa$ ('Error getting erase and kill characters. %v%.', 99, errmsg);
  3442.       end;
  3443.  
  3444.    my_duplex = duplx$ ('FFFF'b4);
  3445.  
  3446.    call user$ (user_num, code);    /* Get our MESSAGE status. */
  3447.    call msg$st (k$read, user_num, '', 0, u_name, 32, my_msg_state);
  3448.  
  3449.    b8 = '00'b4;                    /* Setup all the character codes we need. */
  3450.    nul_7bit_asc = b8_ptr -> char1_based;
  3451.    b8 = '80'b4;
  3452.    nul_8bit_asc = b8_ptr -> char1_based;
  3453.  
  3454.    b8 = ctrl_a_7bit_dec;
  3455.    ctrl_a_7bit_asc = b8_ptr -> char1_based;
  3456.    b8 = ctrl_a_8bit_dec;
  3457.    ctrl_a_8bit_asc = b8_ptr -> char1_based;
  3458.  
  3459.    b8 = '08'b4;
  3460.    bs_7bit_asc = b8_ptr -> char1_based;
  3461.  
  3462.    b8 = cr_7bit_dec;
  3463.    cr_7bit_asc = b8_ptr -> char1_based;
  3464.  
  3465.    rem_eol = cr_7bit_asc;        /* We need this for the FIRST packet sent. */
  3466.  
  3467.    b8 = cr_8bit_dec;
  3468.    cr_8bit_asc = b8_ptr -> char1_based;
  3469.  
  3470.    b8 = lf_7bit_dec;
  3471.    lf_7bit_asc = b8_ptr -> char1_based;
  3472.  
  3473.    b8 = lf_8bit_dec;
  3474.    lf_8bit_asc = b8_ptr -> char1_based;
  3475.  
  3476.    b8 = '0C'b4;
  3477.    ff_7bit_asc = b8_ptr -> char1_based;
  3478.  
  3479.    b8 = '91'b4;
  3480.    dc1_8bit_asc = b8_ptr -> char1_based;
  3481.  
  3482.    b8 = '1A'b4;
  3483.    ctrl_z_7bit_asc = b8_ptr -> char1_based;
  3484.    b8 = '9A'b4;
  3485.    ctrl_z_8bit_asc = b8_ptr -> char1_based;
  3486.  
  3487.    b8 = '3F'b4;
  3488.    query_7bit_asc = b8_ptr -> char1_based;
  3489.  
  3490.    b8 = '60'b4;
  3491.    grave_7bit_asc = b8_ptr -> char1_based;
  3492.  
  3493.    return;
  3494.  
  3495.    end;         /* Kermit_init */
  3496. -------------------------------------------------------------------------------
  3497.  
  3498. /* LOG_INFO -- Log one line of info to log file. */
  3499.  
  3500. Log_info : proc (data);
  3501.  
  3502. Dcl data char (256) var;
  3503.  
  3504. $Insert *>insert>common.ins.plp
  3505. $Insert *>insert>kermit.ins.plp
  3506. $Insert *>insert>primos.ins.plp
  3507. $Insert *>insert>constants.ins.plp
  3508.  
  3509. Dcl code fixed bin;
  3510.  
  3511. /* ************************************************************************* */
  3512.  
  3513.    if log_opened then
  3514.       do;
  3515.          call wtlin$ (log_unit, ('---- ' || data || '  '),
  3516.                       divide (length (data) + 6, 2, 15), code);
  3517.          if code ^= 0 then
  3518.             do;
  3519.                call get_error_msg (code);
  3520.                call ioa$ ('Unable to write to the log file. %v%/Closing the log file.%.',
  3521.                           99, errmsg);
  3522.                log_opened = false;
  3523.                call clo$fu (log_unit, code);
  3524.             end;
  3525.       end;
  3526.  
  3527.    return;
  3528.  
  3529.    end;    /* Log_info */
  3530. -------------------------------------------------------------------------------
  3531.  
  3532. /* LOG_PACKET -- Log Kermit packet to disk. */
  3533.  
  3534. Log_packet : proc (packet_type, seq_num, data);
  3535.  
  3536. $Insert *>insert>common.ins.plp
  3537.  
  3538. Dcl packet_type char (1),
  3539.     seq_num fixed bin,
  3540.     data char (max_msg) var;
  3541.  
  3542. $Insert *>insert>kermit.ins.plp
  3543. $Insert *>insert>primos.ins.plp
  3544. $Insert *>insert>constants.ins.plp
  3545.  
  3546. Dcl line char (256) var,
  3547.     code fixed bin;
  3548.  
  3549. /* ************************************************************************* */
  3550.  
  3551.    if ^log_opened then
  3552.       return;
  3553.  
  3554.    select (packet_type);
  3555.  
  3556.       when (msg_data)
  3557.          line = 'DATA ';
  3558.  
  3559.       when (msg_attrib)
  3560.          line = 'ATTR ';
  3561.  
  3562.       when (msg_ack)
  3563.          line = 'ACK  ';
  3564.  
  3565.       when (msg_nak)
  3566.          line = 'NAK  ';
  3567.  
  3568.       when (msg_snd_init)
  3569.          line = 'SNDI ';
  3570.  
  3571.       when (msg_break)
  3572.          line = 'BRK  ';
  3573.  
  3574.       when (msg_file)
  3575.          line = 'FILE ';
  3576.  
  3577.       when (msg_eof)
  3578.          line = 'EOF  ';
  3579.  
  3580.       when (msg_error)
  3581.          line = 'ERR  ';
  3582.  
  3583.       when (msg_rcv_init)
  3584.          line = 'RCVI ';
  3585.  
  3586.       when (msg_host_command)
  3587.          line = 'HOST ';
  3588.  
  3589.       when (msg_text)
  3590.          line = 'TEXT ';
  3591.  
  3592.       when (msg_init_info)
  3593.          line = 'INIT ';
  3594.  
  3595.       when (msg_kermit)
  3596.          line = 'KER  ';
  3597.  
  3598.       when (msg_kermit_generic)
  3599.          line = 'GEN  ';
  3600.  
  3601.       when (msg_timeout)
  3602.          line = 'TIME ';
  3603.  
  3604.       when (msg_check_err)
  3605.          line = 'CHK  ';
  3606.  
  3607.       otherwise
  3608.          line = '?? ' || packet_type || ' ';
  3609.  
  3610.    end;
  3611.  
  3612.    if seq_num < 10 then
  3613.       line = line || ' ';
  3614.  
  3615.    line = line || trim (char (seq_num), '11'b);     /* Append the seq. number. */
  3616.  
  3617.    if data ^= '' then                          /* Append the data. */
  3618.       line = line || ' "' || data || '"';
  3619.  
  3620.    call wtlin$ (log_unit, (line || '  '), divide (length (line) + 1, 2, 15), code);
  3621.    if code ^= 0 then
  3622.       do;
  3623.          call get_error_msg (code);
  3624.          call ioa$ ('Unable to log the packet. %v%/Closing the log file. %.', 99, errmsg);
  3625.          log_opened = false;
  3626.          call clo$fu (log_unit, code);
  3627.       end;
  3628.  
  3629.    return;
  3630.  
  3631.    end;        /* Log_packet */
  3632. -------------------------------------------------------------------------------
  3633.  
  3634. /* MATCH_FILE -- Match a wildcard spec from user to determine filenames. */
  3635.  
  3636. Match_file : proc returns (fixed bin);
  3637.  
  3638. $Insert *>insert>common.ins.plp
  3639. $Insert *>insert>kermit.ins.plp
  3640. $Insert *>insert>primos.ins.plp
  3641. $Insert syscom>keys.ins.pl1
  3642. $Insert syscom>errd.ins.pl1
  3643.  
  3644. Dcl (dir_unit, type, sufusd, code) fixed bin,
  3645.     (basename, fn, wild_name) char (32) var;
  3646.  
  3647. /* ************************************************************************* */
  3648.  
  3649.    code = 0;
  3650.    num_matches = 0;
  3651.  
  3652.    /* First we convert the filename to uppercase, and translate any
  3653.       wildcard characters from DOS to the PRIME equivelent. Apart from
  3654.       the one case below we cannot fully translate the wildcards, since
  3655.       we don't know what the user actually means.
  3656.  
  3657.       E.g. Given the file A.B.C, if the user types *.C do they just mean
  3658.            the files @.C, or do they mean @@.C which would include A.B.C. */
  3659.  
  3660.    if file_name = '*.*' then
  3661.       if non_null_dir then
  3662.          path_name = dir_name || '>@@';
  3663.       else
  3664.          path_name = '@@';
  3665.  
  3666.    path_name = translate (path_name, uppercase || '@+', lowercase || '*?');
  3667.    call set_path (path_name);
  3668.  
  3669.    if search (path_name, '@+') = 0 then     /* See if we have just one file name. */
  3670.       do;
  3671.          num_matches = 1;
  3672.          matches(1) = path_name;
  3673.          return (code);
  3674.       end;
  3675.  
  3676.    if search (dir_name, '@+') ^= 0 then      /* Wildcarded directories ? */
  3677.       return (e$itre);
  3678.  
  3679.    wild_name = file_name;
  3680.  
  3681.    call srsfx$ (k$read + k$getu, dir_name, dir_unit, type, 0, '', basename, sufusd, code);
  3682.    if code ^= 0 then
  3683.       return (code);
  3684.  
  3685.    call dir$rd (k$init, dir_unit, dir_entry_ptr, dir_entry_size, code);
  3686.  
  3687.    do until (code ^= 0);
  3688.  
  3689.       call dir$rd (k$read, dir_unit, dir_entry_ptr, dir_entry_size, code);
  3690.  
  3691.       if code = 0 & dir_entry.ecw.type = '02'b4 &
  3692.          (dir_entry.file_info.type < '02'b4 | dir_entry.file_info.type = '07'b4) then
  3693.          do;                  /* It's an ordinary SAM, DAM, or CAM file. */
  3694.             fn = trim (dir_entry.entryname, '11'b);
  3695.             if wild$ (wild_name, fn, code) then
  3696.                do;
  3697.                   num_matches = num_matches + 1;
  3698.                   if num_matches <= max_matches then
  3699.                      matches(num_matches) = fn;
  3700.                   else
  3701.                      code = e$tmvv;         /* Too many values for variable. */
  3702.                end;
  3703.          end;
  3704.    end;
  3705.  
  3706.    call clo$fu (dir_unit, sufusd);
  3707.  
  3708.    if code = e$eof then
  3709.       code = 0;
  3710.  
  3711.    return (code);
  3712.  
  3713.    end;     /* Match_file */
  3714. -------------------------------------------------------------------------------
  3715.  
  3716. /* NEXT_FILE -- Fetch next file of wildcard specification. */
  3717.  
  3718. Next_file : proc returns (fixed bin);
  3719.  
  3720. $Insert *>insert>common.ins.plp
  3721. $Insert *>insert>kermit.ins.plp
  3722. $Insert *>insert>constants.ins.plp
  3723.  
  3724. Dcl code fixed bin,
  3725.     test_flag bit (1) aligned;
  3726.  
  3727. /* ************************************************************************* */
  3728.  
  3729.    test_flag = false;
  3730.  
  3731.    do until (test_flag);
  3732.       if file_idx > num_matches | file_idx = 0 then  /* Check for the end of the table. */
  3733.          return (ker_nomorfiles);
  3734.  
  3735.       call set_path (matches(file_idx));  /* Get the next file name. */
  3736.  
  3737.       code = open_input ();               /* Try to open the file. */
  3738.       if code ^= 0 then
  3739.          do;
  3740.             call get_error_msg (code);
  3741.             call log_info ('Error opening ' || path_name || '. ' || errmsg);
  3742.             file_idx = file_idx + 1;      /* Try the next file. */
  3743.          end;
  3744.       else
  3745.          do;
  3746.             test_flag = true;
  3747.  
  3748.             if log_opened then
  3749.                do;
  3750.                   select (file_type);
  3751.  
  3752.                      when (ascii_ft)
  3753.                         errmsg = 'as ASCII file type.';
  3754.  
  3755.                      when (binary_ft)
  3756.                         errmsg = 'as BINARY file type.';
  3757.  
  3758.                      when (automatic_ft)
  3759.                         errmsg = 'with AUTOMATIC file type detection.';
  3760.  
  3761.                      otherwise
  3762.                         errmsg = 'with an ILLEGAL file type.';
  3763.  
  3764.                   end;
  3765.  
  3766.                   call log_info ('File ' || path_name || ' opened ' || errmsg);
  3767.  
  3768.                   if explicit_ft_set then
  3769.                      call log_info ('The file type has been explicitly set.');
  3770.                   else
  3771.                      if file_type ^= automatic_ft then
  3772.                         call log_info ('The file type has been automatically set.');
  3773.                end;
  3774.          end;
  3775.  
  3776.    end;
  3777.  
  3778.    if num_matches = 1 & (alternate_fname ^= '') then  /* Use alternate name if given. */
  3779.       do;
  3780.          file_name = alternate_fname;
  3781.  
  3782.          if log_opened then
  3783.             call log_info ('The file ' || path_name || ' will be sent using the alternate file name of ' || alternate_fname);
  3784.  
  3785.          if ^non_null_dir then
  3786.             path_name = file_name;
  3787.          else
  3788.             path_name = dir_name || '>' || file_name;
  3789.       end;
  3790.  
  3791.    file_idx = file_idx + 1;               /* Point to next file name. */
  3792.  
  3793.    return (ker_normal);
  3794.  
  3795.    end;       /* Next_file */
  3796. -------------------------------------------------------------------------------
  3797.  
  3798. /* OPEN_INPUT -- Open input file, determine its type and length. */
  3799.  
  3800. Open_input : proc returns (fixed bin);
  3801.  
  3802. $Insert *>insert>common.ins.plp
  3803. $Insert *>insert>kermit.ins.plp
  3804. $Insert *>insert>primos.ins.plp
  3805. $Insert *>insert>constants.ins.plp
  3806. $Insert syscom>keys.ins.pl1
  3807. $Insert syscom>errd.ins.pl1
  3808.  
  3809. Dcl (type, code, rnw, code2, sufusd) fixed bin,
  3810.     basename char (32) var;
  3811.  
  3812. /* ************************************************************************* */
  3813.  
  3814.    call srsfx$ (k$read + k$getu, path_name, file_unit, type, 0, '', basename, sufusd, code);
  3815.  
  3816.    if type > 1 & type ^= 7 then
  3817.       do;
  3818.          call clo$fu (file_unit, code);
  3819.          code = e$wft;
  3820.       end;
  3821.  
  3822.    file_opened = (code = 0);
  3823.  
  3824.    if code ^= 0 then
  3825.       return (code);
  3826.  
  3827.    code = get_len ();
  3828.    if code = 0 then
  3829.       do;
  3830.          if file_type = automatic_ft then  /* AUTOMATIC file type detection. */
  3831.             call ck_file_type;
  3832.  
  3833.          if code = 0 then
  3834.             return (code);
  3835.       end;
  3836.  
  3837.    file_opened = false;     /* At this point something is wrong, so  close the file. */
  3838.    call clo$fu (file_unit, code2);
  3839.  
  3840.    return (code);
  3841.  
  3842. /* ****************************** Ck_file_type ***************************** */
  3843.  
  3844. Ck_file_type : proc;
  3845.  
  3846. Dcl (character, prev_char) char (1),
  3847.     character_ptr ptr;
  3848.  
  3849. Dcl 1 bit_char based,
  3850.       2 high_bit bit (1),
  3851.       2 rest bit (7);
  3852.  
  3853. /* ************************************************************************* */
  3854.  
  3855.    /* Initialize local variables for file type checking. */
  3856.  
  3857.    code = 0;
  3858.    character = nul_7bit_asc;
  3859.    character_ptr = addr (character);
  3860.  
  3861.    if file_len = 0 then
  3862.       do;                        /* This allows for empty files. */
  3863.          ibuflen = 0;
  3864.          file_type = ascii_ft;
  3865.          return;
  3866.       end;
  3867.  
  3868.    call prwf$$ (k$read, file_unit, ibuffer_ptr, ibuffer_size_wds, 0, rnw, code);
  3869.  
  3870.    if code = e$eof & rnw ^= 0 then
  3871.       code = 0;
  3872.  
  3873.    ibuflen = 2 * rnw;
  3874.    file_pos = ibuflen;
  3875.  
  3876.    if code ^= 0 then
  3877.       return;
  3878.  
  3879.    file_type = ascii_ft;         /* Assume it's ASCII to begin with. */
  3880.  
  3881.    do ibuf_ptr = 1 to ibuflen while (file_type ^= binary_ft); /* This is the main checking loop. */
  3882.  
  3883.       prev_char = character;
  3884.       character = substr (ibuffer, ibuf_ptr, 1);
  3885.  
  3886.    /* If the high bit is off then check for some special
  3887.       characters before deciding that it IS a binary file. */
  3888.  
  3889.       if ^character_ptr -> bit_char.high_bit then
  3890.          if prev_char ^= dc1_8bit_asc &        /* Space compression. */
  3891.             ^(prev_char = lf_8bit_asc & character = nul_7bit_asc) & /* LFNUL */
  3892.             ^(character = bs_7bit_asc |        /* Back Space. */
  3893.               character = ff_7bit_asc) &       /* Form Feed. */
  3894.             ^(character = ctrl_a_7bit_asc &  /* CTRL-A for FORTRAN formats. */
  3895.               (prev_char = lf_8bit_asc | prev_char = nul_7bit_asc | prev_char = ctrl_a_7bit_asc)) &
  3896.             character ^= ctrl_z_7bit_asc then
  3897.                  file_type = binary_ft;
  3898.  
  3899.    end;
  3900.  
  3901.    if file_type ^= binary_ft & file_len = ibuflen then  /* ASCII files must end in LF or CTRL-Z. */
  3902.       do;
  3903.          if character = nul_7bit_asc then
  3904.             character = prev_char;
  3905.  
  3906.          if ^(character = lf_8bit_asc | character = ctrl_z_7bit_asc) then
  3907.             file_type = binary_ft;
  3908.       end;
  3909.  
  3910.    if file_type = binary_ft & ^explicit_pound_set then
  3911.       pound_conversion = false;
  3912.  
  3913.    ibuflen = 0;             /* Re-initialize some of our buffer variables. */
  3914.    ibuf_ptr = 1;
  3915.    ibuffer = '';
  3916.  
  3917.    call prwf$$ (k$posn + k$prea, file_unit, null (), 0, 0, rnw, code);
  3918.  
  3919.    if code = 0 then
  3920.       file_pos = 0;
  3921.  
  3922.    return;
  3923.  
  3924.    end;        /* Ck_file_type */
  3925.  
  3926.    end;      /* Open_input */
  3927. -------------------------------------------------------------------------------
  3928.  
  3929. /* OPEN_LOG -- Open an output log file. */
  3930.  
  3931. Open_log : proc (pathname) returns (fixed bin);
  3932.  
  3933. Dcl pathname char (128) var;
  3934.  
  3935. $Insert *>insert>common.ins.plp
  3936. $Insert *>insert>primos.ins.plp
  3937. $Insert syscom>keys.ins.pl1
  3938. $Insert syscom>errd.ins.pl1
  3939.  
  3940. Dcl (type, sufusd, code) fixed bin,
  3941.     basename char (32) var,
  3942.     fn char (128) var;
  3943.  
  3944. /* ************************************************************************* */
  3945.  
  3946.    fn = pathname;
  3947.    if fn = '' then
  3948.       fn = 'kermit.log';
  3949.  
  3950.    call fil$dl (fn, code);       /* Delete any old file first, if possible. */
  3951.  
  3952.    if code = 0 | code = e$fntf then
  3953.       call srsfx$ (k$writ + k$getu, fn, log_unit, type, 0, '', basename, sufusd, code);
  3954.  
  3955.    log_opened = (code = 0);
  3956.  
  3957.    return (code);
  3958.  
  3959.    end;      /* Open_log */
  3960. -------------------------------------------------------------------------------
  3961.  
  3962. /* OPEN_OUTPUT -- Open an output file. */
  3963.  
  3964. Open_output : proc returns (fixed bin);
  3965.  
  3966. $Insert *>insert>kermit.ins.plp
  3967. $Insert *>insert>common.ins.plp
  3968. $Insert *>insert>primos.ins.plp
  3969. $Insert *>insert>constants.ins.plp
  3970. $Insert syscom>keys.ins.pl1
  3971. $Insert syscom>errd.ins.pl1
  3972.  
  3973. Dcl (type, sufusd, code, num_len, i) fixed bin,
  3974.     (file_exists, new_file_name, overwrite) bit (1) aligned,
  3975.     new_path_ptr ptr,
  3976.     (treename, new_path) char (128) var,
  3977.     (basename, suffix) char (32) var;
  3978.  
  3979. Dcl 1 bvs based,
  3980.       2 len fixed bin,
  3981.       2 chars char (128);
  3982.  
  3983. %Replace dot by '.';
  3984.  
  3985. /* ************************************************************************* */
  3986.  
  3987.    file_exists = false;
  3988.    file_opened = false;
  3989.    new_file_name = false;
  3990.  
  3991.    if non_null_dir then
  3992.       if ^tnchk$ (k$uprc, dir_name) then
  3993.          return (e$itre);                 /* A bad directory name given. */
  3994.  
  3995.    if ^fnchk$ (k$uprc, file_name) then
  3996.       do;                                 /* Replace a bad file name. */
  3997.          new_file_name = true;
  3998.          file_name = 'KERMIT_FILE';
  3999.  
  4000.          if ^non_null_dir then
  4001.             path_name = file_name;
  4002.          else
  4003.             path_name = dir_name || '>' || file_name;
  4004.       end;
  4005.  
  4006.    if filename_warning then
  4007.       do;
  4008.          call srsfx$ (k$exst, path_name, file_unit, type, 0, '', basename, sufusd, code);
  4009.          if code = 0 then
  4010.             do;
  4011.                file_exists = true;
  4012.                new_path_ptr = addr (new_path);
  4013.                overwrite = (length (file_name) = 32);
  4014.  
  4015.                if overwrite then      /* See if we overwrite or append to the file name. */
  4016.                   num_len = 1;
  4017.                else
  4018.                   do;
  4019.                      num_len = 32 - length (file_name);
  4020.                      if num_len > 4 then
  4021.                         num_len = 4;
  4022.                   end;
  4023.  
  4024.                if index (file_name, dot) ^= 0 then
  4025.                   do;
  4026.                      treename = before (file_name, dot);
  4027.                      suffix = dot || after (file_name, dot);
  4028.                   end;
  4029.                else
  4030.                   do;
  4031.                      treename = file_name;
  4032.                      suffix = '';
  4033.                   end;
  4034.  
  4035.                if overwrite then
  4036.                   treename = substr (treename, 1, length (treename) - 1);
  4037.  
  4038.                do i = 1 to 9999 until (code ^= 0);
  4039.                   if overwrite then
  4040.                      if i = 10 then
  4041.                         do;
  4042.                            num_len = 2;
  4043.                            treename = substr (treename, 1, length (treename) - 1);
  4044.                         end;
  4045.                      else
  4046.                         if i = 100 then
  4047.                            do;
  4048.                               num_len = 3;
  4049.                               treename = substr (treename, 1, length (treename) - 1);
  4050.                            end;
  4051.                         else
  4052.                            if i = 1000 then
  4053.                               do;
  4054.                                  num_len = 4;
  4055.                                  treename = substr (treename, 1, length (treename) - 1);
  4056.                               end;
  4057.  
  4058.                   call ioa$rs (new_path_ptr -> bvs.chars, 128, new_path_ptr -> bvs.len,
  4059.                                '%v%#zd%v%$', 99, treename, num_len, i, suffix);
  4060.  
  4061.                   call srsfx$ (k$exst, new_path, file_unit, type, 0, '', basename, sufusd, code);
  4062.                end;
  4063.  
  4064.                if code = e$fntf then
  4065.                   call set_path (new_path);
  4066.                else
  4067.                   if code = 0 then
  4068.                      code = e$ialn;
  4069.             end;
  4070.       end;
  4071.    else
  4072.       call fil$dl (path_name, code);
  4073.  
  4074.    if code = 0 | code = e$fntf then
  4075.       do;
  4076.          call srsfx$ (k$writ + k$getu, path_name, file_unit, type, 0, '', basename, sufusd, code);
  4077.          if code = 0 then
  4078.             do;
  4079.                ibuffer = '';
  4080.                ibuf_ptr = 0;
  4081.             end;
  4082.       end;
  4083.  
  4084.    file_opened = (code = 0);
  4085.  
  4086.    if code = 0 then
  4087.       if new_file_name then
  4088.          code = e$bnam;          /* Say that the file name was bad. */
  4089.       else
  4090.          if file_exists then     /* Say that the file already exists. */
  4091.             code = e$exst;
  4092.  
  4093.    return (code);
  4094.  
  4095.    end;         /* Open_output */
  4096. -------------------------------------------------------------------------------
  4097.  
  4098. /* PRS_SEND_INIT -- Parse SND_INIT packet from remote Kermit. */
  4099.  
  4100. Prs_send_init : proc;
  4101.  
  4102. $Insert *>insert>common.ins.plp
  4103. $Insert *>insert>kermit.ins.plp
  4104. $Insert *>insert>constants.ins.plp
  4105.  
  4106. Dcl (cap_len, cap_pos, cap_byte) fixed bin,
  4107.     cap_ptr ptr;
  4108.  
  4109. /* ************************************************************************* */
  4110.  
  4111.    rem_pkt_size = 80;   /* Set the default values for fields not received. */
  4112.    rem_npad = 0;
  4113.    rem_padchar = nul_7bit_asc;
  4114.    rem_pad_chars = copy (rem_padchar, max_rem_pad_chrs);  /* Never received. */
  4115.    rem_timeout = 1;                 /* Timeout in minutes. */
  4116.    rem_eol = cr_7bit_asc;
  4117.    rem_quote_chr = '#';
  4118.    rem_8quote_chr = 'N';
  4119.    rem_chk_type = '1';
  4120.    rem_rep_chr = ' ';
  4121.    rem_capas1 = 0;
  4122.    rem_file_attrib = false;
  4123.    rem_windowing = false;
  4124.    rem_max_wsize = 1;
  4125.  
  4126.    select (length (rec_msg) - pkt_tot_ovr_head);  /* Process the packet according to its length. */
  4127.  
  4128.       when (p_si_bufsiz)
  4129.          goto pkt_lbl;
  4130.  
  4131.       when (p_si_timout)
  4132.          goto to_lbl;
  4133.  
  4134.       when (p_si_npad)
  4135.          goto np_lbl;
  4136.  
  4137.       when (p_si_pad)
  4138.          goto pc_lbl;
  4139.  
  4140.       when (p_si_eol)
  4141.         goto eol_lbl;
  4142.  
  4143.       when (p_si_quote)
  4144.          goto qc_lbl;
  4145.  
  4146.       when (p_si_8quote)
  4147.          goto ebqc_lbl;
  4148.  
  4149.       when (p_si_chk)
  4150.          goto chk_lbl;
  4151.  
  4152.       when (p_si_rep)
  4153.          go to rep_lbl;
  4154.  
  4155.       when (0)
  4156.          return;
  4157.  
  4158.    end;
  4159.  
  4160.    /* Longer messages drop through to check the capabilities. */
  4161.  
  4162.    cap_ptr = addr (rem_capas1);
  4163.    rem_capas1 = knum (substr (rec_msg, pkt_msg + p_si_capas, 1));
  4164.    rem_file_attrib = cap_ptr -> capas.file_attributes;
  4165.    rem_windowing = cap_ptr -> capas.windowing;
  4166.  
  4167.    /* Find the end of the variable length capabilities field. */
  4168.  
  4169.    cap_len = 1;
  4170.    cap_byte = rem_capas1;
  4171.    cap_ptr = addr (cap_byte);
  4172.  
  4173.    do while (cap_ptr -> capas.continues);
  4174.       cap_len = cap_len + 1;
  4175.       cap_byte = knum (substr (rec_msg, pkt_msg + p_si_capas + cap_len - 1, 1));
  4176.    end;
  4177.  
  4178.    cap_pos = pkt_msg + p_si_capas + cap_len;
  4179.  
  4180.    if rem_windowing then             /* Get the maximum window size. */
  4181.       rem_max_wsize = knum (substr (rec_msg, cap_pos, 1));
  4182.  
  4183. Rep_lbl :
  4184.    rem_rep_chr = substr (rec_msg, pkt_msg + p_si_rep, 1);
  4185.  
  4186. Chk_lbl :
  4187.    rem_chk_type = substr (rec_msg, pkt_msg + p_si_chk, 1);
  4188.  
  4189. Ebqc_lbl :
  4190.    rem_8quote_chr = substr (rec_msg, pkt_msg + p_si_8quote, 1);
  4191.  
  4192. Qc_lbl :
  4193.    rem_quote_chr = substr (rec_msg, pkt_msg + p_si_quote, 1);
  4194.  
  4195. Eol_lbl :
  4196.    char2_ptr -> fb15_based = knum (substr (rec_msg, pkt_msg + p_si_eol, 1));
  4197.    rem_eol = char2(2);
  4198.  
  4199. Pc_lbl :
  4200.    rem_padchar = ctl (substr (rec_msg, pkt_msg + p_si_pad, 1));
  4201.    rem_pad_chars = copy (rem_padchar, max_rem_pad_chrs);
  4202.  
  4203. Np_lbl :
  4204.    rem_npad = knum (substr (rec_msg, pkt_msg + p_si_npad, 1));
  4205.  
  4206. To_lbl :
  4207.    rem_timeout = knum (substr (rec_msg, pkt_msg + p_si_timout, 1)) + 59;
  4208.    rem_timeout = divide (rem_timeout, 60, 15); /* Set the timeout in minutes. */
  4209.  
  4210. Pkt_lbl :
  4211.    rem_pkt_size = knum (substr (rec_msg, pkt_msg + p_si_bufsiz, 1));
  4212.  
  4213.    return;
  4214.  
  4215.    end;        /* Prs_send_init */
  4216. -------------------------------------------------------------------------------
  4217.  
  4218. /* READ_INPUT -- Read input file and form data packet. */
  4219.  
  4220. Read_input : proc (code) returns (fixed bin);
  4221.  
  4222. Dcl code fixed bin;
  4223.  
  4224. $Insert *>insert>common.ins.plp
  4225. $Insert *>insert>kermit.ins.plp
  4226. $Insert *>insert>primos.ins.plp
  4227. $Insert *>insert>constants.ins.plp
  4228. $Insert syscom>keys.ins.pl1
  4229. $Insert syscom>errd.ins.pl1
  4230.  
  4231. Dcl crlf char (2),
  4232.     (prev_char, new_char) char (1),
  4233.     chr char (3) var,
  4234.     (rep_count, i, max_chars, rnw, ibuf_wds_less1, ibuf_size_less2) fixed bin;
  4235.  
  4236. /* ************************************************************************* */
  4237.  
  4238.    code = 0;
  4239.    snd_msg = '';              /* Clear sending buffer. */
  4240.    rep_count = 0;
  4241.    prev_char = nul_7bit_asc;
  4242.    char2_ptr -> fb15_based = 0;
  4243.    ibuf_wds_less1 = ibuffer_size_wds - 1;
  4244.    ibuf_size_less2 = ibuffer_size - 2;
  4245.    crlf = cr_8bit_asc || lf_8bit_asc;
  4246.  
  4247.    max_chars = rem_pkt_size - pkt_tot_ovr_head - 2; /* This allows for 8-bit, */
  4248.    if do_repeats then                /* control chars, but NOT repeats. */
  4249.       max_chars = max_chars - 2;     /* This now allows for repeat chars. */
  4250.  
  4251. Loop :
  4252.  
  4253.    do until (length (snd_msg) >= max_chars);       /* Main packet loop. */
  4254.       ibuf_ptr = ibuf_ptr + 1;
  4255.       if ibuf_ptr > ibuflen then
  4256.          do;
  4257.             call read_file;
  4258.             ibuf_ptr = 1;
  4259.             if code ^= 0 then
  4260.                leave loop;
  4261.          end;
  4262.  
  4263.       new_char = substr (ibuffer, ibuf_ptr, 1);
  4264.  
  4265.       if do_repeats then
  4266.          if (new_char = prev_char & rep_count < 94) | first_read then
  4267.             rep_count = rep_count + 1;
  4268.          else
  4269.             do;
  4270.                char2(2) = prev_char;
  4271.                chr = trans_char (char2_ptr -> fb15_based);
  4272.  
  4273.                if rep_count > 3 then
  4274.                   do;
  4275.                      char2_ptr -> fb15_based = rep_count + 32;
  4276.                      rep_count = 1;  /* We must do this for the do-loop. */
  4277.                      snd_msg = snd_msg || loc_rep_chr || char2(2);
  4278.                   end;
  4279.  
  4280.                do i = 1 to rep_count;
  4281.                   snd_msg = snd_msg || chr;
  4282.                end;
  4283.  
  4284.                rep_count = 1;
  4285.  
  4286.             end;
  4287.       else
  4288.          do;
  4289.             char2(2) = new_char;
  4290.             snd_msg = snd_msg || trans_char (char2_ptr -> fb15_based);
  4291.          end;
  4292.  
  4293.       first_read = false;
  4294.       prev_char = new_char;
  4295.  
  4296.    end;
  4297.  
  4298.    if code = e$eof then
  4299.       code = 0;
  4300.  
  4301.    if code = 0 & do_repeats then
  4302.       do;
  4303.          char2(2) = new_char;
  4304.          chr = trans_char (char2_ptr -> fb15_based);
  4305.  
  4306.          if rep_count > 3 then
  4307.             do;
  4308.                char2_ptr -> fb15_based = rep_count + 32;
  4309.                rep_count = 1;     /* We must do this for the do-loop. */
  4310.                snd_msg = snd_msg || loc_rep_chr || char2(2);
  4311.             end;
  4312.  
  4313.          do i = 1 to rep_count;
  4314.             snd_msg = snd_msg || chr;
  4315.          end;
  4316.  
  4317.       end;
  4318.  
  4319.    if code ^= 0 then
  4320.       return (ker_internalerr);
  4321.    else
  4322.       if length (snd_msg) = 0 then
  4323.          return (ker_eof);
  4324.       else
  4325.          return (ker_normal);
  4326.  
  4327. /* ******************************* Read_file ******************************* */
  4328.  
  4329. Read_file : proc;
  4330.  
  4331. /* ************************************************************************* */
  4332.  
  4333.    if file_type = ascii_ft then
  4334.       do;
  4335.          call rdlin$ (file_unit, ibuffer, ibuf_wds_less1, code);
  4336.          if code ^= 0 then
  4337.             do;
  4338.                ibuflen = 0;
  4339.                return;
  4340.             end;
  4341.  
  4342.          ibuflen = length (trim (substr (ibuffer, 1, ibuf_size_less2), '01'b));
  4343.          substr (ibuffer, ibuflen + 1, 2) = crlf;
  4344.          ibuflen = ibuflen + 2;
  4345.  
  4346.          ibuffer = clr8str ((ibuffer));
  4347.       end;
  4348.    else
  4349.       do;                                 /* BINARY files. */
  4350.          call prwf$$ (k$read, file_unit, ibuffer_ptr, ibuffer_size_wds, 0, rnw, code);
  4351.          if code = e$eof & rnw ^= 0 then
  4352.             code = 0;
  4353.  
  4354.          ibuflen = 2 * rnw;
  4355.  
  4356.          if code = 0 then
  4357.             do;
  4358.                file_pos = file_pos + ibuflen;
  4359.  
  4360.                if file_pos > file_len then
  4361.                   ibuflen = ibuflen - 1;
  4362.             end;
  4363.  
  4364.       end;
  4365.  
  4366.    return;
  4367.  
  4368.    end;              /* Read_file */
  4369.  
  4370.    end;            /* Read_input */
  4371. -------------------------------------------------------------------------------
  4372.  
  4373. /* REC_PACKET -- Receive a packet from remote Kermit. */
  4374.  
  4375. Rec_packet : proc;
  4376.  
  4377. $Insert *>insert>common.ins.plp
  4378. $Insert *>insert>kermit.ins.plp
  4379. $Insert *>insert>primos.ins.plp
  4380. $Insert *>insert>constants.ins.plp
  4381.  
  4382. Dcl (char_in, code, rec_msg_len) fixed bin,
  4383.     line char (max_msg) var;
  4384.  
  4385. /* ************************************************************************* */
  4386.  
  4387.    timeout = bad_return;        /* Local label used for Timeout condition. */
  4388.  
  4389.    call limit$ ('0602'b4, (rem_timeout), 0, code);
  4390.  
  4391.    do until (char_in = ctrl_a_8bit_dec | char_in = ctrl_a_7bit_dec);
  4392.       call c1in (char_in);
  4393.    end;
  4394.  
  4395.    call get_line;                     /* Get the rest of the message. */
  4396.  
  4397.    call limit$ ('0602'b4, 0, 0, code);       /* Turn off the timer. */
  4398.  
  4399.    rec_msg_len = length (rec_msg);
  4400.    if rec_msg_len < pkt_msg then   /* Check that the packet length is valid. */
  4401.       do;
  4402.          rec_pkt_type = msg_check_err;
  4403.  
  4404.          if log_opened then
  4405.             do;
  4406.                call log_info ('Packet length of ' || trim (char (rec_msg_len), '11'b) || ' is too short.');
  4407.  
  4408.                if rec_msg_len <= 1 then
  4409.                   line = '';
  4410.                else
  4411.                   line = substr (rec_msg, 2);
  4412.  
  4413.                call log_packet (rec_pkt_type, 0, line);
  4414.             end;
  4415.  
  4416.          return;
  4417.  
  4418.       end;
  4419.  
  4420.    rec_pkt_type = set8 (substr (rec_msg, pkt_type, 1));  /* Extract the fields from the packet. */
  4421.    rec_length = knum (substr (rec_msg, pkt_count, 1)) + 2;
  4422.    rec_seq = knum (substr (rec_msg, pkt_seq, 1));
  4423.  
  4424.    if rec_msg_len ^= rec_length then   /* Check that the packet length is correct. */
  4425.       do;
  4426.          rec_pkt_type = msg_check_err;
  4427.  
  4428.          if log_opened then
  4429.             do;
  4430.                call log_info ('Packet length byte (' || trim (char (rec_length - 2), '11'b) ||
  4431.                     ') is not equal to packet size (' || trim (char (rec_msg_len - 2), '11'b) || ').');
  4432.  
  4433.                if rec_msg_len <= 1 then
  4434.                   line = '';
  4435.                else
  4436.                   line = substr (rec_msg, 2);
  4437.  
  4438.                call log_packet (rec_pkt_type, 0, line);
  4439.             end;
  4440.  
  4441.          return;
  4442.  
  4443.       end;
  4444.  
  4445.    if ^check_checksum () then         /* Check the checksum. */
  4446.       if log_opened then
  4447.          do;
  4448.             if rec_msg_len <= 1 then
  4449.                line = '';
  4450.             else
  4451.                line = substr (rec_msg, 2);
  4452.  
  4453.             call log_packet (rec_pkt_type, 0, line);
  4454.          end;
  4455.       else
  4456.          ;
  4457.    else                     /* A good return. */
  4458.       if log_opened then
  4459.          do;
  4460.             if rec_msg_len <= pkt_msg then
  4461.                line = '';
  4462.             else
  4463.                line = substr (rec_msg, pkt_msg, rec_msg_len - pkt_msg);
  4464.  
  4465.             call log_packet (rec_pkt_type, rec_seq, line);
  4466.          end;
  4467.  
  4468.    return;
  4469.  
  4470. Bad_return :            /* If we get here then the Timeout condition has been raised. */
  4471.    rec_pkt_type = msg_timeout;
  4472.    call log_packet (rec_pkt_type, 0, '');
  4473.  
  4474.    return;
  4475.  
  4476. /* ******************************* Get_line ******************************** */
  4477.  
  4478. Get_line : proc;
  4479.  
  4480. Dcl rec_msg_buffer char (max_msg),
  4481.     last_char char (1),
  4482.     buflen fixed bin;
  4483.  
  4484. /* ************************************************************************* */
  4485.  
  4486.    call cnin$ (rec_msg_buffer, max_msg_less1, buflen);
  4487.  
  4488.    last_char = clr8 (substr (rec_msg_buffer, buflen, 1));
  4489.  
  4490.    if last_char = cr_7bit_asc | last_char = lf_7bit_asc then
  4491.       buflen = buflen - 1;
  4492.  
  4493.    rec_msg = ctrl_a_8bit_asc || substr (rec_msg_buffer, 1, buflen);
  4494.  
  4495.    return;
  4496.  
  4497.    end;         /* Get_line */
  4498.  
  4499. /* ***************************** Check_checksum **************************** */
  4500.  
  4501. Check_checksum : proc returns (bit (1) aligned);
  4502.  
  4503. Dcl (chksum, chksum7, chksum8, key, rec_len, rec_pkt_chksum) fixed bin;
  4504.  
  4505. /* ************************************************************************* */
  4506.  
  4507.    rec_len = rec_length - 1;
  4508.    rec_pkt_chksum = knum (substr (rec_msg, rec_length, 1));
  4509.  
  4510.    if auto_sum then      /* If checksum type is undetermined, then try both. */
  4511.       do;
  4512.          chksum7 = chks (0, substr (rec_msg, 1, rec_len));
  4513.          chksum8 = chks (1, substr (rec_msg, 1, rec_len));
  4514.  
  4515.          if (chksum7 ^= rec_pkt_chksum) & (chksum8 ^= rec_pkt_chksum) then
  4516.             do;
  4517.                rec_pkt_type = msg_check_err;
  4518.                call log_info ('Checksum error : wanted '||
  4519.                               trim (char (chksum7), '11'b) || ' or ' ||
  4520.                               trim (char (chksum8), '11'b) ||', but got ' ||
  4521.                               trim (char (rec_pkt_chksum), '11'b) || '.');
  4522.                return (false);
  4523.             end;
  4524.  
  4525.          if chksum7 ^= chksum8 then    /* Determine checksum type if undetermined. */
  4526.             do;
  4527.                auto_sum = false;
  4528.                do_8bit_chks = (chksum8 = rec_pkt_chksum);
  4529.                if do_8bit_chks then
  4530.                   call log_info ('Doing 8 bit checksums.');
  4531.                else
  4532.                   call log_info ('Doing 7 bit checksums.');
  4533.             end;
  4534.  
  4535.       end;
  4536.    else
  4537.       do;                 /* Checksum type already determined. */
  4538.          if do_8bit_chks then
  4539.             key = 1;
  4540.          else
  4541.             key = 0;
  4542.  
  4543.          chksum = chks (key, substr (rec_msg, 1, rec_len));
  4544.  
  4545.          if chksum ^= rec_pkt_chksum then
  4546.             do;
  4547.                rec_pkt_type = msg_check_err;
  4548.                char2(1) = nul_7bit_asc;
  4549.                char2(2) = substr (rec_msg, rec_length, 1);
  4550.                rec_pkt_chksum = char2_ptr -> fb15_based - 32;
  4551.                call log_info ('Checksum error : wanted ' ||
  4552.                               trim (char (chksum), '11'b) || ', but got ' ||
  4553.                               trim (char (rec_pkt_chksum), '11'b) || '.');
  4554.                return (false);
  4555.             end;
  4556.       end;
  4557.  
  4558.    return (true);
  4559.  
  4560.    end;          /* Check_checksum */
  4561.  
  4562.    end;        /* Rec_packet */
  4563. -------------------------------------------------------------------------------
  4564.  
  4565. /* REC_SWITCH -- Handle Kermit file receive protocol. */
  4566.  
  4567. Rec_switch : proc;
  4568.  
  4569. $Insert *>insert>common.ins.plp
  4570. $Insert *>insert>kermit.ins.plp
  4571. $Insert *>insert>primos.ins.plp
  4572. $Insert *>insert>constants.ins.plp
  4573. $Insert syscom>errd.ins.pl1
  4574.  
  4575. Dcl (temp, i, fs_attr_type, rep_count) fixed bin,
  4576.     new_path char (128) var,
  4577.     chr char (1),
  4578.     (single_file_rec, test_flag) bit (1) aligned;
  4579.  
  4580. /* ************************************************************************* */
  4581.  
  4582.    do_flush = true;
  4583.    num_retries = 0;          /* Initialize the number of retries. */
  4584.    single_file_rec = (path_name ^= '');
  4585.  
  4586.    if log_opened then
  4587.       do;
  4588.          if single_file_rec then
  4589.             errmsg = ' ' || path_name;
  4590.          else
  4591.             errmsg = '';
  4592.  
  4593.          call log_info ('');
  4594.          call log_info (kversion || ' receiving' || errmsg || '.');
  4595.       end;
  4596.  
  4597.    do while (true);
  4598.  
  4599.       select (state);
  4600.  
  4601.          when (state_r)
  4602.             state = rec_init ();
  4603.  
  4604.          when (state_rf)
  4605.             state = rec_file ();
  4606.  
  4607.          when (state_ra)
  4608.             state = rec_attrib ();
  4609.  
  4610.          when (state_rd)
  4611.             state = rec_data ();
  4612.  
  4613.          when (state_rdw)
  4614.             state = rec_windowing ();
  4615.  
  4616.          when (state_c)
  4617.             do;
  4618.                call sleep$ (3000);
  4619.                return;
  4620.             end;
  4621.  
  4622.          otherwise                    /* This includes state_a. */
  4623.             do;
  4624.                do_flush = true;
  4625.                call discard_output (i);
  4626.                if i ^= 0 then
  4627.                   do;
  4628.                      call get_error_msg (i);
  4629.                      snd_msg = 'Error trying to discard the output file. ' || errmsg;
  4630.                      call send_packet (msg_error, length (snd_msg), msg_number);
  4631.                   end;
  4632.  
  4633.                call sleep$ (3000);
  4634.                return;
  4635.             end;
  4636.  
  4637.       end;     /* select */
  4638.  
  4639.    end;     /* do while ... */
  4640.  
  4641. /* ******************************** Rec_init ******************************* */
  4642.  
  4643. Rec_init : proc returns (fixed bin);
  4644.  
  4645. /* ************************************************************************* */
  4646.  
  4647.    msg_number = 0;               /* Initialize sequence numbering. */
  4648.  
  4649.    if ^rec_message () then       /* Get a packet. */
  4650.       return (state_a);
  4651.  
  4652.    if rec_pkt_type = msg_snd_init then
  4653.       do;
  4654.          call ack_send_init;
  4655.          num_retries = 0;
  4656.          msg_number = mod (msg_number + 1, 64);
  4657.          return (state_rf);         /* Ready to receive file info. */
  4658.       end;
  4659.    else
  4660.       do;
  4661.          call send_packet (msg_nak, 0, rec_seq);
  4662.          return (state_a);
  4663.       end;
  4664.  
  4665.    end;      /* Rec_init */
  4666.  
  4667. /* ******************************* Rec_file ******************************** */
  4668.  
  4669. Rec_file : proc returns (fixed bin);
  4670.  
  4671. /* ************************************************************************* */
  4672.  
  4673.    if ^rec_message () then             /* Get a packet. */
  4674.       return (state_a);
  4675.  
  4676.    select (rec_pkt_type);
  4677.  
  4678.       when (msg_snd_init)
  4679.          if rec_seq = mod (msg_number - 1, 64) then
  4680.             do;
  4681.                if ^bump_retry () then
  4682.                   return (state_a);
  4683.                call ack_send_init;
  4684.                return (state);
  4685.             end;
  4686.          else
  4687.             do;
  4688.                snd_msg = 'Protocol error detected.';
  4689.                call send_packet (msg_error, length (snd_msg), msg_number);
  4690.                return (state_a);
  4691.             end;
  4692.  
  4693.       when (msg_file)
  4694.          do;
  4695.             if rec_seq ^= msg_number then
  4696.                do;
  4697.                   snd_msg = 'Protocol error detected.';
  4698.                   call send_packet (msg_error, length (snd_msg), msg_number);
  4699.                   return (state_a);
  4700.                end;
  4701.  
  4702.             if path_name = '' then   /* Get the pathname from the packet. */
  4703.                do;
  4704.                   if single_file_rec then
  4705.                      do;
  4706.                         snd_msg = 'Error : only ONE file upload allowed.';
  4707.                         call send_packet (msg_error, length (snd_msg), msg_number);
  4708.                         return (state_a);
  4709.                      end;
  4710.  
  4711.                   path_name = substr (rec_msg, pkt_msg, length (rec_msg) - pkt_msg);
  4712.                   path_name = trim (set8str (path_name), '11'b);
  4713.  
  4714.                   /* The pathname may have repeat character processing in it,
  4715.                      so we must handle this. 8-bit quoting and control quoting
  4716.                      are not allowed in path names, and so will be caught
  4717.                      later on. */
  4718.  
  4719.                   if do_repeats then
  4720.                      if index (path_name, loc_rep_chr) ^= 0 then
  4721.                         do;
  4722.                            new_path = '';
  4723.  
  4724.                            do i = 1 to length (path_name);
  4725.                               chr = substr (path_name, i, 1);
  4726.  
  4727.                               if chr = loc_rep_chr then
  4728.                                  do;
  4729.                                     i = i + 1;
  4730.                                     rep_count = knum (substr (path_name, i, 1));
  4731.  
  4732.                                     i = i + 1;
  4733.                                     chr = substr (path_name, i, 1);
  4734.                                  end;
  4735.                               else
  4736.                                  rep_count = 1;
  4737.  
  4738.                               do temp = 1 to rep_count;
  4739.                                  new_path = new_path || chr;
  4740.                               end;
  4741.  
  4742.                            end;
  4743.  
  4744.                            path_name = new_path;
  4745.  
  4746.                         end;
  4747.  
  4748.                   call set_path (path_name);
  4749.  
  4750.                end;
  4751.  
  4752.             i = open_output ();      /* Open the file for writing. */
  4753.  
  4754.             select (i);
  4755.  
  4756.                when (0)
  4757.                   snd_msg = '';
  4758.  
  4759.                when (e$exst)
  4760.                   do;            /* Acknowldege with our new file name. */
  4761.                      snd_msg = file_name;
  4762.                      call log_info ('File already exists. New file name is ' || file_name || '.');
  4763.                   end;
  4764.  
  4765.                when (e$bnam)
  4766.                   do;
  4767.                      snd_msg = file_name;
  4768.                      call log_info ('The file name is illegal, ' || file_name || ' will be used instead.');
  4769.                   end;
  4770.  
  4771.                when (e$ialn)
  4772.                   do;
  4773.                      snd_msg = 'File already exists. Unable to generate a new file name!';
  4774.                      call send_packet (msg_error, length (snd_msg), msg_number);
  4775.                      return (state_a);
  4776.                   end;
  4777.  
  4778.                otherwise
  4779.                   do;
  4780.                      call get_error_msg (i);
  4781.                      snd_msg = 'Error opening file on remote system. ' || errmsg;
  4782.                      call send_packet (msg_error, length (snd_msg), msg_number);
  4783.                      return (state_a);
  4784.                   end;
  4785.             end;
  4786.  
  4787.             if explicit_ft_set then
  4788.                do;
  4789.                   rec_file_type = file_type;
  4790.  
  4791.                   if log_opened then
  4792.                      do;
  4793.                         errmsg = 'The receiving file type has been explicitly set to ';
  4794.  
  4795.                         select (file_type);
  4796.  
  4797.                            when (ascii_ft)
  4798.                               errmsg = errmsg || 'ASCII.';
  4799.  
  4800.                            when (binary_ft)
  4801.                               errmsg = errmsg || 'BINARY.';
  4802.  
  4803.                            when (automatic_ft)      /* ? - This can't be! */
  4804.                               errmsg = errmsg || 'AUTOMATIC.';
  4805.  
  4806.                            otherwise                /* And what's this ? */
  4807.                               errmsg = errmsg || 'ILLEGAL.';
  4808.  
  4809.                         end;
  4810.  
  4811.                         call log_info ((errmsg));
  4812.                      end;
  4813.                end;
  4814.             else
  4815.                do;
  4816.                   rec_file_type = automatic_ft;
  4817.                   file_type = ascii_ft;       /* Assume this to start with. */
  4818.  
  4819.                   if log_opened then
  4820.                      do;
  4821.                         call log_info ('The receiving file type will be automatically detected.');
  4822.                         call log_info ('But ASCII file type will initially be assumed.');
  4823.                      end;
  4824.                end;
  4825.  
  4826.             call send_packet (msg_ack, length (snd_msg), msg_number);  /* ACK file header packet. */
  4827.             num_retries = 0;
  4828.             msg_number = mod (msg_number + 1, 64);
  4829.  
  4830.             if loc_file_attrib then    /* Get the file attributes if we can. */
  4831.                return (state_ra);
  4832.             else
  4833.                if do_windowing then
  4834.                   do;
  4835.                      tab_first = msg_number;
  4836.                      tab_next = tab_first;
  4837.                      do_flush = false;
  4838.                      return (state_rdw);
  4839.                   end;
  4840.                else
  4841.                   return (state_rd);
  4842.          end;
  4843.  
  4844.       when (msg_eof)
  4845.          if rec_seq = mod (msg_number - 1, 64) then
  4846.             do;
  4847.                if ^bump_retry () then
  4848.                   return (state_a);
  4849.                call send_packet (msg_ack, 0, rec_seq);
  4850.                return (state);
  4851.             end;
  4852.          else
  4853.             do;
  4854.                snd_msg = 'Protocol error detected.';
  4855.                call send_packet (msg_error, length (snd_msg), msg_number);
  4856.                return (state_a);
  4857.             end;
  4858.  
  4859.       when (msg_break)
  4860.          do;
  4861.             call send_packet (msg_ack, 0, rec_seq);
  4862.             return (state_c);
  4863.          end;
  4864.  
  4865.       when (msg_error)
  4866.          return (state_a);
  4867.  
  4868.       otherwise
  4869.          do;
  4870.             snd_msg = 'Unexpected packet type "' || rec_pkt_type || '" received on remote system.';
  4871.             call send_packet (msg_error, length (snd_msg), msg_number);
  4872.             return (state_a);
  4873.          end;
  4874.  
  4875.    end;      /* Select */
  4876.  
  4877.    end;    /* Rec_file */
  4878.  
  4879. /* ****************************** Rec_attrib ******************************* */
  4880.  
  4881. Rec_attrib : proc returns (fixed bin);
  4882.  
  4883. Dcl avail_disk_space fixed bin (31),
  4884.     code fixed bin,
  4885.     1 quota_info,
  4886.       2 (record_size, dir_used, max_quota, quota_used) fixed bin (31),
  4887.       2 (duff1, duff2, duff3, duff4) fixed bin (31),
  4888.     inf_array (8) fixed bin (31) based;
  4889.  
  4890. /* ************************************************************************* */
  4891.  
  4892.    if ^rec_message () then                 /* Get a packet. */
  4893.       return (state_a);
  4894.  
  4895.    select (rec_pkt_type);
  4896.  
  4897.       when (msg_attrib)
  4898.          do;
  4899.             call q$read (dir_name, addr (quota_info) -> inf_array, 4, temp, code);
  4900.             if code ^= 0 | temp = 1 then
  4901.                avail_disk_space = -1;
  4902.             else
  4903.                do;
  4904.                   avail_disk_space = quota_info.max_quota - quota_info.quota_used;
  4905.                   if quota_info.record_size ^= 1024 then
  4906.                      avail_disk_space = divide ((avail_disk_space * quota_info.record_size) + 1023, 1024, 31);
  4907.                end;
  4908.  
  4909.             call decode_attrs;
  4910.  
  4911.             if avail_disk_space = -1 | rec_file_size <= 0 | rec_file_size <= avail_disk_space then
  4912.                snd_msg = 'Y';
  4913.             else               /* ONLY reject the file if we run out of room. */
  4914.                do;
  4915.                   call discard_output (temp);
  4916.  
  4917.                   if fs_attr_type = 0 then
  4918.                      snd_msg = 'N!';
  4919.                   else
  4920.                      snd_msg = 'N1';
  4921.                end;
  4922.  
  4923.             if rec_file_dtc = 0 then
  4924.                snd_msg = snd_msg || '#';
  4925.  
  4926.             if file_type = illegal_ft then
  4927.                do;
  4928.                   rec_file_type = automatic_ft;
  4929.                   file_type = ascii_ft;  /* Reset this, but let the other side know. */
  4930.                   snd_msg = snd_msg || '"';
  4931.                end;
  4932.  
  4933.             call send_packet (msg_ack, length (snd_msg), rec_seq);
  4934.             num_retries = 0;
  4935.             msg_number = mod (msg_number + 1, 64);
  4936.             if substr (snd_msg, 1, 1) = 'N' then
  4937.                call log_info ('Unable to receive the file ' || file_name || '. File too big.');
  4938.             return (state);
  4939.          end;
  4940.  
  4941.       when (msg_data)
  4942.          do;
  4943.             if rec_seq ^= msg_number then    /* Out of sequence messages. */
  4944.                if rec_seq = mod (msg_number - 1, 64) then
  4945.                   do;
  4946.                      if ^bump_retry () then
  4947.                         return (state_a);
  4948.                      call send_packet (msg_ack, 0, rec_seq);
  4949.                      return (state);
  4950.                   end;
  4951.                else
  4952.                   do;
  4953.                      snd_msg = 'Protocol error detected.';
  4954.                      call send_packet (msg_error, length (snd_msg), msg_number);
  4955.                      return (state_a);
  4956.                   end;
  4957.  
  4958.             temp = write_output ();
  4959.             if temp ^= 0 then
  4960.                do;
  4961.                   call get_error_msg (temp);
  4962.                   snd_msg = 'Unable to write to output file. ' || errmsg;
  4963.                   call send_packet (msg_error, length (snd_msg), msg_number);
  4964.                   return (state_a);
  4965.                end;
  4966.  
  4967.             call send_packet (msg_ack, 0, rec_seq);
  4968.             num_retries = 0;
  4969.             msg_number = mod (msg_number + 1, 64);
  4970.  
  4971.             if do_windowing then
  4972.                do;
  4973.                   tab_first = msg_number;
  4974.                   tab_next = tab_first;
  4975.                   do_flush = false;
  4976.                   return (state_rdw);
  4977.                end;
  4978.             else
  4979.                return (state_rd);
  4980.  
  4981.          end;
  4982.  
  4983.       when (msg_file)
  4984.          if rec_seq = mod (msg_number - 1, 64) then
  4985.             do;
  4986.                if ^bump_retry () then
  4987.                   return (state_a);
  4988.                call send_packet (msg_ack, 0, rec_seq);
  4989.                return (state);
  4990.             end;
  4991.          else
  4992.             do;
  4993.                snd_msg = 'Protocol error detected.';
  4994.                call send_packet (msg_error, length (snd_msg), msg_number);
  4995.                return (state_a);
  4996.             end;
  4997.  
  4998.       when (msg_eof)
  4999.          if rec_seq = msg_number then
  5000.             do;
  5001.                i = close_output ();
  5002.                call set_path ('');    /* Knock out the file_name for later. */
  5003.                if i ^= 0 then
  5004.                   do;
  5005.                      call get_error_msg (i);
  5006.                      snd_msg = 'Unable to close output file on remote system. ' || errmsg;
  5007.                      call send_packet (msg_error, length (snd_msg), msg_number);
  5008.                      return (state_a);
  5009.                   end;
  5010.  
  5011.                call send_packet (msg_ack, 0, rec_seq);
  5012.                num_retries = 0;
  5013.                msg_number = mod (msg_number + 1, 64);
  5014.  
  5015.                return (state_rf);
  5016.             end;
  5017.          else
  5018.             do;
  5019.                snd_msg = 'Protocol error detected.';
  5020.                call send_packet (msg_error, length (snd_msg), msg_number);
  5021.                return (state_a);
  5022.             end;
  5023.  
  5024.       when (msg_error)
  5025.          return (state_a);
  5026.  
  5027.       otherwise
  5028.          do;
  5029.             snd_msg = 'Unexpected packet type "' || rec_pkt_type || '" received on remote system.';
  5030.             call send_packet (msg_error, length (snd_msg), msg_number);
  5031.             return (state_a);
  5032.          end;
  5033.  
  5034.    end;         /* select */
  5035.  
  5036.    end;     /* Rec_attrib */
  5037.  
  5038. /* ******************************** Rec_data ******************************* */
  5039.  
  5040. Rec_data : proc returns (fixed bin);
  5041.  
  5042. /* ************************************************************************* */
  5043.  
  5044.    if ^rec_message () then             /* Get a packet. */
  5045.       return (state_a);
  5046.  
  5047.    select (rec_pkt_type);
  5048.  
  5049.       when (msg_data)
  5050.          do;
  5051.             if rec_seq ^= msg_number then    /* Out of sequence messages. */
  5052.                do;
  5053.                   if rec_seq = mod (msg_number - 1, 64) then
  5054.                      do;
  5055.                         if ^bump_retry () then
  5056.                            return (state_a);
  5057.                         call send_packet (msg_ack, 0, rec_seq);
  5058.                         return (state);
  5059.                      end;
  5060.                   else
  5061.                      do;
  5062.                         snd_msg = 'Protocol error detected.';
  5063.                         call send_packet (msg_error, length (snd_msg), msg_number);
  5064.                         return (state_a);
  5065.                      end;
  5066.                end;
  5067.  
  5068.             temp = write_output ();
  5069.             if temp ^= 0 then
  5070.                do;
  5071.                   call get_error_msg (temp);
  5072.                   snd_msg = 'Unable to write to output file. ' || errmsg;
  5073.                   call send_packet (msg_error, length (snd_msg), msg_number);
  5074.                   return (state_a);
  5075.                end;
  5076.  
  5077.             call send_packet (msg_ack, 0, rec_seq);
  5078.             num_retries = 0;
  5079.             msg_number = mod (msg_number + 1, 64);
  5080.             return (state_rd);
  5081.          end;
  5082.  
  5083.       when (msg_file)
  5084.         if rec_seq = mod (msg_number - 1, 64) then
  5085.            do;
  5086.               if ^bump_retry () then
  5087.                   return (state_a);
  5088.               call send_packet (msg_ack, 0, rec_seq);
  5089.               return (state);
  5090.            end;
  5091.         else
  5092.            do;
  5093.               snd_msg = 'Protocol error detected.';
  5094.               call send_packet (msg_error, length (snd_msg), msg_number);
  5095.               return (state_a);
  5096.            end;
  5097.  
  5098.       when (msg_eof)
  5099.          do;
  5100.             if length (rec_msg) > pkt_msg then
  5101.                rec_msg = substr (rec_msg, pkt_msg, 1);
  5102.             else
  5103.                rec_msg = '';
  5104.  
  5105.             if rec_msg = 'D' then
  5106.                call discard_output (i);
  5107.             else
  5108.                i = close_output ();
  5109.  
  5110.             call set_path ('');         /* Do this for later. */
  5111.  
  5112.             if i ^= 0 then
  5113.                do;
  5114.                   call get_error_msg (i);
  5115.                   if rec_msg = 'D' then
  5116.                      snd_msg = 'Unable to discard the output file on remote system. ' || errmsg;
  5117.                   else
  5118.                      snd_msg = 'Unable to close output file on remote system. ' || errmsg;
  5119.                   call send_packet (msg_error, length (snd_msg), msg_number);
  5120.                   return (state_a);
  5121.                end;
  5122.  
  5123.             call send_packet (msg_ack, 0, rec_seq);
  5124.             num_retries = 0;
  5125.             msg_number = mod (rec_seq + 1, 64);
  5126.             return (state_rf);
  5127.          end;
  5128.  
  5129.       when (msg_error)
  5130.          return (state_a);
  5131.  
  5132.       otherwise
  5133.          do;
  5134.             snd_msg = 'Unexpected packet type "' || rec_pkt_type || '" received on remote system.';
  5135.             call send_packet (msg_error, length (snd_msg), msg_number);
  5136.             return (state_a);
  5137.          end;
  5138.  
  5139.    end;        /* select */
  5140.  
  5141.    end;     /* Rec_data */
  5142.  
  5143. /* ***************************** Rec_windowing ***************************** */
  5144.  
  5145. Rec_windowing : proc returns (fixed bin);
  5146.  
  5147. /* ************************************************************************* */
  5148.  
  5149.    call rec_packet;             /* Get input. */
  5150.  
  5151.    select (rec_pkt_type);
  5152.  
  5153.       when (msg_data)
  5154.          if ^between (rec_seq, tab_first, mod (tab_first + 2 * window_size - 1, 64)) then
  5155.             return (state);
  5156.          else
  5157.             do;
  5158.                call update_table;
  5159.                num_retries = 0;
  5160.                return (state);
  5161.             end;
  5162.  
  5163.       when (msg_check_err)
  5164.          do;          /* NAK for oldest unACKed entry in table. */
  5165.             call log_info ('Checksum error : NAK for oldest unACKed packet.');
  5166.             call nak_oldest (false);
  5167.             return (state);
  5168.          end;
  5169.  
  5170.       when (msg_eof)
  5171.          do;
  5172.             do_flush = true;
  5173.             if length (rec_msg) > pkt_msg then
  5174.                rec_msg = substr (rec_msg, pkt_msg, 1);
  5175.             else
  5176.                rec_msg = '';
  5177.  
  5178.             if rec_msg = 'D' then
  5179.                call discard_output (i);
  5180.             else
  5181.                do;
  5182.                   if ^flush_table ()  then
  5183.                      return (state_a);
  5184.  
  5185.                   i = close_output ();
  5186.                end;
  5187.  
  5188.             call set_path ('');             /* Do this for later. */
  5189.  
  5190.             if i ^= 0 then
  5191.                do;
  5192.                   call get_error_msg (i);
  5193.                   if rec_msg = 'D' then
  5194.                      snd_msg = 'Unable to discard the output file on remote system. ' || errmsg;
  5195.                   else
  5196.                      snd_msg = 'Unable to close output file on remote system. ' || errmsg;
  5197.                   call send_packet (msg_error, length (snd_msg), msg_number);
  5198.                   return (state_a);
  5199.                end;
  5200.  
  5201.             call send_packet (msg_ack, 0, rec_seq);
  5202.             msg_number = mod (rec_seq + 1, 64);
  5203.             return (state_rf);
  5204.  
  5205.          end;
  5206.  
  5207.       when (msg_error)
  5208.          return (state_a);
  5209.  
  5210.       when (msg_timeout)
  5211.          if num_retries > max_retries then
  5212.             do;
  5213.                snd_msg = 'Retry count exceeded on remote system.';
  5214.                call send_packet (msg_error, length (snd_msg), msg_number);
  5215.                return (state_a);
  5216.             end;
  5217.          else
  5218.             do;
  5219.                call log_info ('Timeout : NAK for most desired packet.');
  5220.                call nak_oldest (true);
  5221.                return (state);
  5222.             end;
  5223.  
  5224.       otherwise
  5225.          do;
  5226.             snd_msg = 'Unexpected packet type "' || rec_pkt_type || '" received on remote system.';
  5227.             call send_packet (msg_error, length (snd_msg), msg_number);
  5228.             return (state_a);
  5229.          end;
  5230.  
  5231.    end;      /* Select */
  5232.  
  5233.    end;   /* Rec_windowing */
  5234.  
  5235. /* ****************************** Rec_message ****************************** */
  5236.  
  5237. Rec_message : proc returns (bit (1) aligned);
  5238.  
  5239. /* ************************************************************************* */
  5240.  
  5241.    test_flag = false;
  5242.  
  5243.    do until (test_flag);
  5244.  
  5245.       call rec_packet;
  5246.  
  5247.       if rec_pkt_type = msg_timeout | rec_pkt_type = msg_check_err then
  5248.          do;
  5249.             if ^bump_retry () then
  5250.                return (false);
  5251.             call send_packet (msg_nak, 0, msg_number);
  5252.             num_retries = num_retries + 1;
  5253.          end;
  5254.       else
  5255.          test_flag = true;
  5256.    end;
  5257.  
  5258.    return (true);
  5259.  
  5260.    end;       /* Rec_message */
  5261.  
  5262. /* ***************************** Update_table ****************************** */
  5263.  
  5264. Update_table : proc;
  5265.  
  5266. Dcl save_msg char (max_msg) var;
  5267.  
  5268. /* ************************************************************************* */
  5269.  
  5270.    /* Make room in the table if necessary. */
  5271.  
  5272.    if between (rec_seq, mod (tab_first + window_size, 64), mod (tab_first - 1, 64)) then
  5273.       do;
  5274.          save_msg = rec_msg;
  5275.  
  5276.          i = tab_first;      /* Write the old table entries to the file. */
  5277.          do while (mod (i + window_size - 1, 64) ^= rec_seq);
  5278.             if ^msg_table.slot(i).acked then
  5279.                do;
  5280.                   snd_msg = 'Protocol error : receive table overrun.';
  5281.                   call send_packet (msg_error, length (snd_msg), msg_number);
  5282.                   state = state_a;
  5283.                   return;
  5284.                end;
  5285.  
  5286.             rec_msg = msg_table.slot(i).msg;
  5287.  
  5288.             temp = write_output ();
  5289.             if temp ^= 0 then
  5290.                do;
  5291.                   call get_error_msg (temp);
  5292.                   snd_msg = 'Unable to write to output file. ' || errmsg;
  5293.                   call send_packet (msg_error, length (snd_msg), msg_number);
  5294.                   state = state_a;
  5295.                   return;
  5296.                end;
  5297.  
  5298.             i = mod (i + 1, 64);
  5299.             tab_first = i;
  5300.          end;
  5301.  
  5302.          rec_msg = save_msg;          /* Restore rec_msg. */
  5303.  
  5304.       end;
  5305.  
  5306.    msg_table.slot(rec_seq).msg = rec_msg;   /* Add the new data packet to the table. */
  5307.    msg_table.slot(rec_seq).acked = true;
  5308.    msg_table.slot(rec_seq).retries = 0;
  5309.  
  5310. /* Clear the acked bit on any skipped pkts */
  5311.  
  5312.    if between (rec_seq, mod (tab_next + 1, 64), mod (tab_first - 1, 64)) then
  5313.       do;
  5314.          i = tab_next;
  5315.          do while (i ^= rec_seq);
  5316.             msg_table.slot(i).acked = false;
  5317.             msg_table.slot(i).retries = 0;
  5318.             call send_packet (msg_nak, 0, i);    /* NAK for the packet. */
  5319.             i = mod (i + 1, 64);
  5320.          end;
  5321.       end;
  5322.  
  5323.    if between (rec_seq, tab_next, mod (tab_first - 1, 64)) then
  5324.       do;             /* Update TAB_NEXT to be the next packet expected. */
  5325.          tab_next = mod (rec_seq + 1, 64);
  5326.          msg_number = tab_next;
  5327.       end;
  5328.  
  5329.    call send_packet (msg_ack, 0, rec_seq);    /* Acknowledge the packet. */
  5330.  
  5331.    return;
  5332.  
  5333.    end;      /* Update_table */
  5334.  
  5335. /* ****************************** Flush_table ****************************** */
  5336.  
  5337. Flush_table : proc returns (bit (1) aligned);
  5338.  
  5339. /* ************************************************************************* */
  5340.  
  5341.    i = tab_first;  /* Write the remainder of the receive table to the file. */
  5342.  
  5343.    do while (i ^= tab_next);
  5344.       if ^msg_table.slot(i).acked then
  5345.          do;
  5346.             snd_msg = 'Unacknowledged data packet when flushing table.';
  5347.             call send_packet (msg_error, length (snd_msg), msg_number);
  5348.             state = state_a;
  5349.             return (false);
  5350.          end;
  5351.  
  5352.       rec_msg = msg_table.slot(i).msg;
  5353.  
  5354.       temp = write_output ();
  5355.       if temp ^= 0 then
  5356.          do;
  5357.             call get_error_msg (temp);
  5358.             snd_msg = 'Unable to write to output file. ' || errmsg;
  5359.             call send_packet (msg_error, length (snd_msg), msg_number);
  5360.             state = state_a;
  5361.             return (false);
  5362.          end;
  5363.  
  5364.       i = mod (i + 1, 64);
  5365.    end;
  5366.  
  5367.    return (true);
  5368.  
  5369.    end;      /* Flush_table */
  5370.  
  5371. /* ****************************** Nak_oldest ******************************* */
  5372.  
  5373. Nak_oldest : proc (desire);
  5374.  
  5375. Dcl desire bit (1) aligned;
  5376.  
  5377. /* ************************************************************************* */
  5378.  
  5379.    i = tab_first;
  5380.  
  5381.    do until (i = tab_next);
  5382.       if ^msg_table.slot(i).acked then
  5383.          do;
  5384.             call send_packet (msg_nak, 0, i);
  5385.             return;
  5386.          end;
  5387.  
  5388.       i = mod (i + 1, 64);
  5389.    end;
  5390.  
  5391.    /* No packets to NAK, so NAK for next in hope of unblocking
  5392.       sender if a NAK for the most desired packet is required. */
  5393.  
  5394.    if desire then
  5395.       call send_packet (msg_nak, 0, tab_next);
  5396.  
  5397.    return;
  5398.  
  5399.    end;      /* Nak_oldest */
  5400.  
  5401. /* ******************************* Bump_retry ****************************** */
  5402.  
  5403. Bump_retry : proc returns (bit (1) aligned);
  5404.  
  5405. /* ************************************************************************* */
  5406.  
  5407.    if num_retries > max_retries then
  5408.       do;
  5409.          snd_msg = 'Retry limit exceeded on remote system.';
  5410.          call send_packet (msg_error, length (snd_msg), msg_number);
  5411.          state = state_a;
  5412.          return (false);
  5413.    end;
  5414.  
  5415.    num_retries = num_retries + 1;
  5416.  
  5417.    return (true);
  5418.  
  5419.    end;          /* Bump_retry */
  5420.  
  5421. /* ****************************** Decode_attrs ***************************** */
  5422.  
  5423. Decode_attrs : proc;
  5424.  
  5425. Dcl (str, data) char (max_msg) var,
  5426.     attr char (1),
  5427.     (len, found, code) fixed bin;
  5428.  
  5429. /* ************************************************************************* */
  5430.  
  5431.    rec_file_size = -1;    /* -1 = Unknown, 0 = Illegal, > 0 = Legal value. */
  5432.    rec_file_dtc = -1;
  5433.  
  5434.    found = 0;
  5435.    str = substr (rec_msg, pkt_msg, length (rec_msg) - pkt_msg);
  5436.    str = set8str (str);
  5437.  
  5438.    do while (length (str) > 0 & found < 5);
  5439.  
  5440.       attr = substr (str, 1, 1);
  5441.  
  5442.       len = knum (substr (str, 2, 1));
  5443.  
  5444.       data = substr (str, 3, len);
  5445.       str = substr (str, len + 3);
  5446.  
  5447.       select (attr);
  5448.  
  5449.          when ('!')             /* File size in Kbytes. */
  5450.             do;
  5451.                fs_attr_type = 0;
  5452.                rec_file_size = bin (trim (data, '11'b), 31);
  5453.             end;
  5454.  
  5455.          when ('1')             /* File size in bytes. */
  5456.             do;
  5457.                fs_attr_type = 1;
  5458.                rec_file_size = bin (trim (data, '11'b), 31);
  5459.                rec_file_size = divide (rec_file_size + 1023, 1024, 31);
  5460.             end;
  5461.  
  5462.          when ('#')             /* Date/Time file created. */
  5463.             do;
  5464.                if substr (data, 1, 2) = '19' then
  5465.                   data = substr (data, 3);    /* Knock off the century. */
  5466.  
  5467.                data = substr (data, 1, 2) || '-' || substr (data, 3, 2) ||
  5468.                       '-' || substr (data, 5, 2) || '.' || after (data, ' ');
  5469.  
  5470.                call cv$dtb (data, rec_file_dtc, code);
  5471.                if code ^= 0 then
  5472.                   rec_file_dtc = 0;
  5473.  
  5474.             end;
  5475.  
  5476.          when ('.')             /* Machine and OS. */
  5477.             if ^explicit_pound_set & (data = 'U8' | substr (data, 1, 1) = 'K') then
  5478.                pound_conversion = true;    /* U8 = MS-DOS, K = Atari. */
  5479.  
  5480.          when ('"')             /* Indication of file type. */
  5481.             if ^explicit_ft_set then     /* Might as well use this if we can. */
  5482.                do;
  5483.                   select (substr (data, 1, 1));
  5484.  
  5485.                      when ('A')
  5486.                         do;
  5487.                            rec_file_type = ascii_ft;    /* ASCII file. */
  5488.                            call log_info ('The received file type attribute is ASCII, this file type will be used.');
  5489.                         end;
  5490.  
  5491.                      when ('B')
  5492.                         do;
  5493.                            rec_file_type = binary_ft;   /* BINARY file. */
  5494.                            call log_info ('The received file type attribute is BINARY, this file type will be used.');
  5495.                         end;
  5496.  
  5497.                      when ('I')
  5498.                         do;
  5499.                            rec_file_type = binary_ft;   /* IMAGE file (BINARY). */
  5500.                            call log_info ('The received file type attribute is IMAGE, but BINARY file type will be used.');
  5501.                         end;
  5502.  
  5503.                      otherwise
  5504.                         do;
  5505.                            rec_file_type = illegal_ft;  /* ILLEGAL file type. */
  5506.                            call log_info ('The received file type attribute is ILLEGAL.');
  5507.                            call log_info ('The file type will be automatically detected, but ASCII will initially be used.');
  5508.                         end;
  5509.  
  5510.                   end;
  5511.  
  5512.                   file_type = rec_file_type;
  5513.  
  5514.                end;
  5515.  
  5516.          otherwise
  5517.             found = found - 1;        /* Didn't find one we wanted. */
  5518.  
  5519.       end;
  5520.  
  5521.       found = found + 1;        /* Assume that we did find one. */
  5522.  
  5523.    end;
  5524.  
  5525.    return;
  5526.  
  5527.    end;          /* Decode_attrs */
  5528.  
  5529.    end;       /* Rec_switch */
  5530. -------------------------------------------------------------------------------
  5531.  
  5532. /* REN_HNDLR -- On_unit for returning after a PUSH. */
  5533.  
  5534. Ren_hndlr : proc (dummy);
  5535.  
  5536. Dcl dummy ptr;
  5537.  
  5538. $Insert *>insert>common.ins.plp
  5539.  
  5540. /* ************************************************************************* */
  5541.  
  5542.    /* "ren_lbl" is a label variable which is set to a local label
  5543.       in COMND. This enables us to create the on-unit once at startup
  5544.       yet have it return to a sub-procedure when the condition arises.
  5545.    */
  5546.  
  5547.    goto ren_lbl;
  5548.  
  5549.    end;       /* Ren_hndlr */
  5550. -------------------------------------------------------------------------------
  5551.  
  5552. /* SEND_PACKET -- Send Kermit packet to user. */
  5553.  
  5554. Send_packet : proc (type, pkt_len, seq_num);
  5555.  
  5556. Dcl type        char (1),    /* Type of packet to send. */
  5557.     pkt_len     fixed bin,   /* Length of packet to send. */
  5558.     seq_num     fixed bin;   /* Sequence number of packet. */
  5559.  
  5560. $Insert *>insert>common.ins.plp
  5561. $Insert *>insert>kermit.ins.plp
  5562. $Insert *>insert>primos.ins.plp
  5563. $Insert *>insert>constants.ins.plp
  5564. $Insert syscom>keys.ins.pl1
  5565.  
  5566. Dcl msg char (max_msg) var,
  5567.     (temp, msg_length, chksum) fixed bin;
  5568.  
  5569. /* ************************************************************************* */
  5570.  
  5571.    if rem_npad > 0 then          /* Do any packet filling required. */
  5572.       call tnoua (rem_pad_chars, rem_npad);
  5573.  
  5574.    /* Store the header information into the message. */
  5575.  
  5576.    char2_ptr -> fb15_based = pkt_len + pkt_ovr_head + 32;
  5577.    msg = ctrl_a_8bit_asc || char2(2);
  5578.  
  5579.    char2_ptr -> fb15_based = seq_num + 32;
  5580.    msg = msg || char2(2) || type;
  5581.  
  5582.    if pkt_len ^= 0 then
  5583.       msg = msg || snd_msg;
  5584.  
  5585.    msg_length = length (msg);
  5586.  
  5587.    if do_transparent then   /* If transparent, then clear all the high bits. */
  5588.       do;
  5589.          if type = msg_data then
  5590.             temp = pkt_type;
  5591.          else
  5592.             temp = msg_length;
  5593.  
  5594.          substr (msg, 1, temp) = clr8str (substr (msg, 1, temp));
  5595.       end;
  5596.  
  5597.    temp = 0;               /* Do the initial checksum calculation. */
  5598.    if do_8bit_chks then
  5599.       temp = 1;
  5600.  
  5601.    chksum = chks (temp, msg);
  5602.  
  5603.    char2_ptr -> fb15_based = chksum + 32;
  5604.    msg = msg || char2(2) || rem_eol;
  5605.  
  5606.    msg_length = msg_length + 2;
  5607.  
  5608.    if do_flush then            /* Flush the input buffer. */
  5609.       call tty$rs (k$inb, temp);
  5610.  
  5611.    call tnoua ((msg), msg_length);           /* Now send the message. */
  5612.  
  5613.    if log_opened then                 /* Log the packet if necessary. */
  5614.       do;
  5615.          if pkt_len = 0 then
  5616.             msg = '';
  5617.          else
  5618.             msg = snd_msg;
  5619.  
  5620.          call log_packet (type, seq_num, msg);
  5621.       end;
  5622.  
  5623.    return;
  5624.  
  5625.    end;         /* Send_packet */
  5626. -------------------------------------------------------------------------------
  5627.  
  5628. /* SEND_SWITCH -- Handles Kermit file send protocol. */
  5629.  
  5630. Send_switch : proc;
  5631.  
  5632. $Insert *>insert>common.ins.plp
  5633. $Insert *>insert>kermit.ins.plp
  5634. $Insert *>insert>primos.ins.plp
  5635. $Insert *>insert>constants.ins.plp
  5636.  
  5637. Dcl (stop_xfer, stop_trans, test_flag) bit (1) aligned,
  5638.     (code, temp) fixed bin;
  5639.  
  5640. /* ************************************************************************* */
  5641.  
  5642.    num_retries = 0;                 /* Initialize number of retries. */
  5643.    msg_number = 0;                  /* Initial message number. */
  5644.    do_flush = true;
  5645.    test_flag = false;
  5646.  
  5647.    if log_opened then
  5648.       do;
  5649.          call log_info ('');
  5650.          call log_info (kversion || ' sending ' || path_name || '.');
  5651.       end;
  5652.  
  5653.    if delay ^= 0 then                   /* Sleep if we need to. */
  5654.       call sleep$ (1000 * delay);
  5655.  
  5656.    do until (test_flag);
  5657.  
  5658.       select (state);
  5659.  
  5660.          when (state_s, state_x)
  5661.             state = send_init ();
  5662.  
  5663.          when (state_sf, state_xf)
  5664.             state = send_file ();
  5665.  
  5666.          when (state_sa)
  5667.             state = send_attrib ();
  5668.  
  5669.          when (state_sd)
  5670.             state = send_data ();
  5671.  
  5672.          when (state_sdw)
  5673.             state = send_windowing ();
  5674.  
  5675.          when (state_sz)
  5676.             state = send_eof ();
  5677.  
  5678.          when (state_sb)
  5679.             state = send_break ();
  5680.  
  5681.          when (state_c)
  5682.             test_flag = true;
  5683.  
  5684.          otherwise               /* Includes state_a. */
  5685.             do;
  5686.               do_flush = true;
  5687.               test_flag = true;
  5688.               if file_opened then
  5689.                  call close_input;
  5690.             end;
  5691.  
  5692.       end;      /* select */
  5693.  
  5694.    end;      /* loop */
  5695.  
  5696.    return;
  5697.  
  5698. /* ****************************** Send_init ******************************** */
  5699.  
  5700. Send_init : proc returns (fixed bin);
  5701.  
  5702. Dcl eol_bin fixed bin,
  5703.     eol char (1);
  5704.  
  5705. /* ************************************************************************* */
  5706.  
  5707.    /* setup our send_init parameters. */
  5708.  
  5709.    char2(1) = nul_7bit_asc;
  5710.    char2(2) = loc_eol;
  5711.    char2_ptr -> fb15_based = char2_ptr -> fb15_based + 32;   /* Set the printable bit. */
  5712.    eol = char2(2);
  5713.  
  5714.    eol_bin = loc_pkt_size + 32;
  5715.    temp = loc_timeout + 32;
  5716.  
  5717.    snd_msg = substr (addr (eol_bin) -> char2_based, 2, 1) ||
  5718.              substr (addr (temp) -> char2_based, 2, 1);
  5719.  
  5720.    eol_bin = loc_npad + 32;
  5721.    temp = loc_capas1 + 32;
  5722.  
  5723.    snd_msg = snd_msg || substr (addr (eol_bin) -> char2_based, 2, 1) ||
  5724.              ctl (loc_padchar) || eol || loc_quote_chr || loc_8quote_chr ||
  5725.              loc_chk_type || loc_rep_chr || substr (addr (temp) -> char2_based, 2, 1);
  5726.  
  5727.    temp = loc_max_wsize + 32;
  5728.    snd_msg = snd_msg || substr (addr (temp) -> char2_based, 2, 1);
  5729.  
  5730.    loc_file_attrib = addr (loc_capas1) -> capas.file_attributes;
  5731.    loc_windowing = addr (loc_capas1) -> capas.windowing;
  5732.  
  5733.    call send_packet (msg_snd_init, length (snd_msg), msg_number);  /* Send the packet. */
  5734.  
  5735.    if ^get_response () then          /* Get a response from the remote side. */
  5736.       return (state);
  5737.  
  5738.    call prs_send_init;           /* Process ACK response. */
  5739.    call set_params;
  5740.  
  5741.    if state = state_x then  /* Text transfer : the file is already open. */
  5742.       return (state_xf);
  5743.  
  5744.    temp = match_file ();
  5745.    if temp ^= 0 then
  5746.       do;
  5747.          call get_error_msg (temp);
  5748.          snd_msg = 'Unable to match files on remote system. ' || errmsg;
  5749.          call send_packet (msg_error, length (snd_msg), msg_number);
  5750.          return (state_a);
  5751.       end;
  5752.  
  5753.    if num_matches = 0 then           /* Check for no matching files. */
  5754.       do;
  5755.          snd_msg = 'No matching files on remote system.';
  5756.          call send_packet (msg_error, length (snd_msg), msg_number);
  5757.          return (state_a);
  5758.       end;
  5759.  
  5760.    file_idx = 1;           /* Send the first file. */
  5761.  
  5762.    return (state_sf);
  5763.  
  5764.    end;             /* Send_init */
  5765.  
  5766. /* ******************************* Send_file ******************************* */
  5767.  
  5768. Send_file : proc returns (fixed bin);
  5769.  
  5770. Dcl test_flag bit (1) aligned;
  5771.  
  5772. /* ************************************************************************* */
  5773.  
  5774.    stop_xfer = false;       /* Initialize the file interrupt flags. */
  5775.    stop_trans = false;
  5776.    first_read = true;       /* Say that this is the first read of the file. */
  5777.    test_flag = true;
  5778.  
  5779.    if state = state_sf then      /* File transfer : send the file name. */
  5780.       if next_file () ^= ker_normal then
  5781.          return (state_sb);
  5782.       else
  5783.          snd_msg = clr8str (file_name);
  5784.  
  5785.    do while (test_flag);
  5786.  
  5787.       if state = state_sf then
  5788.          call send_packet (msg_file, length (file_name), msg_number);
  5789.       else
  5790.          call send_packet (msg_text, 0, msg_number);
  5791.  
  5792.       if ^get_response () then      /* Get a response from the remote side. */
  5793.          if state = state_a then
  5794.             return (state_a);
  5795.          else
  5796.             ;
  5797.       else
  5798.          test_flag = false;
  5799.  
  5800.    end;
  5801.  
  5802.    if log_opened then        /* See if our file name was acceptable. */
  5803.       do;
  5804.          temp = length (rec_msg);
  5805.          if temp > pkt_msg then
  5806.             call log_info ('The file will be received as ' || substr (rec_msg, pkt_msg, temp - pkt_msg) || '.');
  5807.       end;
  5808.  
  5809.    call setup_trans_char;    /* Setup the character translation table. */
  5810.  
  5811.    /* If this is a file transfer, and attributes are expected, send them. */
  5812.  
  5813.    if (state = state_sf) & rem_file_attrib then
  5814.       return (state_sa);
  5815.  
  5816.    if do_windowing then             /* Otherwise, transmit the data. */
  5817.       do;
  5818.          tab_first = msg_number;
  5819.          tab_next = msg_number;
  5820.          do_flush = false;
  5821.          return (state_sdw);
  5822.       end;
  5823.    else
  5824.       return (state_sd);
  5825.  
  5826.    end;         /* Send_file */
  5827.  
  5828. /* ****************************** Send_attrib ****************************** */
  5829.  
  5830. Send_attrib : proc returns (fixed bin);
  5831.  
  5832. Dcl test_flag bit (1) aligned;
  5833.  
  5834. /* ************************************************************************* */
  5835.  
  5836.    test_flag = true;
  5837.  
  5838.    call get_attr;            /* Form the attribute packet. */
  5839.  
  5840.    do while (test_flag);     /* Send the data packet. */
  5841.  
  5842.       call send_packet (msg_attrib, length (snd_msg), msg_number);
  5843.  
  5844.       if ^get_response () then    /* Get a response from the remote side. */
  5845.          if state = state_a then
  5846.             return (state_a);
  5847.          else
  5848.             ;
  5849.       else
  5850.          test_flag = false;
  5851.    end;
  5852.  
  5853.    if length (rec_msg) > pkt_msg then
  5854.       rec_msg = substr (rec_msg, pkt_msg, 1);
  5855.    else
  5856.       rec_msg = '';
  5857.  
  5858.    if rec_msg = 'N' then      /* We cannot send this file for some reason. */
  5859.       do;
  5860.          stop_xfer = true;
  5861.          return (state_sz);
  5862.       end;
  5863.  
  5864.    return (state_sd);  /* Send the first data packet (always non-windowing). */
  5865.  
  5866.    end;     /* Send_attrib */
  5867.  
  5868. /* ******************************* Send_data ******************************* */
  5869.  
  5870. Send_data : proc returns (fixed bin);
  5871.  
  5872. Dcl status fixed bin,
  5873.     test_flag bit (1) aligned;
  5874.  
  5875. /* ************************************************************************* */
  5876.  
  5877.    test_flag = true;
  5878.  
  5879.    status = read_input (code);      /* Get the next buffer of data. */
  5880.  
  5881.    select (status);
  5882.  
  5883.       when (ker_normal)
  5884.          ;
  5885.  
  5886.       when (ker_eof)
  5887.          return (state_sz);
  5888.  
  5889.       otherwise
  5890.          do;
  5891.             call get_error_msg (code);
  5892.             snd_msg = 'Error reading file on remote system. ' || errmsg;
  5893.             call send_packet (msg_error, length (snd_msg), msg_number);
  5894.             return (state_a);
  5895.          end;
  5896.    end;
  5897.  
  5898.    do while (test_flag);      /* Send the data packet. */
  5899.  
  5900.       call send_packet (msg_data, length (snd_msg), msg_number);
  5901.  
  5902.       if ^get_response () then    /* Get the response from the remote side. */
  5903.          if state = state_a then
  5904.             return (state_a);
  5905.          else
  5906.             ;
  5907.       else
  5908.          test_flag = false;
  5909.    end;
  5910.  
  5911.    if length (rec_msg) > pkt_msg then    /* Check for file transfer interruption. */
  5912.       rec_msg = substr (rec_msg, pkt_msg, 1);
  5913.    else
  5914.       rec_msg = '';
  5915.  
  5916.    stop_xfer = (rec_msg = 'X');
  5917.    stop_trans = (rec_msg = 'Z');
  5918.  
  5919.    if stop_xfer | stop_trans then
  5920.       return (state_sz);
  5921.  
  5922.    if do_windowing then  /* If we are windowing, then change to SDW state. */
  5923.       do;
  5924.          tab_first = msg_number;
  5925.          tab_next = msg_number;
  5926.          do_flush = false;
  5927.          return (state_sdw);
  5928.       end;
  5929.    else
  5930.       return (state_sd);
  5931.  
  5932.    end;            /* Send_data */
  5933.  
  5934. /* ***************************** Send_windowing **************************** */
  5935.  
  5936. Send_windowing : proc returns (fixed bin);
  5937.  
  5938. Dcl status fixed bin;
  5939.  
  5940. /* ************************************************************************* */
  5941.  
  5942.    status = read_input (code);   /* Get the next buffer of data. */
  5943.  
  5944.    select (status);
  5945.  
  5946.       when (ker_normal)
  5947.          ;
  5948.  
  5949.       when (ker_eof)
  5950.          if ^prs_input (true) then
  5951.             return (state_a);
  5952.          else
  5953.             return (state_sz);
  5954.  
  5955.       otherwise
  5956.          do;
  5957.             call get_error_msg (code);
  5958.             snd_msg = 'Error reading file on remote system. ' || errmsg;
  5959.             call send_packet (msg_error, length (snd_msg), msg_number);
  5960.             return (state_a);
  5961.          end;
  5962.    end;
  5963.  
  5964.    msg_table.slot(msg_number).msg = snd_msg;       /* Update the table. */
  5965.    msg_table.slot(msg_number).acked = false;
  5966.    msg_table.slot(msg_number).retries = 0;
  5967.  
  5968.    call send_packet (msg_data, length (snd_msg), msg_number);   /* Send the data packet. */
  5969.  
  5970.    msg_number = mod (msg_number + 1, 64);   /* Increment the message number. */
  5971.    tab_next = msg_number;
  5972.  
  5973.    if ^prs_input (false) then     /* Get a response from the remote side. */
  5974.       return (state_a);
  5975.  
  5976.    if stop_xfer | stop_trans then  /* Check for file transfer interruption. */
  5977.       return (state_sz);
  5978.  
  5979.    return (state_sdw);
  5980.  
  5981.    end;               /* Send_windowing */
  5982.  
  5983. /* ******************************* Send_eof ******************************** */
  5984.  
  5985. Send_eof : proc returns (fixed bin);
  5986.  
  5987. /* ************************************************************************* */
  5988.  
  5989.    do_flush = true;         /* Start flushing input before each output. */
  5990.  
  5991.    call close_input;
  5992.  
  5993.    if stop_xfer | stop_trans then  /* Check for file transfer interruption. */
  5994.       do;
  5995.          call log_info ('File transfer interrupted.');
  5996.  
  5997.          snd_msg = 'D';           /* Discard indication. */
  5998.          msg_number = mod (rec_seq + 1, 64);       /* Reset sequence number. */
  5999.          call sleep$ (5000); /* Wait 5 secs to allow receiver to flush input. */
  6000.          call send_packet (msg_eof, length (snd_msg), msg_number);
  6001.       end;
  6002.    else
  6003.       call send_packet (msg_eof, 0, msg_number); /* Normal EOF : send end-of-file indicator packet. */
  6004.  
  6005.    if ^get_response () then       /* Get a response from the remote side. */
  6006.       return (state);
  6007.  
  6008.    if stop_trans then
  6009.       return (state_sb);
  6010.  
  6011.    return (state_sf);
  6012.  
  6013.    end;           /* Send_eof */
  6014.  
  6015. /* ******************************* Send_break ****************************** */
  6016.  
  6017. Send_break : proc returns (fixed bin);
  6018.  
  6019. /* ************************************************************************* */
  6020.  
  6021.    call send_packet (msg_break, 0, msg_number); /* Send end-of-file-set indicator packet. */
  6022.  
  6023.    if ^get_response () then    /* Get a response from the remote side. */
  6024.       return (state);
  6025.  
  6026.    return (state_c);
  6027.  
  6028.    end;            /* Send_break */
  6029.  
  6030. /* ****************************** Get_response ***************************** */
  6031.  
  6032. Get_response : proc returns (bit (1) aligned);
  6033.  
  6034. Dcl fail bit (1) aligned;
  6035.  
  6036. /* ************************************************************************* */
  6037.  
  6038.    fail = false;
  6039.  
  6040.    call rec_packet;    /* Get a packet from the remote side. */
  6041.  
  6042.    select (rec_pkt_type);          /* Check the packet type. */
  6043.  
  6044.       when (msg_timeout, msg_check_err)        /* Timeout. */
  6045.          fail = true;
  6046.  
  6047.       when (msg_ack)                           /* ACK type. */
  6048.          if rec_seq ^= msg_number then
  6049.             fail = true;
  6050.  
  6051.       when (msg_nak)                           /* NAK type. */
  6052.  
  6053.               /* Treat an ACK to packet n+1 as an ACK of packet n.
  6054.                  This covers the case when the ACK to packet n is lost, and the
  6055.                  remote later sends a NAK. Any other NAKs cause a retransmit. */
  6056.  
  6057.          if rec_seq ^= mod (msg_number + 1, 64) then
  6058.             fail = true;
  6059.  
  6060.       when(msg_error)                          /* Error type. */
  6061.          do;
  6062.             state = state_a;
  6063.             return (false);
  6064.          end;
  6065.  
  6066.       otherwise
  6067.          do;
  6068.             snd_msg = 'Unexpected packet type "' || rec_pkt_type || '" received on remote system.';
  6069.             call send_packet (msg_error, length (snd_msg), msg_number);
  6070.             state = state_a;
  6071.             return (false);
  6072.          end;
  6073.    end;       /* Select */
  6074.  
  6075.    if ^fail then          /* A good response. */
  6076.       do;
  6077.          num_retries = 0;
  6078.          msg_number = mod (msg_number + 1, 64);
  6079.          return (true);
  6080.       end;
  6081.  
  6082.    if num_retries > max_retries then         /*  No response ? */
  6083.       do;
  6084.          num_retries = 0;
  6085.          snd_msg = 'Retry limit exceeded on remote system.';
  6086.          call send_packet (msg_error, length (snd_msg), msg_number);
  6087.          state = state_a;
  6088.       end;
  6089.    else
  6090.       num_retries = num_retries + 1;
  6091.  
  6092.    return (false);
  6093.  
  6094.    end;             /* Get_response */
  6095.  
  6096. /* ******************************* Prs_input ******************************* */
  6097.  
  6098. Prs_input : proc (eof) returns (bit (1) aligned);
  6099.  
  6100. Dcl eof bit (1) aligned;
  6101.  
  6102. Dcl i fixed bin;
  6103.  
  6104. /* ************************************************************************* */
  6105.  
  6106. Get_pkt :
  6107.  
  6108.    if eof then   /* Wait for a packet until all are acknowledged. */
  6109.       if tab_first = tab_next then
  6110.          return (true);
  6111.       else
  6112.          goto rec_pkt;
  6113.  
  6114.    /* If the window is not blocked, make sure there is input. */
  6115.  
  6116.    if tab_next ^= mod (tab_first + window_size, 64) then
  6117.       if ^tty$in () then
  6118.           return (true);
  6119.       else
  6120.          goto rec_pkt;
  6121.  
  6122.    /* Window is blocked : Check for special case. */
  6123.  
  6124.    if msg_table.slot(tab_first).retries = 0 then
  6125.       do;
  6126.          i = mod (tab_first + 1, 64);    /* If some later packet has been received,
  6127.                                             then resend earliest one. */
  6128.  
  6129.          do while (i ^= mod (tab_first + window_size, 64));
  6130.             if msg_table.slot(i).acked then
  6131.                do;
  6132.                   i = tab_first;
  6133.                   call log_info ('Resend - window blocked.');
  6134.                   goto resend;
  6135.                end;
  6136.             i = mod (i + 1, 64);
  6137.          end;
  6138.       end;
  6139.  
  6140. Rec_pkt :                /* Receive a packet from the remote side. */
  6141.  
  6142.    call rec_packet;
  6143.  
  6144.    select (rec_pkt_type);          /* Check the packet type. */
  6145.  
  6146.       when (msg_timeout)
  6147.          do;
  6148.             i = tab_first;         /* Resend oldest unacked packet. */
  6149.             do while (msg_table.slot(i).acked);
  6150.                i = mod (i + 1, 64);
  6151.                if i = tab_next then
  6152.                   return (true);
  6153.             end;
  6154.  
  6155.             call log_info ('Resend - timeout.');
  6156.          end;
  6157.  
  6158.       when (msg_check_err)
  6159.          do;
  6160.             call log_info ('Checksum error - ignore packet.');
  6161.             goto get_pkt;
  6162.          end;
  6163.  
  6164.       when (msg_ack)
  6165.          do;               /* Check for ACK/Interrupt packets. */
  6166.             if length (rec_msg) > pkt_msg then
  6167.                rec_msg = set8 (substr (rec_msg, pkt_msg, 1));
  6168.             else
  6169.                rec_msg = '';
  6170.  
  6171.             stop_xfer = (rec_msg = 'X');
  6172.             stop_trans = (rec_msg = 'Z');
  6173.  
  6174.             if stop_xfer | stop_trans then
  6175.                return (true);
  6176.  
  6177.         /* If the ACK is within bounds, process it. */
  6178.  
  6179.             if between (rec_seq, tab_first, mod (tab_next - 1, 64)) then
  6180.                do;
  6181.                   msg_table.slot(rec_seq).acked = true;
  6182.                   i = tab_first;
  6183.  
  6184.                   do while (msg_table.slot(i).acked);
  6185.                      i = mod (i + 1, 64);
  6186.                      if i = tab_next then
  6187.                         leave;
  6188.                   end;
  6189.  
  6190.                   tab_first = i;
  6191.                end;
  6192.  
  6193.             goto get_pkt;
  6194.  
  6195.          end;
  6196.  
  6197.       when (msg_nak)
  6198.          do;
  6199.  
  6200.                 /* If the NAK is within window, resend requested packet,
  6201.                    otherwise resend earliest, hoping for an ACK. */
  6202.  
  6203.             if between (rec_seq, tab_first, mod (tab_next - 1, 64)) then
  6204.                do;
  6205.                   call log_info ('NAK - resend packet.');
  6206.                   i = rec_seq;
  6207.                end;
  6208.             else
  6209.                do;
  6210.                   call log_info ('NAK - resend earliest packet.');
  6211.                   i = tab_first;
  6212.                end;
  6213.          end;
  6214.  
  6215.       when (msg_error)
  6216.          do;                 /* Error type. */
  6217.             state = state_a;
  6218.             return (false);
  6219.          end;
  6220.  
  6221.       otherwise
  6222.          do;
  6223.             snd_msg = 'Unexpected packet type "' || rec_pkt_type || '" received on remote system.';
  6224.             call send_packet (msg_error, length (snd_msg), msg_number);
  6225.             state = state_a;
  6226.             return (false);
  6227.          end;
  6228.    end;        /* Select */
  6229.  
  6230. Resend :                   /* Resend the packet. */
  6231.  
  6232.    msg_table.slot(i).acked = false;
  6233.    if msg_table.slot(i).retries > max_retries then
  6234.       do;
  6235.          snd_msg = 'Retry limit exceeded on remote system.';
  6236.          call send_packet (msg_error, length (snd_msg), msg_number);
  6237.          return (false);
  6238.       end;
  6239.  
  6240.    snd_msg = msg_table.slot(i).msg;
  6241.    msg_table.slot(i).retries =  msg_table.slot(i).retries + 1;
  6242.    call send_packet (msg_data, length (snd_msg), i);
  6243.  
  6244.    goto get_pkt;
  6245.  
  6246.    end;          /* Prs_input */
  6247.  
  6248.    end;        /* Send_switch */
  6249. -------------------------------------------------------------------------------
  6250.  
  6251. /* SERVER -- Kermit server process. */
  6252.  
  6253. Server : proc;
  6254.  
  6255. $Insert *>insert>common.ins.plp
  6256. $Insert *>insert>kermit.ins.plp
  6257. $Insert *>insert>constants.ins.plp
  6258.  
  6259. Dcl (rep_count, temp, i) fixed bin,
  6260.     new_path char (128) var,
  6261.     chr char (1);
  6262.  
  6263. /* ************************************************************************* */
  6264.  
  6265.    num_retries = 0;         /* Initialize retry count. */
  6266.  
  6267.    do while (true);         /* Main server loop. */
  6268.  
  6269.       msg_number = 0;       /* Reinitialize sequence numbering. */
  6270.  
  6271.       call rec_packet;      /* Get input from line. */
  6272.  
  6273.       select (rec_pkt_type);   /* Process message type. */
  6274.  
  6275.          when (msg_timeout)
  6276.             call send_packet (msg_nak, 0, msg_number);
  6277.  
  6278.          when (msg_init_info)
  6279.             call ack_send_init;
  6280.  
  6281.          when (msg_snd_init)
  6282.             do;
  6283.                call ack_send_init;
  6284.                msg_number = mod (msg_number + 1, 64);
  6285.                state = state_rf;
  6286.                call set_path ('');
  6287.                call rec_switch;
  6288.             end;
  6289.  
  6290.          when (msg_rcv_init)
  6291.             do;
  6292.                if rec_length > pkt_msg then
  6293.                   do;
  6294.                      path_name = set8str (substr (rec_msg, pkt_msg, length (rec_msg) - pkt_msg));
  6295.                      path_name = trim (path_name, '11'b);
  6296.  
  6297.                   /* The pathname may have repeat character processing in it,
  6298.                      so we must handle this. 8-bit quoting and control quoting
  6299.                      are not allowed in path names, and so will be caught
  6300.                      later on. */
  6301.  
  6302.                      if do_repeats then
  6303.                         if index (path_name, loc_rep_chr) ^= 0 then
  6304.                            do;
  6305.                               new_path = '';
  6306.  
  6307.                               do i = 1 to length (path_name);
  6308.                                  chr = substr (path_name, i, 1);
  6309.  
  6310.                                  if chr = loc_rep_chr then
  6311.                                     do;
  6312.                                        i = i + 1;
  6313.                                        rep_count = knum (substr (path_name, i, 1));
  6314.  
  6315.                                        i = i + 1;
  6316.                                        chr = substr (path_name, i, 1);
  6317.                                     end;
  6318.                                  else
  6319.                                     rep_count = 1;
  6320.  
  6321.                                  do temp = 1 to rep_count;
  6322.                                     new_path = new_path || chr;
  6323.                                  end;
  6324.  
  6325.                               end;
  6326.  
  6327.                               path_name = new_path;
  6328.  
  6329.                            end;
  6330.  
  6331.                      call set_path (path_name);
  6332.                   end;
  6333.  
  6334.                i = delay;         /* Save this old value for later. */
  6335.                delay = 0;         /* No delay time for the server. */
  6336.                state = state_s;
  6337.  
  6338.                call send_switch;
  6339.                delay = i;         /* Now restore the old delay time. */
  6340.             end;
  6341.  
  6342.          when (msg_kermit_generic)          /* Generic kermit commands. */
  6343.             if generic_cmd () = ker_exit then
  6344.                return;
  6345.  
  6346.       end;      /* select */
  6347.  
  6348.    end;      /* do while */
  6349.  
  6350.    return;
  6351.  
  6352.    end;      /* Server */
  6353. -------------------------------------------------------------------------------
  6354. /*
  6355.    This routine sets up the trans_char character translation table
  6356.    for either ASCII or binary files. the table is used to translate
  6357.    each character of file data to a representation suitable for
  6358.    transmission. The QUOTE8_CHAR determines whether the data receives
  6359.    8-bit quoting in addition to control character quoting.
  6360. */
  6361.  
  6362. Setup_trans_char : proc;
  6363.  
  6364. $Insert *>insert>common.ins.plp
  6365. $Insert *>insert>kermit.ins.plp
  6366.  
  6367. Dcl (c, sq_bin, s8q_bin, rep_bin) fixed bin,
  6368.     c_ptr ptr,
  6369.     conv_chrs char (3) var,
  6370.     (sq, chr) char (1);
  6371.  
  6372. /* ************************************************************************* */
  6373.  
  6374.    c_ptr = addr (c);
  6375.    char2(1) = nul_7bit_asc;
  6376.  
  6377.    sq = clr8 (loc_quote_chr);      /* Control quote character. */
  6378.    char2(2) = sq;
  6379.    sq_bin = char2_ptr -> fb15_based;
  6380.  
  6381.    char2(2) = clr8 (quote8_char);  /* 8-bit quote character. */
  6382.    s8q_bin = char2_ptr -> fb15_based;
  6383.  
  6384.    char2(2) = clr8 (loc_rep_chr);  /* Repeat character prefix. */
  6385.    rep_bin = char2_ptr -> fb15_based;
  6386.  
  6387.    do c = 0 to 255;
  6388.       chr = substr (c_ptr -> char2_based, 2, 1);
  6389.  
  6390.       if (c < 32) | ((c >= 127) & (c < 160)) | (c = 255) then  /* Control chars. */
  6391.          conv_chrs = sq || ctl (chr);
  6392.       else
  6393.          if (c = sq_bin) | (c = sq_bin + 128) then  /* Control prefix. */
  6394.             conv_chrs = sq || chr;
  6395.          else
  6396.             if (quote8_char ^= 'N') & ((c = s8q_bin) | (c = s8q_bin + 128)) then
  6397.                conv_chrs = sq || chr;       /* 8-bit quote prefix. */
  6398.             else
  6399.                if do_repeats & ((c = rep_bin) | (c = rep_bin + 128)) then
  6400.                   conv_chrs = sq || chr;    /* Repeat character prefix. */
  6401.                else
  6402.                   conv_chrs = chr;  /* Normal character. */
  6403.  
  6404.       if (quote8_char ^= 'N') & (c >= 128) then  /* Apply 8-bit quoting. */
  6405.          trans_char(c) = quote8_char || trans_char(c - 128);
  6406.       else
  6407.          trans_char(c) = conv_chrs;
  6408.  
  6409.    end;
  6410.  
  6411.    if pound_conversion then
  6412.       trans_char(28) = trans_char(156);  /* Pound sign conversion for DOS. */
  6413.  
  6414.    return;
  6415.  
  6416.    end;       /* Setup_trans_char */
  6417. -------------------------------------------------------------------------------
  6418.  
  6419. /* SET_PARAMS -- determine the file transfer parameters. */
  6420.  
  6421. Set_params : proc;
  6422.  
  6423. $Insert *>insert>common.ins.plp
  6424. $Insert *>insert>kermit.ins.plp
  6425. $Insert *>insert>constants.ins.plp
  6426.  
  6427. Dcl rem_8q char (1);
  6428.  
  6429. /* ************************************************************************* */
  6430.  
  6431.    rem_8q = set8 (rem_8quote_chr);  /* Set the top bit for local processing. */
  6432.  
  6433.    quote8_char = 'N';     /* Assume no 8-bit quoting at first. */
  6434.  
  6435.    if loc_8quote_chr = 'Y' then
  6436.       if quote8_ok (rem_8q) then           /* Check on the remote side. */
  6437.          quote8_char = rem_8quote_chr;
  6438.       else
  6439.          ;
  6440.    else
  6441.       if quote8_ok (loc_8quote_chr) then
  6442.          if rem_8q = 'Y' | rem_8q = loc_8quote_chr then /* See if remote agrees. */
  6443.             quote8_char = loc_8quote_chr;
  6444.  
  6445.    do_repeats = (loc_rep_chr = rem_rep_chr) & (loc_rep_chr ^= ' ');
  6446.  
  6447.    do_windowing = loc_windowing & rem_windowing;   /* Determine window size to use. */
  6448.  
  6449.    if do_windowing then
  6450.       if loc_max_wsize <= rem_max_wsize then
  6451.          window_size = loc_max_wsize;
  6452.       else
  6453.          window_size = rem_max_wsize;
  6454.    else
  6455.       window_size = 1;
  6456.  
  6457.    return;
  6458.  
  6459. /* ******************************* Quote8_ok ******************************* */
  6460.  
  6461. Quote8_ok : proc (c) returns (bit (1) aligned);
  6462.  
  6463. Dcl c char (1);
  6464.  
  6465. Dcl n fixed bin;
  6466.  
  6467. /* ************************************************************************* */
  6468.  
  6469.    char2(1) = nul_7bit_asc;
  6470.    char2(2) = c;
  6471.    n = char2_ptr -> fb15_based;
  6472.  
  6473.    if n > 128 then
  6474.       n = n - 128;
  6475.  
  6476.    if ((n >= 33) & (n <= 62)) | ((n >= 96) & (n <= 126)) then
  6477.       return (true);
  6478.    else
  6479.       return (false);
  6480.  
  6481.    end;        /* Quote8_ok */
  6482.  
  6483.    end;     /* Set_params */
  6484. -------------------------------------------------------------------------------
  6485.  
  6486. /* SET_PATH -- Set the pathname, directory name, and file name variables. */
  6487.  
  6488. Set_path : proc (treename);
  6489.  
  6490. Dcl treename char (128) var;
  6491.  
  6492. $Insert *>insert>common.ins.plp
  6493. $Insert *>insert>primos.ins.plp
  6494. $Insert *>insert>constants.ins.plp
  6495. $Insert syscom>keys.ins.pl1
  6496.  
  6497. Dcl (funit, new_dir_len, code) fixed bin,
  6498.     temp_path char (128) var,
  6499.     new_dir_name char (128);
  6500.  
  6501. /* ************************************************************************* */
  6502.  
  6503.    dir_name = '';
  6504.    file_name = '';
  6505.    non_null_dir = false;
  6506.    path_name = trim (treename, '11'b);
  6507.  
  6508.    if path_name = '*' then
  6509.       path_name = '';
  6510.  
  6511.    if path_name = '' then
  6512.       return;
  6513.  
  6514.    temp_path = reverse (path_name);
  6515.    file_name = reverse (before (temp_path, '>'));
  6516.    dir_name = reverse (after (temp_path, '>'));
  6517.  
  6518.    if dir_name = '*' then
  6519.       dir_name = '';
  6520.  
  6521.    non_null_dir = (dir_name ^= '');
  6522.  
  6523.    if non_null_dir then    /* We need to do this to get the partition name. */
  6524.       do;
  6525.          call at$ (k$setc, dir_name, code);
  6526.          if code = 0 then
  6527.             do;
  6528.                call gpath$ (k$cura, funit, new_dir_name, 128, new_dir_len, code);
  6529.                if code = 0 then
  6530.                   do;
  6531.                      dir_name = substr (new_dir_name, 1, new_dir_len);
  6532.                      path_name = dir_name || '>' || file_name;
  6533.                   end;
  6534.             end;
  6535.  
  6536.          call at$hom (code);
  6537.  
  6538.       end;
  6539.  
  6540.    return;
  6541.  
  6542.    end;       /* Set_path */
  6543. -------------------------------------------------------------------------------
  6544.  
  6545. /* TIMEOUT_HNDLR -- On_unit for receive timeout (ALARM$ condition). */
  6546.  
  6547. Timeout_hndlr : proc (dummy);
  6548.  
  6549. Dcl dummy ptr;
  6550.  
  6551. $Insert *>insert>common.ins.plp
  6552.  
  6553. /* ************************************************************************* */
  6554.  
  6555.    /* "timeout" is a label variable which is set to a local label
  6556.       in REC_PACKET every time that routine is called. This enables
  6557.       us to create the on-unit once at startup yet have it return to
  6558.       a sub-procedure when the condition arises.
  6559.    */
  6560.  
  6561.    goto timeout;
  6562.  
  6563.    end;       /* Timeout_hndlr */
  6564. -------------------------------------------------------------------------------
  6565.  
  6566. /* CTL -- Toggle character's "control" bit. */
  6567.  
  6568. Ctl : proc (char_str) returns (char (1));
  6569.  
  6570. Dcl char_str char (1);
  6571.  
  6572. $Insert *>insert>common.ins.plp
  6573. $Insert *>insert>kermit.ins.plp
  6574.  
  6575. Dcl bit8 bit (8) aligned,
  6576.     bit8_ptr ptr,
  6577.     fb fixed bin;
  6578.  
  6579. Dcl 1 b8 based,
  6580.       2 high_bit bit (1),
  6581.       2 ctrl_bit bit (1),
  6582.       2 b6 bit (6);
  6583.  
  6584. /* ************************************************************************* */
  6585.  
  6586.    bit8_ptr = addr (bit8);
  6587.    bit8_ptr -> char1_based = char_str;
  6588.    bit8_ptr -> b8.ctrl_bit = ^(bit8_ptr -> b8.ctrl_bit);
  6589.  
  6590.    return (bit8_ptr -> char1_based);
  6591.  
  6592. /* ********************************* Knum ********************************** */
  6593.  
  6594. /* KNUM -- Kermit function to make character a number. */
  6595.  
  6596. Knum : entry (char_k) returns (fixed bin);
  6597.  
  6598. Dcl char_k char (1);
  6599.  
  6600. /* ************************************************************************* */
  6601.  
  6602.    fb = 0;
  6603.    substr (addr (fb) -> char2_based, 2, 1) = char_k;
  6604.  
  6605.    if fb >= 128 then
  6606.       fb = fb - 128;
  6607.  
  6608.    fb = fb - 32;              /* Turn off "printable" bit. */
  6609.  
  6610.    return (fb);
  6611.  
  6612. /* ********************************* Set8 ********************************** */
  6613.  
  6614. /* SET8 -- Set high bit on a character. */
  6615.  
  6616. Set8 : entry (ch1) returns (char (1));
  6617.  
  6618. Dcl ch1 char (1);
  6619.  
  6620. /* ************************************************************************* */
  6621.  
  6622.    bit8_ptr = addr (bit8);
  6623.    bit8_ptr -> char1_based = ch1;
  6624.    bit8_ptr -> b8.high_bit = '1'b;
  6625.  
  6626.    return (bit8_ptr -> char1_based);
  6627.  
  6628. /* ********************************* Clr8 ********************************** */
  6629.  
  6630. /* CLR8 -- Clear high bit on a character. */
  6631.  
  6632. Clr8 : entry (ch1) returns (char (1));
  6633.  
  6634. /* ************************************************************************* */
  6635.  
  6636.    bit8_ptr = addr (bit8);
  6637.    bit8_ptr -> char1_based = ch1;
  6638.    bit8_ptr -> b8.high_bit = '0'b;
  6639.  
  6640.    return (bit8_ptr -> char1_based);
  6641.  
  6642. /* ******************************** Set8str ******************************** */
  6643.  
  6644. /* SET8STR -- Set high bit on all characters in a string. */
  6645.  
  6646. Set8str : entry (str1) returns (char (ibuffer_size) var);
  6647.  
  6648. Dcl str1 char (ibuffer_size) var;
  6649.  
  6650. Dcl str2 char (ibuffer_size) var,
  6651.     (str_ptr, str_ptr2) ptr,
  6652.     (i, j) fixed bin;
  6653.  
  6654. /* ************************************************************************* */
  6655.  
  6656.    str2 = '';
  6657.    j = length (str1);
  6658.    str_ptr = addrel (addr (str1), 1);
  6659.    str_ptr2 = addr (str2);
  6660.    str_ptr2 -> fb15_based = j;             /* Set the string length. */
  6661.    str_ptr2 = addrel (str_ptr2, 1);
  6662.  
  6663.    do i = 1 to j by 2;       /* Process the string 2 characters at a time. */
  6664.       str_ptr2 -> bit16_based = str_ptr -> bit16_based | '8080'b4;
  6665.       str_ptr = addrel (str_ptr, 1);
  6666.       str_ptr2 = addrel (str_ptr2, 1);
  6667.    end;
  6668.  
  6669.    if mod (j, 2) > 0 then    /* We mustn't forget the last odd character. */
  6670.       str_ptr2 -> bit8_based = str_ptr -> bit8_based | '80'b4;
  6671.  
  6672.    return (str2);
  6673.  
  6674. /* ******************************** Clr8str ******************************** */
  6675.  
  6676. /* CLR8STR -- Clear high bit on all characters in a string. */
  6677.  
  6678. Clr8str : entry (str1) returns (char (ibuffer_size) var);
  6679.  
  6680. /* ************************************************************************* */
  6681.  
  6682.    str2 = '';
  6683.    j = length (str1);
  6684.    str_ptr = addrel (addr (str1), 1);
  6685.    str_ptr2 = addr (str2);
  6686.    str_ptr2 -> fb15_based = j;             /* Set the string length. */
  6687.    str_ptr2 = addrel (str_ptr2, 1);
  6688.  
  6689.    do i = 1 to j by 2;       /* Process the string 2 characters at a time. */
  6690.       str_ptr2 -> bit16_based = str_ptr -> bit16_based & '7F7F'b4;
  6691.       str_ptr = addrel (str_ptr, 1);
  6692.       str_ptr2 = addrel (str_ptr2, 1);
  6693.    end;
  6694.  
  6695.    if mod (j, 2) > 0 then    /* We mustn't forget the last odd character. */
  6696.       str_ptr2 -> bit8_based = str_ptr -> bit8_based & '7F'b4;
  6697.  
  6698.    return (str2);
  6699.  
  6700. /* ******************************** Between ******************************** */
  6701.  
  6702. Between : entry (num, lo, hi) returns (bit (1) aligned);
  6703.  
  6704. Dcl (num, lo, hi) fixed bin;
  6705.  
  6706. /* ************************************************************************* */
  6707.  
  6708.    if lo <= hi then
  6709.       return ((num >= lo) & (num <= hi));
  6710.    else
  6711.       return ((num <= hi) | (num >= lo));
  6712.  
  6713.    end;       /* Utilities */
  6714. -------------------------------------------------------------------------------
  6715.  
  6716. /* WRITE_IBUF -- Write intermediate buffer to disk file. */
  6717.  
  6718. Write_ibuf : proc (key, code);
  6719.  
  6720. Dcl (key, code) fixed bin;
  6721.  
  6722. $Insert *>insert>common.ins.plp
  6723. $Insert *>insert>kermit.ins.plp
  6724. $Insert *>insert>primos.ins.plp
  6725. $Insert *>insert>constants.ins.plp
  6726. $Insert syscom>keys.ins.pl1
  6727.  
  6728. Dcl rnw fixed bin;
  6729.  
  6730. /* ************************************************************************* */
  6731.  
  6732.    code = 0;
  6733.  
  6734.    /* Initially we try to write the file out as an ASCII file, unless the
  6735.       file type has been set or any 8-bit characters are seen. */
  6736.  
  6737.    if file_type ^= binary_ft then
  6738.       call write_text;
  6739.  
  6740.    /* If write_text decides it's actually a binary file, it will change FILE_TYPE. */
  6741.  
  6742.    if file_type = binary_ft then
  6743.       call write_binary;
  6744.  
  6745.    return;
  6746.  
  6747. /* ***************************** Write_binary ****************************** */
  6748.  
  6749. Write_binary : proc;
  6750.  
  6751. Dcl rwl_key (2) fixed bin,
  6752.     odd bit (1) aligned;
  6753.  
  6754. /* ************************************************************************* */
  6755.  
  6756.    /* This code adds an extra CTRL-Z to ibuffer if the file length is odd,
  6757.    /* this enables us to write out an even number of characters and not lose
  6758.    /* the last character. The file read/write lock is set to NONE to show this.
  6759.    /* The file length is decremented by 1 in OPEN_INPUT (downloading) if the
  6760.    /* rwlock is set to NONE (3). Note : this scheme for preserving the exact
  6761.    /* character length of the file will only work if the uploading process has
  6762.    /* OWNER (O) or PROTECT (P) access to the file. Otherwise the lock is not
  6763.    /* changed and the extra CTRL-Z will be downloaded. The error is not reported. */
  6764.  
  6765.    odd = (mod (ibuf_ptr, 2) = 1);
  6766.  
  6767.    if key = 1 then     /* If key indicates this is the end of the file ... */
  6768.       if odd then
  6769.          do;
  6770.             ibuf_ptr = ibuf_ptr + 1;
  6771.             substr (ibuffer, ibuf_ptr, 1) = ctrl_z_7bit_asc;
  6772.  
  6773.             if non_null_dir then
  6774.                call at$ (k$setc, dir_name, code);
  6775.  
  6776.             rwl_key(1) = k$none;
  6777.             rwl_key(2) = 0;
  6778.  
  6779.             if code = 0 then
  6780.                call satr$$ (k$rwlk, (file_name), length (file_name), addr (rwl_key) -> fb31_based, code);
  6781.  
  6782.             if non_null_dir then
  6783.                call at$hom (code);
  6784.          end;
  6785.  
  6786.    call prwf$$ (k$writ, file_unit, ibuffer_ptr, divide (ibuf_ptr, 2, 15), 0, rnw, code);
  6787.  
  6788.    if odd then
  6789.       do;                /* Keep the last odd character. */
  6790.          substr (ibuffer, 1, 1) = substr (ibuffer, ibuf_ptr, 1);
  6791.          ibuf_ptr = 1;
  6792.       end;
  6793.    else
  6794.       ibuf_ptr = 0;      /* Reset position pointer to start of ibuffer. */
  6795.  
  6796.    return;
  6797.  
  6798.    end;       /* Write_binary */
  6799.  
  6800. /* ******************************* Write_text ****************************** */
  6801.  
  6802. Write_text : proc;
  6803.  
  6804. Dcl tbuffer char (2048),
  6805.     (i, tbuf_ptr, save_cnt) fixed bin,
  6806.     (character, prev_char) char (1),
  6807.     char_ptr ptr,
  6808.     crlf_seen bit (1) aligned;
  6809.  
  6810. Dcl 1 bit_char based,
  6811.       2 high_bit bit (1),
  6812.       2 next_bits bit (7);
  6813.  
  6814. /* ************************************************************************* */
  6815.  
  6816.    eol_flag = 0;
  6817.    tbuf_ptr = 0;
  6818.    crlf_seen = false;
  6819.    prev_char = nul_7bit_asc;
  6820.    char_ptr = addr (character);
  6821.  
  6822.    do i = 1 to ibuf_ptr;  /* Set top bit on all chars, and convert EOL sequences. */
  6823.       character = substr (ibuffer, i, 1);
  6824.       if prev_char ^= dc1_8bit_asc then
  6825.          char_ptr -> bit_char.high_bit = '1'b;
  6826.  
  6827.       prev_char = character;
  6828.  
  6829.       if character = cr_8bit_asc then
  6830.          eol_flag = 1;
  6831.       else
  6832.          if character = lf_8bit_asc then
  6833.             eol_flag = eol_flag + 1;
  6834.          else
  6835.             eol_flag = 0;
  6836.  
  6837.       if eol_flag < 2 then         /* Store normal characters. */
  6838.          do;
  6839.             tbuf_ptr = tbuf_ptr + 1;
  6840.             substr (tbuffer, tbuf_ptr, 1) = character;
  6841.          end;
  6842.       else
  6843.          do;                        /* Convert CRLF to LF or LFNUL. */
  6844.             crlf_seen = true;
  6845.             substr (tbuffer, tbuf_ptr, 1) = lf_8bit_asc;
  6846.             if mod (tbuf_ptr, 2) ^= 0 then
  6847.                do;
  6848.                   tbuf_ptr = tbuf_ptr + 1;
  6849.                   substr (tbuffer, tbuf_ptr, 1) = nul_7bit_asc;
  6850.                end;
  6851.          end;
  6852.    end;
  6853.  
  6854.    if tbuf_ptr = 0 then
  6855.       return;
  6856.  
  6857.    save_cnt = 0;
  6858.  
  6859.    if key = 0 then            /* Save the CTRL-Z or CR or odd character. */
  6860.       do;
  6861.          character = substr (tbuffer, tbuf_ptr, 1);
  6862.          if character = ctrl_z_8bit_asc | character = cr_8bit_asc then
  6863.             save_cnt = 1;
  6864.  
  6865.          if mod (tbuf_ptr - save_cnt, 2) = 1 then
  6866.             do;
  6867.                save_cnt = save_cnt + 1;
  6868.  
  6869.                if substr (tbuffer, tbuf_ptr - save_cnt, 1) = dc1_8bit_asc then
  6870.                   save_cnt = save_cnt + 2;
  6871.             end;
  6872.  
  6873.          if save_cnt > 0 then
  6874.             do;
  6875.                substr (ibuffer, 1, save_cnt) = substr (ibuffer, ibuf_ptr - save_cnt + 1, save_cnt);
  6876.                tbuf_ptr = tbuf_ptr - save_cnt;
  6877.             end;
  6878.  
  6879.          ibuf_ptr = save_cnt;
  6880.       end;
  6881.    else
  6882.       do;                /* Last write to file. */
  6883.          if rec_file_type = automatic_ft & ^crlf_seen then
  6884.             do;
  6885.                rec_file_type = binary_ft; /* If the file is read in one go, */
  6886.                file_type = binary_ft; /* and doesn't end in CRLF, then it's BINARY. */
  6887.                if log_opened then
  6888.                   call log_info ('BINARY file type has been detected, and will now be used.');
  6889.                return;
  6890.             end;
  6891.  
  6892.          if substr (tbuffer, tbuf_ptr, 1) = ctrl_z_8bit_asc then
  6893.             tbuf_ptr = tbuf_ptr - 1;        /* Remove the last CTRL-Z. */
  6894.  
  6895.          if tbuf_ptr > 0 then
  6896.             if substr (tbuffer, tbuf_ptr, 1) ^= lf_8bit_asc then
  6897.                if tbuf_ptr > 1 then
  6898.                   if substr (tbuffer, tbuf_ptr - 1, 2) ^= lf_8bit_asc || nul_7bit_asc then
  6899.                      do;
  6900.                         tbuf_ptr = tbuf_ptr + 1;
  6901.                         substr (tbuffer, tbuf_ptr, 1) = lf_8bit_asc;
  6902.                      end;
  6903.                   else
  6904.                      ;
  6905.                else
  6906.                   do;
  6907.                      tbuf_ptr = tbuf_ptr + 1;
  6908.                      substr (tbuffer, tbuf_ptr, 1) = lf_8bit_asc;
  6909.                   end;
  6910.  
  6911.          if mod (tbuf_ptr, 2) = 1 then
  6912.             do;
  6913.                tbuf_ptr = tbuf_ptr + 1;
  6914.                substr (tbuffer, tbuf_ptr, 1) = nul_7bit_asc;
  6915.             end;
  6916.  
  6917.          ibuf_ptr = 0;
  6918.       end;
  6919.  
  6920.    call prwf$$ (k$writ, file_unit, addr (tbuffer), divide (tbuf_ptr, 2, 15), 0, rnw, code);
  6921.  
  6922.    return;
  6923.  
  6924.    end;            /* Write_text */
  6925.  
  6926.    end;        /* Write_ibuf */
  6927. -------------------------------------------------------------------------------
  6928.  
  6929. /* WRITE_OUTPUT -- Write data to output file. */
  6930.  
  6931. Write_output : proc returns (fixed bin);
  6932.  
  6933. $Insert *>insert>kermit.ins.plp
  6934. $Insert *>insert>common.ins.plp
  6935. $Insert *>insert>constants.ins.plp
  6936.  
  6937. Dcl (counter, rec_msg_len, code, rep_count, next, end) fixed bin,
  6938.     (character, chr, space_7bit_asc) char (1),
  6939.     rem_pound_str char (2),
  6940.     (do_8bit_quoting, parity, compress_spaces) bit (1) aligned;
  6941.  
  6942. /* ************************************************************************* */
  6943.  
  6944.    code = 0;
  6945.    char2(1) = nul_7bit_asc;
  6946.    rec_msg_len = length (rec_msg) - 1;
  6947.    do_8bit_quoting = (quote8_char ^= 'N');
  6948.    space_7bit_asc = clr8 (' ');
  6949.    rem_pound_str = rem_quote_chr || '\';
  6950.  
  6951.    do counter = pkt_msg to rec_msg_len until (code ^= 0);
  6952.  
  6953.       character = substr (rec_msg, counter, 1);
  6954.       rep_count = 1;
  6955.       parity = false;
  6956.  
  6957.       if do_repeats then              /* Process repeat characters. */
  6958.          if character = loc_rep_chr then
  6959.             do;
  6960.                counter = counter + 1;
  6961.                rep_count = knum (substr (rec_msg, counter, 1));
  6962.  
  6963.                counter = counter + 1;
  6964.                character = substr (rec_msg, counter, 1);
  6965.             end;
  6966.  
  6967.       if do_8bit_quoting then         /* Process 8-bit quoting. */
  6968.          if character = quote8_char then
  6969.             do;
  6970.                parity = true;
  6971.                counter = counter + 1;
  6972.                character = substr (rec_msg, counter, 1);
  6973.                if rec_file_type = automatic_ft & (substr (rec_msg, counter, 2) ^= rem_pound_str) then
  6974.                   do;
  6975.                      rec_file_type = binary_ft;
  6976.                      file_type = binary_ft;       /* It's a BINARY file. */
  6977.                      if log_opened then
  6978.                         call log_info ('BINARY file type has been detected, and will now be used.');
  6979.                   end;
  6980.             end;
  6981.  
  6982.       if character = rem_quote_chr then   /* Process control character quoting. */
  6983.          do;
  6984.             counter = counter + 1;
  6985.             character = substr (rec_msg, counter, 1);
  6986.             chr = clr8 (character);
  6987.             if chr >= query_7bit_asc & chr < grave_7bit_asc then
  6988.                character = ctl (character);
  6989.          end;
  6990.  
  6991.       if do_8bit_quoting then        /* Now we can add the parity. */
  6992.          if parity then
  6993.             character = set8 (character);
  6994.          else
  6995.             character = clr8 (character);
  6996.       else
  6997.          if do_transparent then
  6998.             if rec_file_type = automatic_ft & character >= nul_8bit_asc then
  6999.                do;
  7000.                   rec_file_type = binary_ft;
  7001.                   file_type = binary_ft;    /* It's a BINARY file. */
  7002.                   if log_opened then
  7003.                      call log_info ('BINARY file type has been detected, and will now be used.');
  7004.                end;
  7005.  
  7006. /* Store in intermediate buffer. */
  7007.  
  7008.       if file_type = ascii_ft & character = space_7bit_asc & rep_count > 2 then
  7009.          do;         /* Spaces are a special case, allow for 2 characters. */
  7010.             next = 2;
  7011.             compress_spaces = true;
  7012.          end;
  7013.       else
  7014.          do;
  7015.             next = rep_count;
  7016.             compress_spaces = false;
  7017.          end;
  7018.  
  7019.       if ibuf_ptr + next > ibuffer_size then
  7020.          call write_ibuf (0, code);       /* Make some space if necessary. */
  7021.  
  7022.       if compress_spaces then
  7023.          do;
  7024.             ibuf_ptr = ibuf_ptr + 1;
  7025.             substr (ibuffer, ibuf_ptr, 1) = dc1_8bit_asc;
  7026.             char2_ptr -> fb15_based = rep_count;
  7027.             character = char2(2);
  7028.             rep_count = 1;
  7029.          end;
  7030.  
  7031.       next = ibuf_ptr + 1;
  7032.       end = ibuf_ptr + rep_count;
  7033.  
  7034.       do ibuf_ptr = next to end;
  7035.          substr (ibuffer, ibuf_ptr, 1) = character;
  7036.       end;
  7037.  
  7038.       ibuf_ptr = ibuf_ptr - 1;     /* Adjustment for the do loop. */
  7039.  
  7040.       if ibuf_ptr >= ibuffer_size then  /* Write out the buffer if its full. */
  7041.          call write_ibuf (0, code);
  7042.  
  7043.    end;            /* do until */
  7044.  
  7045.    return (code);
  7046.  
  7047.    end;         /* Write_output */
  7048. -------------------------------------------------------------------------------
  7049.  
  7050. /* XFER_MODE -- Set or reset packet transfer mode. */
  7051.  
  7052. Xfer_mode : proc (key, code);
  7053.  
  7054. Dcl (key, code) fixed bin;
  7055.  
  7056. $Insert *>insert>common.ins.plp
  7057. $Insert *>insert>kermit.ins.plp
  7058. $Insert *>insert>primos.ins.plp
  7059. $Insert syscom>keys.ins.pl1
  7060.  
  7061. /* ************************************************************************* */
  7062.  
  7063.    code = 0;
  7064.  
  7065.    select (key);
  7066.  
  7067.       when (0)          /* Reset to interactive use. */
  7068.          do;
  7069.             if ^do_transparent then
  7070.                addr (code) -> bit16_based = duplx$ (my_duplex);
  7071.  
  7072.             call erkl$$ (k$writ, my_erase, my_kill, code);
  7073.  
  7074.             call mgset$ (my_msg_state, code);
  7075.          end;
  7076.  
  7077.       when (1)               /* Set up for packet transfer. */
  7078.          do;
  7079.             if ^do_transparent then
  7080.                addr (code) -> bit16_based = duplx$ ('A000'b4);  /* Set to half duplex. */
  7081.  
  7082.             call erkl$$ (k$writ, '
  7083.             call mgset$ (k$rjct, code);  /* Reject any messages we may receive. */
  7084.  
  7085.             auto_sum = do_transparent;   /* Set if we have no parity. */
  7086.          end;
  7087.  
  7088.       otherwise
  7089.          code = -1;
  7090.  
  7091.    end;
  7092.  
  7093.    return;
  7094.  
  7095.    end;      /* Xfer_mode */
  7096.  
  7097. /* END OF PRIME8.SRC */
  7098.