-------------------------------------------------------------------------------
/*
/*   Build file for PRIME Kermit-R21.
/*
&severity &error &routine err
/*
&args rest_of_line : uncl; compile : -c, -comp, -compile fn : entry = @.plp; ~
      como : -como como_file : tree = kermit.build.como; load : -l, -load; ~
      no_compress : -noc, -no_compress; rebuild : -r, -reb, -rebuild; ~
      help : -h, -help, -u, -usage
/*
&if [null %compile%%load%%rebuild%] &then ~
    &s help := HELP
/*
&if ^ [null %help%] &then ~
    &do
       &call print_help
       &stop
    &end
/*
&if ^ [null %rebuild%] &then ~
    &do
       &s compile := true
       &s load := true
    &end
/*
&if [null %no_compress%] & [index %rest_of_line% -debug] = 0 &then ~
    &s compress := compress
&else ~
    &s compress :=
/*
&if ^ [null %como%] &then ~
    &do
       &debug &echo com
       como %como_file%
       date
    &end
/*
&if ^ [null %compile%] &then ~
    &do
       &if ^ [exists *>obj -dir] &then ~
           create *>obj
       &else ~
           &if ^ [null %rebuild%] &then ~
               delete  *>obj>@@ -nvfy -force
/*
       &if [entryname %fn%] = %fn% &then   /* [dir %fn%] = *, doesn't work. ~
           &s fn := *>source>%fn%
/*
       plp %fn% -b *>obj>=.+bin %rest_of_line%
    &end
/*
&if ^ [null %load%] &then ~
    &data bind
          lo *>obj>kermit
          lo *>obj>kermit_init
          lo *>obj>bk_hndlr
          lo *>obj>timeout_hndlr
          lo *>obj>ren_hndlr
          lo *>obj>comnd
          lo *>obj>server
          lo *>obj>generic_cmd
          lo *>obj>rec_switch
          lo *>obj>rec_packet
          lo *>obj>send_switch
          lo *>obj>send_packet
          lo *>obj>utilities
          lo *>obj>chks
          lo *>obj>ack_send_init
          lo *>obj>prs_send_init
          lo *>obj>set_params
          lo *>obj>set_path
          lo *>obj>read_input
          lo *>obj>write_output
          lo *>obj>write_ibuf
          lo *>obj>log_packet
          lo *>obj>log_info
          lo *>obj>next_file
          lo *>obj>setup_trans_char
          lo *>obj>get_attr
          lo *>obj>get_dtc
          lo *>obj>get_len
          lo *>obj>change_dir
          lo *>obj>open_input
          lo *>obj>open_output
          lo *>obj>close_input
          lo *>obj>close_output
          lo *>obj>discard_output
          lo *>obj>open_log
          lo *>obj>match_file
          lo *>obj>xfer_mode
          lo *>obj>get_error_msg
          lo *>obj>convert_file
          li
          rdc
          nwc
          &if ^ [null %compress%] &then ~
          %compress%
          map -undefined
          file
    &end
/*
&if ^ [null %como%] &then ~
    como -e
/*
&stop
/*
&routine err
/*
type Error detected in Kermit build.
/*
&if ^ [null %como%] &then ~
    como -e
/*
&stop
/*
&routine print_help
/*
type
~type '   Usage : CPL KERMIT.BUILD  [-Compile [path_name]]  [-Load]  [-Rebuild]'
~type '                             [-COMO [como_file]]  [-NO_Compress]  [-Help]'
type
type '           Where "path_name" is a Kermit source file path name which'
type '           defaults to "*>SOURCE>@.PLP", and "como_file" is a COMO path'
type '           name which defaults to "*>KERMIT.BUILD.COMO".'
type
/*
&return
-------------------------------------------------------------------------------

/* COMMON.INS.PLP -- Variables held in common storage for Kermit. */

%nolist;

%Replace max_msg by 100,
         max_msg_less1 by 99,
         max_matches by 100,
         max_rem_pad_chrs by 255,
         ibuffer_size by 1024,
         ibuffer_size_wds by 512,
         max_take_level by 25;

                     /* Message variables. */

Dcl snd_msg char (max_msg) var external,
    msg_number fixed bin external,

    rec_msg char (max_msg) var external,
    rec_pkt_type char (1) aligned external,   /* Type of message received. */
    rec_seq fixed bin external,
    rec_length fixed bin external,

    rec_file_size fixed bin (31) external,    /* Received file attributes. */
    rec_file_dtc fixed bin (31) external,
    rec_file_type fixed bin external,
    use_attributes bit (1) aligned external,  /* Do we use the attributes ? */

    1 msg_table external,           /* Packet table for windowing. */
      2 slot (0 : 63),
        3 msg char (max_msg) var,
        3 acked bit (1) aligned,
        3 retries fixed bin,

    tab_first fixed bin external,       /* First msg in the table. */
    tab_next fixed bin external;        /* Position of next msg. */

               /* File transfer status variables. */

Dcl state fixed bin external,              /* Current state. */
    delay fixed bin external,              /* Amount of time to delay. */
    num_retries fixed bin external,        /* Number of retries. */
    quote8_char char (1) external,         /* 8-bit quoting character. */
    file_type fixed bin external,          /* File storage type. */
    explicit_ft_set bit (1) aligned external, /* File type has been set. */
    first_read bit (1) aligned external,   /* First read of the data. */
    filename_warning bit (1) aligned external, /* File re-naming warning. */
    do_repeats bit (1) aligned external,   /* TRUE if repeat processing. */
    do_windowing bit (1) aligned external, /* TRUE when windowing. */
    do_transparent bit (1) aligned external, /* TRUE when transparent. */
    do_flush bit (1) aligned external,     /* Flush rcv buffer when sending. */
    do_8bit_chks bit (1) aligned external, /* TRUE for none parity. */
    auto_sum bit (1) aligned external,     /* Try 7 and 8-bit checksums. */
    log_opened bit (1) aligned external,   /* Log file opened. */
    log_unit fixed bin external,           /* Log file unit. */
    window_size fixed bin external,        /* Transmission window size. */
    errmsg char (128) var external,        /* Error message buffer. */

    timeout label external,                /* Return point on timeout. */
    brk_lbl label external,                /* Return point on break. */
    ren_lbl label external,                /* Return point on re-enter. */

    take_level fixed bin external,         /* Current number of TAKE files open. */
    take_unit (max_take_level) fixed bin external; /* TAKE file units used. */

                     /* Local parameters. */

Dcl loc_pkt_size fixed bin external,        /* Receive packet size. */
    loc_npad fixed bin external,            /* Padding length. */
    loc_padchar char (1) external,          /* Padding character. */
    loc_timeout fixed bin external,         /* Time out. */
    loc_eol char (1) external,              /* Eol character. */
    loc_quote_chr char (1) external,        /* Quote character. */
    loc_8quote_chr char (1) external,       /* 8-bit quoting character. */
    loc_chk_type char (1) external,         /* Checksum type. */
    loc_rep_chr char (1) external,          /* Repeat character. */
    loc_capas1 fixed bin external,          /* Capabilities byte 1. */
    loc_file_attrib bit (1) aligned external, /* Ability to rcv attributes. */
    loc_windowing bit (1) aligned external, /* Ability to do windowing. */
    loc_max_wsize fixed bin external;       /* Max window size. */

                    /* Remote parameters. */

Dcl rem_pkt_size fixed bin external,        /* Send packet size. */
    rem_npad fixed bin external,            /* Padding length. */
    rem_padchar char (1) external,          /* Padding character. */
    rem_pad_chars char (max_rem_pad_chrs) external, /* String of padding characters. */
    rem_timeout fixed bin external,         /* Time out. */
    rem_eol char (1) external,              /* Eol character. */
    rem_quote_chr char (1) external,        /* Quote character. */
    rem_8quote_chr char (1) external,       /* 8-bit quoting character. */
    rem_chk_type char (1) external,         /* Checksum type. */
    rem_rep_chr char (1) external,          /* Repeat character. */
    rem_capas1 fixed bin external,          /* Capabilities byte 1. */
    rem_file_attrib bit (1) aligned external, /* Ability to rcv attributes. */
    rem_windowing bit (1) aligned external, /* Ability to do windowing. */
    rem_max_wsize fixed bin external;       /* Max window size. */

                    /* User Interface. */

Dcl kversion char (32) var external,
    kprompt char (32) var external,
    uppercase char (26) static external init ('ABCDEFGHIJKLMNOPQRSTUVWXYZ'),
    lowercase char (26) static external init ('abcdefghijklmnopqrstuvwxyz');

                    /* File Variables. */

Dcl path_name char (128) var external,       /* Current path name. */
    dir_name char (128) var external,        /* Current directory name. */
    non_null_dir bit (1) aligned external,   /* Directory name is not null ? */
    file_name char (32) var external,        /* Current file name. */
    alternate_fname char (32) var external,  /* Alternate file name. */
    file_unit fixed bin external,            /* File unit. */
    file_opened bit (1) aligned external,    /* Flag for open files. */
    file_len fixed bin (31) external,        /* File length (bytes). */
    file_pos fixed bin (31) external,        /* File position (bytes). */

    matches(max_matches) char (128) var external, /* Pathname list. */
    num_matches fixed bin external,          /* Number matches found. */
    file_idx fixed bin external,             /* Index into matches. */

    del_incomplete bit (1) aligned external, /* Delete incomplete files. */
    ibuffer char (ibuffer_size) external,    /* Intermediate file buffer. */
    ibuffer_ptr ptr external,                /* Pointer to int_buffer. */
    ibuflen fixed bin external,              /* Length of int_buffer. */
    ibuf_ptr fixed bin external,             /* Pointer into int_buffer. */
    eol_flag fixed bin external,             /* Detector for cr lf seqs. */
    char2 (2) char (1) unal external,        /* Two character buffer. */
    char2_ptr ptr external,                  /* And its pointer. */
    pound_conversion bit (1) aligned external, /* Convert DOS pound signs. */
    explicit_pound_set bit (1) aligned external, /* True if SET POUND used. */
    trans_char (0 : 255) char (3) var external; /* Translation table. */

                      /* User Environment. */

Dcl my_msg_state fixed bin external,
    my_duplex bit (16) aligned external,
    my_erase char (2) external,
    my_kill char (2) external;

                       /* Character codes. */

Dcl nul_7bit_asc char (1) external,
    nul_8bit_asc char (1) external,
    ctrl_a_7bit_asc char (1) external,
    ctrl_a_8bit_asc char (1) external,
    bs_7bit_asc char (1) external,
    cr_7bit_asc char (1) external,
    cr_8bit_asc char (1) external,
    lf_7bit_asc char (1) external,
    lf_8bit_asc char (1) external,
    ff_7bit_asc char (1) external,
    dc1_8bit_asc char (1) external,
    ctrl_z_7bit_asc char (1) external,
    ctrl_z_8bit_asc char (1) external,
    query_7bit_asc char (1) external,
    grave_7bit_asc char (1) external;

%list;

/* End of COMMON.INS.PLP */
-------------------------------------------------------------------------------

/* CONSTANTS.INS.PLP -- Constant values used by KERMIT. */

%nolist;

%Replace                                 /* Protocol states. */

    state_s by 1,                        /* Send init state. */
    state_sf by 2,                       /* Send file header. */
    state_sd by 3,                       /* Send file data packet. */
    state_sz by 4,                       /* Send EOF packet. */
    state_sb by 5,                       /* Send break. */
    state_r by 6,                        /* Receive send_init. */
    state_rf by 7,                       /* Receive file header packet. */
    state_rd by 8,                       /* Receive file data packet. */
    state_x by 9,                        /* Text send init. */
    state_xf by 10,                      /* Text header. */
    state_c by 11,                       /* Send complete. */
    state_a by 12,                       /* Abort. */
    state_ra by 13,                      /* Receive attributes. */
    state_sa by 14,                      /* Send attributes. */
    state_rdw by 15,                     /* Rec data windowing. */
    state_sdw by 16;                     /* Send data windowing. */

%Replace                                 /* Status codes. */

    ker_normal by 0,
    ker_internalerr by 1,
    ker_eof by 2,
    ker_nomorfiles by 3,
    ker_illfiltyp by 4,
    ker_exit by 5,
    ker_unimplgen by 6,
    ker_protoerr by 7;

%Replace                                 /* Message constants. */

    pkt_count by 2,                      /* <CHAR(Count)> */
    pkt_seq by 3,                        /* <CHAR(Seq)> */
    pkt_type by 4,                       /* <Message type> */
    pkt_msg by 5,                        /* <MESSAGE-DEPENDENT INFORMATION> */

    pkt_ovr_head by 3,                   /* Overhead added to data length. */
    pkt_tot_ovr_head by 6;               /* Total overhead of the message. */

%Replace                                 /* Message types. */

    msg_data by 'D',                     /* Data packet. */
    msg_attrib by 'A',                   /* File attributes. */
    msg_ack by 'Y',                      /* Acknowledgement. */
    msg_nak by 'N',                      /* Negative acknowledgement. */
    msg_snd_init by 'S',                 /* Send initiate. */
    msg_break by 'B',                    /* Break transmission. */
    msg_file by 'F',                     /* File header. */
    msg_eof by 'Z',                      /* End of file (EOF). */
    msg_error by 'E',                    /* Error. */
    msg_rcv_init by 'R',                 /* Receive initiate. */
    msg_host_command by 'C',             /* Host command. */
    msg_text by 'X',                     /* Plain Text. */
    msg_init_info by 'I',                /* Initialize parameters. */
    msg_kermit by 'K',                   /* Interactive KERMIT command. */
    msg_kermit_generic by 'G',           /* Generic KERMIT command. */
    msg_timeout by 'T',                  /* Timeout. */
    msg_check_err by 'Q';                /* Checksum error. */

%Replace                                 /* Generic commands. */

    msg_gen_login by 'I',                /* Login. */
    msg_gen_finish by 'F',               /* Finish (exit to OS). */
    msg_gen_cwd by 'C',                  /* Change Working Directory. */
    msg_gen_logout by 'L',               /* Logout. */
    msg_gen_directory by 'D',            /* List the directory. */
    msg_gen_disk_usage by 'U',           /* Disk usage. */
    msg_gen_delete by 'E',               /* Delete a file. */
    msg_gen_type by 'T',                 /* Type a file. */
    msg_gen_rename by 'R',               /* Rename file. */
    msg_gen_copy by 'K',                 /* Copy file. */
    msg_gen_program by 'P',              /* Program invocation. */
    msg_gen_who by 'W',                  /* Who's logged in. */
    msg_gen_send by 'M',                 /* Send a message to a user. */
    msg_gen_help by 'H',                 /* Help. */
    msg_gen_query by 'Q',                /* Query status. */
    msg_gen_journal by 'J',              /* Transaction Journal. */
    msg_gen_variable by 'V';             /* Set/Read Variables. */

/*
 *                    INITIALIZATION PACKET FORMAT.
 *
 *           The following describes the send initiate packet.
 *           All fields in the message data area are optional.
 *
 * <"S"><CHAR(Bufsiz)><CHAR(Timeout)><CHAR(npad)><CTL(pad)><CHAR(Eol)><Quote>
 *       <8-bit-quote><Repeat><Reserved><Reserved><Reserved>
 *
 * Bufsiz
 *       Sending Kermit's maximum buffer size.
 *
 * Timeout
 *       Number of seconds after which the sending Kermit wishes to be timed out.
 *
 * Npad
 *       Number of padding characters the sending Kermit needs before each packet.
 *
 * PAD
 *       Padding character.
 *
 * EOL
 *       A line terminator required on all packets set by the receiving Kermit.
 *
 * Quote
 *       The printable ASCII character the sending Kermit will use when quoting
 *       the control characters. Default is "#".
 *
 * 8-bit-quote
 *       Specify quoting mechanism for 8-bit quantities. A quoting mechanism is
 *       necessary when sending to hosts which prevent the use of the 8th bit
 *       for data. When elected, the quoting mechanism will be used by both
 *       hosts, and the quote character must be in the range of 41-76 or 140-176
 *       octal, but different from the control-quoting character. This field is
 *       interpreted as follows :
 *
 *       "Y" - I agree to 8-bit quoting if you request it,
 *       "N" - I will not do 8-bit quoting,
 *       "&" - (or any other character in the range of 41-76 or 140-176) I want
 *             to do 8-bit quoting using this character (it will be done if the
 *             other Kermit puts a "Y" in this field),
 *       Anything else : Quoting will not be done.
 *
 * Repeat
 *       A printable ASCII character for compressing repeated characters.
 *       The default is "~". A " " means no repeat character processing, also
 *       it will only be done if both sides request it with the same character.
 */

%Replace                                 /* Positions within the packet. */

    p_si_bufsiz by 0,                    /* Buffer size. */
    p_si_timout by 1,                    /* Time out. */
    p_si_npad by 2,                      /* Number of padding characters. */
    p_si_pad by 3,                       /* Padding character. */
    p_si_eol by 4,                       /* End of line character. */
    p_si_quote by 5,                     /* Quoting character. */
    p_si_8quote by 6,                    /* 8-bit quoting character. */
    p_si_chk by 7,                       /* Checksum type. */
    p_si_rep by 8,                       /* Repeat character. */
    p_si_capas by 9;                     /* Capabilities. */

%Replace                                 /* My default initialization values. */

    my_pkt_size by 94,                   /* My packet size. */
    my_timeout by 15,                    /* My time out. */
    my_npad by 0,                        /* Amount of padding I require. */
    my_pad_chr by '00'b4,                /* My pad character. */
    my_eol_chr by '8D'b4,                /* My EOL character. <CR> */
    my_quote_chr by '#',                 /* My quoting character. */
    my_8quote_chr by '&',                /* My 8-bit quote character. */
    my_chk_type by '1',                  /* My checksum type => single char. */
    my_rep_chr by '~',                   /* My repeat character prefix. */
    my_capas1 by '0C'b4,                 /* My capabilities => attr. + windows. */
    my_max_wsize by 16;                  /* My maximum window size. */

%Replace                                 /* File types. */

    automatic_ft by -1,                  /* AUTOMATIC file type detection. */
    illegal_ft by 0,                     /* An ILLEGAL file type. */
    ascii_ft by 1,                       /* ASCII/TEXT files. */
    binary_ft by 2;                      /* BINARY/IMAGE files. */

%Replace                                 /* Miscellaneous values. */

    true by '1'b,                        /* Logical .TRUE. */
    false by '0'b,                       /* Logical .FALSE. */
    init_delay by 5,                     /* Initial delay time. */
    max_retries by 5,                    /* Maximum number of retries. */
    bignum by 2147483647,                /* The biggest fixed bin number. */

    ctrl_a_7bit_dec by '01'b4,           /* Control-A */
    ctrl_a_8bit_dec by '81'b4,
    cr_7bit_dec by '0D'b4,               /* Carriage Return */
    cr_8bit_dec by '8D'b4,
    lf_7bit_dec by '0A'b4,               /* Line Feed */
    lf_8bit_dec by '8A'b4,

    query_8bit_asc by '?',
    grave_8bit_asc by '`';

%list;

/* End of CONSTANTS.INS.PLP */
-------------------------------------------------------------------------------

/* PRIMOS.INS.PLP -- Declarations for PRIMOS subroutines and the directory entries. */

%nolist;

Dcl at$ entry (fixed bin, char (*) var, fixed bin),
    at$hom entry (fixed bin),
    at$or entry (fixed bin, fixed bin),
    c1in entry (fixed bin),
    cl$get entry (char (*) var, fixed bin, fixed bin),
    cl$pix entry (bit (16) aligned, char (*) var, ptr, fixed bin, char (*) var,
                  ptr, fixed bin, fixed bin, fixed bin),
    clo$fu entry (fixed bin, fixed bin),
    cnam$$ entry (char (*), fixed bin, char (*), fixed bin, fixed bin, fixed bin),
    cnin$ entry (char (*), fixed bin, fixed bin),
    comi$$ entry (char (*), fixed bin, fixed bin, fixed bin),
    comlv$ entry,
    cv$dtb entry (char (*) var, fixed bin (31), fixed bin),
    cv$fda entry (fixed bin (31), fixed bin, char (21)),
    dir$rd entry (fixed bin, fixed bin, ptr, fixed bin, fixed bin),
    duplx$ entry (bit (16) aligned) returns (bit (16) aligned),
    ent$rd entry (fixed bin, char (*) var, ptr, fixed bin, fixed bin),
    erkl$$ entry (fixed bin, char (2), char (2), fixed bin),
    ertxt$ entry (fixed bin, char (*) var),
    fil$dl entry (char (*) var, fixed bin),
    fnchk$ entry (fixed bin, char (*) var) returns (bit (1) aligned),
    gpath$ entry (fixed bin, fixed bin, char (128), fixed bin, fixed bin, fixed bin),
    ioa$ entry options (variable),
    ioa$rs entry options (variable),
    limit$ entry (fixed bin, fixed bin (31), fixed bin, fixed bin),
    logo$$ entry (fixed bin, fixed bin, char (*), fixed bin, fixed bin (31), fixed bin),
    mgset$ entry (fixed bin, fixed bin),
    mkonu$ entry (char (*) var, entry) options (shortcall (20)),
    msg$st entry (fixed bin, fixed bin, char (*), fixed bin, char (*), fixed bin, fixed bin),
    prwf$$ entry (fixed bin, fixed bin, ptr options (short), fixed bin,
                  fixed bin (31), fixed bin, fixed bin),
    q$read entry (char (*) var, (4) fixed bin (31), fixed bin, fixed bin, fixed bin),
    rdlin$ entry (fixed bin, char (*), fixed bin, fixed bin),
    satr$$ entry (fixed bin, char (*), fixed bin, fixed bin (31), fixed bin),
    sleep$ entry (fixed bin (31)),
    smsg$ entry (fixed bin, char (32), fixed bin, fixed bin, char (*),
                 fixed bin, char (*), fixed bin, (4) fixed bin),
    srch$$ entry (fixed bin, char (*), fixed bin, fixed bin, fixed bin, fixed bin),
    srsfx$ entry (fixed bin, char (*) var, fixed bin, fixed bin, fixed bin,
                  char (*) var, char (*) var, fixed bin, fixed bin),
    tnchk$ entry (fixed bin, char (*) var) returns (bit (1) aligned),
    tnou entry (char (*), fixed bin),
    tnoua entry (char (*), fixed bin),
    tonl entry,
    tty$in entry returns (bit (1) aligned),
    tty$rs entry (fixed bin, fixed bin),
    uid$bt entry (char (6) aligned),
    uid$ch entry (char (6) aligned, char (13)),
    user$ entry (fixed bin, fixed bin),
    wild$ entry (char (*) var, char (*) var, fixed bin) returns (bit (1) aligned),
    wtlin$ entry (fixed bin, char (*), fixed bin, fixed bin);

%Replace dir_entry_size by 37;   /* Correct size at PRIMOS revision 22.0.1a. */

Dcl dir_entry_ptr ptr external;  /* Pointer to the following structure. */

Dcl 1 dir_entry external,        /* PRIMOS directory entry structure. */
      2 ecw,
        3 type bit (8),
        3 len bit (8),
      2 entryname char (32),
      2 pw_protection bit (16) aligned,
      2 non_dflt_protection bit (1) aligned,
      2 file_info,
        3 (long_rat_hdr, dumped, dos_mod, special) bit (1),
        3 rwlock bit (2),
        3 pad1 bit (2),
        3 type bit (8),
      2 dtm,
        3 date,
          4 year bit (7),
          4 month bit (4),
          4 day bit (5),
        3 time fixed bin,
      2 spare (2) fixed bin,
      2 trunc bit (1) aligned,
      2 (dtb, dtc, dta) fixed bin (31),
      2 bra fixed bin (31),
      2 fileid char (8);

%list;

/* End of PRIMOS.INS.PLP */
-------------------------------------------------------------------------------

/* KERMIT.INS.PLP -- Declarations for KERMIT subroutines,
                     Utilities, and some based variables. */

%nolist;

Dcl ack_send_init entry,
    bk_hndlr entry (ptr),
    change_dir entry (char (128) var, fixed bin),
    chks entry (fixed bin, char (*) var) returns (fixed bin),
    close_input entry,
    close_output entry returns (fixed bin),
    comnd entry,
    convert_file entry returns (fixed bin),
    discard_output entry (fixed bin),
    generic_cmd entry returns (fixed bin),
    get_attr entry,
    get_dtc entry returns (char (32) var),
    get_error_msg entry (fixed bin),
    get_len entry returns (fixed bin),
    log_info entry (char (256) var),
    log_packet entry (char (1), fixed bin, char (*) var),
    match_file entry returns (fixed bin),
    kermit_init entry,
    next_file entry returns (fixed bin),
    open_input entry returns (fixed bin),
    open_log entry (char (128) var) returns (fixed bin),
    open_output entry returns (fixed bin),
    prs_send_init entry,
    read_input entry (fixed bin) returns (fixed bin),
    rec_packet entry,
    rec_switch entry,
    ren_hndlr entry (ptr),
    send_packet entry (char (1), fixed bin, fixed bin),
    send_switch entry,
    server entry,
    set_params entry,
    set_path entry (char (128) var),
    setup_trans_char entry,
    timeout_hndlr entry (ptr),
    write_ibuf entry (fixed bin, fixed bin),
    write_output entry returns (fixed bin),
    xfer_mode entry (fixed bin, fixed bin);

                    /* Kermit utilities. */

Dcl between entry (fixed bin, fixed bin, fixed bin) returns (bit (1) aligned),
    clr8 entry (char (1)) returns (char (1)),
    clr8str entry (char (*) var) returns (char (1024) var),
    ctl entry (char (1)) returns (char (1)),
    knum entry (char (1)) returns (fixed bin),
    set8 entry (char (1)) returns (char (1)),
    set8str entry (char (*) var) returns (char (1024) var);

                    /* Based variables. */

Dcl fb15_based fixed bin (15) based,
    fb31_based fixed bin (31) based,
    char1_based char (1) based,
    char2_based char (2) based,
    bit8_based bit (8) aligned based,
    bit16_based bit (16) aligned based,

    1 capas based,                     /* Capability structure. */
      2 rsv2 bit (12),
      2 file_attributes bit (1),
      2 windowing bit (1),
      2 rsv1 bit (1),
      2 continues bit (1);

%list;

/* End of KERMIT.INS.PLP */
-------------------------------------------------------------------------------

/* ACK_SEND_INIT -- Setup our SND_INIT packet to send to other Kermit. */

Ack_send_init : proc;

$Insert *>insert>common.ins.plp
$Insert *>insert>kermit.ins.plp
$Insert *>insert>constants.ins.plp

Dcl (eol_bin, temp) fixed bin,
    eol char (1),
    capa_ptr ptr;

/* ************************************************************************* */

   call prs_send_init;       /* Extract the fields from the init packet. */

   capa_ptr = addr (loc_capas1);      /* Set parameters for file transfer. */
   loc_file_attrib = capa_ptr -> capas.file_attributes;
   loc_windowing = capa_ptr -> capas.windowing;

   call set_params;

   /* Build our ACK packet. */

   char2(1) = nul_7bit_asc;
   char2(2) = loc_eol;
   char2_ptr -> fb15_based = char2_ptr -> fb15_based + 32;  /* Set the printable bit. */
   eol = char2(2);

   eol_bin = loc_pkt_size + 32;
   temp = loc_timeout + 32;

   snd_msg = substr (addr (eol_bin) -> char2_based, 2, 1) ||
             substr (addr (temp) -> char2_based, 2, 1);

   eol_bin = loc_npad + 32;
   temp = loc_capas1 + 32;

   snd_msg = snd_msg || substr (addr (eol_bin) -> char2_based, 2, 1) ||
             ctl (loc_padchar) || eol || loc_quote_chr ||
             quote8_char || loc_chk_type || loc_rep_chr ||
             substr (addr (temp) -> char2_based, 2, 1);

   temp = loc_max_wsize + 32;
   snd_msg = snd_msg || substr (addr (temp) -> char2_based, 2, 1);

   call send_packet (msg_ack, length (snd_msg), rec_seq); /* Send the packet. */

   return;

   end;       /* Ack_send_init */
-------------------------------------------------------------------------------

/* BK_HNDLR -- Break handler for Kermit. */

Bk_hndlr : proc (point);

Dcl point ptr;

$Insert *>insert>common.ins.plp
$Insert *>insert>kermit.ins.plp
$Insert *>insert>primos.ins.plp
$Insert *>insert>constants.ins.plp

Dcl code fixed bin;

/* ************************************************************************* */

   call limit$ ('0602'b4, 0, 0, code);    /* Turn off watchdog timer. */

   call log_info ('.BREAK. received!');       /* Log the break. */

   call xfer_mode (0, code);            /* Reset the user's environment. */

   call tnou ('QUIT.',5);

   goto brk_lbl;

   end;      /* Bk_hndlr */
-------------------------------------------------------------------------------

/* CHANGE_DIR -- Change current directory. */

Change_dir : proc (treename, code);

Dcl treename char (128) var,
    code fixed bin;

$Insert *>insert>common.ins.plp
$Insert *>insert>primos.ins.plp
$Insert syscom>keys.ins.pl1

Dcl pathlen fixed bin,
    new_dir char (128);

/* ************************************************************************* */

   code = 0;

   if treename = '' then     /* Attach to the origin if no treename given. */
      do;
         call at$or (k$seth, code);
         if code = 0 then
            snd_msg = 'Now in your origin directory.';
      end;
   else
      do;
         call at$ (k$seth, treename, code);   /* Don't forget we may have had */
         if code = 0 then             /* passwords, so we can't use SET_PATH. */
            do;
               if substr (treename, 1, 2) = '*>' then
                  do;                   /* Find out where we are! */
                     call gpath$ (k$homa, 0, new_dir, 128, pathlen, code);
                     if code = 0 then
                        treename = substr (new_dir, 1, pathlen);
                     else
                        code = 0;          /* We do this for later. */
                  end;

               snd_msg = 'Now in directory ' || before (treename, ' ') || '.';
            end;
      end;

   return;

   end;       /* Change_dir */
-------------------------------------------------------------------------------

/* CHKS -- Subroutine to compute Kermit checksum. */

Chks : proc (key, str) returns (fixed bin);

Dcl key fixed bin,
    str char (96) var;

$Insert *>insert>constants.ins.plp

Dcl topbyte bit (1) aligned,
    str_ptr ptr,
    (i, str_len, total, word_index) fixed bin;

Dcl 1 non_trans_data (1) based,
      2 a1skip bit (1),
      2 a1 bit (7),
      2 a2skip bit (1),
      2 a2 bit (7);

Dcl 1 trans_data (1) based,
      2 a1 bit (8),
      2 a2 bit (8);

Dcl 1 checksum_format based,
      2 s1 bit (8),
      2 s2 bit (2),
      2 s3 bit (6);

/* ************************************************************************* */

   topbyte = false;   /* Skip first char (mark), take low order byte. */
   word_index = 2;    /* Word index into char var string (skip length). */
   total = 0;
   str_len = length (str);
   str_ptr = addr (str);

   do i = 2 to str_len;

      if topbyte then
         do;
            word_index = word_index + 1;

            if key = 1 then
               total = total + str_ptr -> trans_data(word_index).a1;  /* Parity NONE, 8 bit data, transparent mode. */
            else
               total = total + str_ptr -> non_trans_data(word_index).a1;   /* 7 bit data, non-transparent mode. */
         end;
      else
         if key = 1 then
            total = total + str_ptr -> trans_data(word_index).a2;
         else
            total = total + str_ptr -> non_trans_data(word_index).a2;

      topbyte = ^topbyte;

   end;

   /* Compute checksum from total of character values,
      (Add bits 6 - 7 to bits 0 - 5 then return 6-bit value). */

   total = total + addr (total) -> checksum_format.s2;
   total = addr (total) -> checksum_format.s3;

   return (total);

   end;         /* Chks */
-------------------------------------------------------------------------------

/* CLOSE_INPUT -- Close an input file. */

Close_input : proc;

$Insert *>insert>common.ins.plp
$Insert *>insert>kermit.ins.plp
$Insert *>insert>primos.ins.plp
$Insert *>insert>constants.ins.plp
$Insert syscom>errd.ins.pl1

Dcl code fixed bin;

/* ************************************************************************* */

   if ^explicit_ft_set then
      file_type = automatic_ft;  /* Now we have finished, reset this. */

   if ^explicit_pound_set then   /* This may have changed for BINARY files. */
      pound_conversion = true;

   if file_opened then
      do;
         call clo$fu (file_unit, code);
         if code ^= 0 & code ^= e$unop then
            do;
               call get_error_msg (code);
               snd_msg = 'Unable to close the input file on remote system. ' || errmsg;
               call send_packet (msg_error, length (snd_msg), msg_number);
            end;

         file_opened = false;

      end;

   return;

   end;       /* Close_input */
-------------------------------------------------------------------------------

/* CLOSE_OUTPUT -- Close an output file. */

Close_output : proc returns (fixed bin);

$Insert *>insert>common.ins.plp
$Insert *>insert>kermit.ins.plp
$Insert *>insert>primos.ins.plp
$Insert *>insert>constants.ins.plp
$Insert syscom>keys.ins.pl1
$Insert syscom>errd.ins.pl1

Dcl (code, code2) fixed bin;

/* ************************************************************************* */

   code = 0;

   if ^file_opened then
      do;
         rec_file_type = automatic_ft;
         if ^explicit_ft_set then
            file_type = automatic_ft;

         return (code);
      end;

   call write_ibuf (1, code);        /* Write the buffer to the file first. */

   rec_file_type = automatic_ft;     /* We MUST do this before returning. */
   if ^explicit_ft_set then
      file_type = automatic_ft;

   if code ^= 0 then
      return (code);

   call clo$fu (file_unit, code);

   if code = e$unop then
      code = 0;

   if use_attributes & (rec_file_dtc ^= 0 & rec_file_dtc ^= -1) & code = 0 then
      do;
         code2 = 0;

         if non_null_dir then
            call at$ (k$setc, dir_name, code2);

         if code2 = 0 then
            call satr$$ (k$dtc, (file_name), length (file_name), rec_file_dtc, code2);

         if non_null_dir then
            call at$hom (code2);

      end;

   file_opened = false;

   call set_path ('');

   return (code);

   end;       /* Close_output */
-------------------------------------------------------------------------------

/* COMND -- Kermit command level processor. */

Comnd : proc;

$Insert *>insert>common.ins.plp
$Insert *>insert>kermit.ins.plp
$Insert *>insert>primos.ins.plp
$Insert *>insert>constants.ins.plp
$Insert syscom>keys.ins.pl1
$Insert syscom>errd.ins.pl1

%Replace num_tokens by 3;

Dcl token (num_tokens) char (128) var,
    (num_tok, command, prompt_len, i, code) fixed bin,
    from_comi_hndlr bit (1) aligned,
    kermit_state_ptr ptr,
    (reenter, comi_eof) char (10) var,
    cmd_option char (128) var,
    prompt char (32) var,
    cmd_buf char (160) var;

%Replace kermit_len by 16,
         ambiguous_cmd by -1;

Dcl kermit_state (kermit_len) char (16) var static init (
          'EXIT',
          'HELP',
          'QUIT',
          'RECEIVE',
          'SET',
          'SEND',
          'SERVER',
          'SHOW',
          'TAKE',
          'VERSION',
          'CONVERT',
          'LOG',
          'CLOSE',
          'PUSH',
          'STOP',
          'POP');

%Replace cmd_exit by 1,
         cmd_help by 2,
         cmd_quit by 3,
         cmd_receive by 4,
         cmd_set by 5,
         cmd_send by 6,
         cmd_server by 7,
         cmd_show by 8,
         cmd_take by 9,
         cmd_version by 10,
         cmd_convert by 11,
         cmd_log by 12,
         cmd_close by 13,
         cmd_push by 14,
         cmd_stop by 15,
         cmd_pop by 16;

%Replace show_len by 12;

Dcl show_state (show_len) char (16) var static init (
          'ALL',
          'DELAY',
          'PARITY',
          'QUOTE',
          '8QUOTE',
          'REPEAT',
          'WINDOW',
          'STORAGE_TYPE',
          'INCOMPLETE',
          'POUND',
          'ATTRIBUTES',
          'WARNING');

%Replace show_all by 1,
         show_delay by 2,
         show_parity by 3,
         show_quote by 4,
         show_8quote by 5,
         show_repeat by 6,
         show_wsize by 7,
         show_store by 8,
         show_incomplete by 9,
         show_pound by 10,
         show_attributes by 11,
         show_warning by 12;

/* ************************************************************************* */

   code = 0;
   from_comi_hndlr = false;
   prompt = kprompt || '> ';
   prompt_len = length (prompt);
   kermit_state_ptr = addr (kermit_state);

   reenter = 'REENTER$';
   ren_lbl = ren_point;
   call mkonu$ (reenter, ren_hndlr);

   comi_eof = 'COMI_EOF$';
   call mkonu$ (comi_eof, comi_hndlr);

Ren_point :

   do while (true);

      do until (((length (cmd_buf) ^= 0) & substr (cmd_buf, 1, 1) ^= ctrl_a_8bit_asc) | (code ^= 0));
         call tnoua ((prompt), prompt_len);

Comi_restart :

         call cl$get (cmd_buf, 160, code);
      end;

      if code ^= 0 then
         do;
            call get_error_msg (code);
            call ioa$ ('Error reading the command line. %v%.', 99, errmsg);
            return;
         end;

      call tokenize (cmd_buf);
      command = type (token(1), kermit_state_ptr, kermit_len);
      cmd_option = token(2);

      select (command);        /* Now process the command. */

         when (cmd_take)       /* TAKE input from a file. */
            if num_tok < 2 then
               call tnou ('No pathname given for TAKE command.', 35);
            else
               if cmd_option = 'TTY' | cmd_option = 'PAUSE' |
                  cmd_option = substr ('CONTINUE', 1, length (cmd_option)) then
                  call ioa$ ('The filename "%v" is NOT allowed for the TAKE command. %.',
                             99, cmd_option);
               else
                  if take_level + 1 > max_take_level then
                     call ioa$ ('You have reached the maximum number (%d) of nested TAKE files.%.', 99, max_take_level);
                  else
                     do;
                        i = get_unit (code);
                        if i > 0 then
                           call comi$$ ((cmd_option), length (cmd_option), i, code);
                        if code = 0 then
                           do;
                              take_level = take_level + 1;
                              take_unit(take_level) = i;
                           end;
                        else
                           do;
                              call get_error_msg (code);
                              call ioa$ ('Error opening file %v. %v%.', 99, cmd_option, errmsg);
                           end;
                     end;

         when (cmd_version)          /* Display the current VERSION number. */
            call tnou ((kversion), length (kversion));

         when (cmd_help)                /* Display HELP information. */
            call comnd_help;

         when (cmd_set)                 /* SET parameter. */
            if num_tok < 2 then
               call tnou ('No SET option specified.', 24);
            else
               call comnd_set;

         when (cmd_show)                /* SHOW parameter. */
            do;
               if num_tok < 2 then
                  cmd_option = 'ALL';

               call tonl;
               call comnd_show (type (cmd_option, addr (show_state), show_len));
               call tonl;
            end;

         when (cmd_server)               /* SERVER. */
            do;
               call xfer_mode (1, code);
               call tnou ('Kermit server started.', 22);
               call server;
               call xfer_mode (0, code);
               return;
            end;

         when (cmd_send)                 /* SEND. */
            if num_tok < 2 then
               call tnou ('No pathname(s) given for SEND command.', 38);
            else
               if tnchk$ (k$uprc + k$wldc, cmd_option) then
                  do;
                     call set_path (cmd_option);
                     state = state_s;
                     call xfer_mode (1, code);
                     call tnou ('Kermit send started.', 20);
                     call send_switch;
                     call xfer_mode (0, code);
                  end;
               else
                  call ioa$ ('Invalid SEND pathname(s) "%v".%.', 99, cmd_option);

         when (cmd_receive)              /* RECEIVE. */
            do;
               state = state_r;
               call set_path (cmd_option);
               call xfer_mode (1, code);
               call tnou ('Kermit receive started.', 23);
               call rec_switch;
               call xfer_mode (0, code);
            end;

         when (cmd_convert)              /* CONVERT a file. */
            if num_tok < 2 then
               call tnou ('No filename given for CONVERT command.', 38);
            else
               do;
                  call set_path (cmd_option);
                  code = convert_file ();
                  if code ^= 0 then
                     do;
                        call get_error_msg (code);
                        call ioa$ ('%v. %v%.', 99, snd_msg, errmsg);
                     end;
                  else
                     call ioa$ ('Conversion of file %v successful.%.', 99, cmd_option);
               end;

         when (cmd_log)                  /* LOG command. */
            if log_opened then
               call tnou ('Log file already opened.', 24);
            else
               do;
                  code = open_log (cmd_option);
                  if code ^= 0 then
                     do;
                        call get_error_msg (code);
                        call ioa$ ('Error opening log file. %v%.', 99, errmsg);
                     end;
                  else
                     call tnou ('Log file opened.', 16);
               end;

         when (cmd_close)                /* CLOSE the log file. */
            if log_opened then
               do;
                  log_opened = false;
                  call clo$fu (log_unit, code);
                  if code ^= 0 & code ^= e$unop then
                     do;
                        call get_error_msg (code);
                        call ioa$ ('Error closing the log file. %v%.', 99, errmsg);
                     end;
                  else
                     call tnou ('Log file closed.', 16);
               end;
            else
               call tnou ('Log file not opened.', 20);

         when (cmd_push)             /* PUSH to a new command level. */
            call comlv$;

         when (cmd_pop)
            if take_level > 0 then
               do;
Comi_point :
                  call comi$$ ('TTY', 3, take_unit(take_level), code);

                  take_unit(take_level) = 0;
                  take_level = take_level - 1;

                  if code = 0 then
                     if take_level > 0 then
                        do;
                           call comi$$ ('CONTINUE', 8, take_unit(take_level), code);
                           if code ^= 0 then
                              do;
                                 call get_error_msg (code);
                                 call ioa$ ('Unable to continue the previous TAKE file. %v%.', 99, errmsg);
                                 go to comi_point;
                              end;
                        end;
                     else
                        ;
                  else
                     do;
                        call get_error_msg (code);
                        call ioa$ ('Error closing the current TAKE file. %v%.', errmsg);
                     end;

                  if from_comi_hndlr then
                     do;
                        from_comi_hndlr = false;
                        go to comi_restart;
                     end;

               end;

         when (cmd_stop)
            if take_level > 0 then
               do;
                  call comi$$ ('TTY', 3, take_unit(take_level), code);  /* If this fails then the on-unit should catch EOF. */
                  take_unit(take_level) = 0;

                  take_level = take_level - 1;
                  do i = 1 to take_level;
                     call clo$fu (take_unit(i), code);
                     take_unit(i) = 0;
                  end;

                  take_level = 0;
               end;

         when (cmd_quit, cmd_exit)   /* EXIT to PRIMOS. */
            return;

         when (ambiguous_cmd)
            call ioa$ ('Ambiguous command "%v". Type HELP for a list of commands.%.',
                       99, token(1));

         otherwise
            call ioa$ ('Unrecognized command "%v". Type HELP for a list of commands.%.',
                       99, token(1));

      end;        /* select */

   end;        /* do while */

   return;

/* ******************************* Comnd_help ****************************** */

Comnd_help : proc;

Dcl ans char (16) var;

/* ************************************************************************* */

   call ioa$ ('%/Interactive mode commands : %/%.', 99);
   call ioa$ ('Commands may be abbreviated to those letters in uppercase.%/%.', 99);
   call ioa$ ('  Receive [pathname]                 Upload a file.%.', 99);
   call ioa$ ('  SENd wildcard                      Download file(s) using wildcards.%.', 99);
   call ioa$ ('  SERver                             Start Kermit server.%/%.', 99);

   call ioa$ ('  CLose                              Close the log file.%.', 99);
   call ioa$ ('  COnvert pathname                   Converts a file to PRIME ASCII.%.', 99);
   call ioa$ ('  Exit or Quit                       Leave Kermit.%.', 99);
   call ioa$ ('  Help                               Display this message.%.', 99);
   call ioa$ ('  Log [pathname]                     Start a log file. Default is KERMIT.LOG%.', 99);
   call ioa$ ('  POp                                Close the current TAKE file.%.', 99);
   call ioa$ ('  PUsh                               Return to PRIMOS, and may re-enter Kermit.%.', 99);
   call ioa$ ('  SHow [{parameter | ALL}]           Display the required parameter.%.', 99);
   call ioa$ ('  STop                               Close all TAKE files, and return to Kermit.%.', 99);
   call ioa$ ('  Take pathname                      Execute commands from a file.%.', 99);
   call ioa$ ('  Version                            Display the current version number.%/%.', 99);

   ans = '';
   call tnoua ('More ? ', 7);
   call cl$get (ans, 16, code);
   if code ^= 0 then
      do;
         call get_error_msg (code);
         call ioa$ ('Error reading the command line. %v%.', 99, errmsg);
         return;
      end;

   if length (ans) > 0 then
      ans = translate (substr (trim (ans, '11'b), 1, 1), uppercase, lowercase);
   if ans ^= 'Y' & ans ^= '' then
      return;

   call ioa$ ('%/  SET parameter                      Set one of the following parameters :%.', 99);
   call ioa$ ('      Attributes {ON | OFF}             Use the received file attributes. DTC%.', 99);
   call ioa$ ('%40xand file type are used. Default is ON.%.', 99);
   call ioa$ ('      Delay n                           Delay time in seconds before sending a%.', 99);
   call ioa$ ('%40xfile. Default is %d seconds.%.', 99, init_delay);
   call ioa$ ('      File_Type {AUTO | TEXT | BINARY}  Set the type of file(s) to be sent or%.', 99);
   call ioa$ ('%40xreceived. Default is AUTO.%.', 99);
   call ioa$ ('      Incomplete {SAVE | DELETE}        Keep or delete incompletely received%.', 99);
   call ioa$ ('%40xfiles. Default is DELETE.%.', 99);
   call ioa$ ('      PArity {MARK | NONE}              Set the character parity type.%.', 99);
   call ioa$ ('%40xDefault parity is MARK.%.', 99);
   call ioa$ ('      POUnd {ON | OFF}                  Sets the conversion of DOS pound%.', 99);
   call ioa$ ('%40xsigns. Default is ON.%.', 99);
   call ioa$ ('      Quote char                        Control quoting character to use.%.', 99);
   call ioa$ ('%40x("char" = ASCII printable character).%.', 99);
   call ioa$ ('      8Quote char                       8-bit quoting character to use.%.', 99);
   call ioa$ ('%40x("char" = ASCII grammatical character).%.', 99);
   call ioa$ ('      Repeat char                       Repeat character prefix to use.%.', 99);
   call ioa$ ('%40x("char" = ASCII printable character).%.', 99);
   call ioa$ ('      WArning {ON | OFF}                File name collision warning. Prevents%.', 99);
   call ioa$ ('%40xoverwriting of files. Default is ON.%.', 99);
   call ioa$ ('      WIndow n                          File transfer window size.%.', 99);
   call ioa$ ('%40x(0 <= "n" <= 31, 0 = no windowing).%.', 99);

   return;

   end;      /* Comnd_help */

/* ******************************* Comnd_show ****************************** */

Comnd_show : proc (option);

Dcl option fixed bin;

/* ************************************************************************* */

   select (option);

      when (show_all)
         do i = 2 to show_len;
            call comnd_show (i);
         end;

      when (show_delay)
         call ioa$ ('Time delay before sending a file is %d seconds.%.', 99, delay);

      when (show_parity)
         do;
            call tnoua ('Character parity I will use ......... ', 38);
            if do_transparent then
               call tnou ('NONE', 4);
            else
               call tnou ('MARK', 4);
         end;

      when (show_quote)
         call ioa$ ('Quoting character I will use ........ "%c"%.', 99, loc_quote_chr, 1);

      when (show_8quote)
         do;
            call ioa$ ('8-Bit quoting character I want to use "%c"%$', 99, loc_8quote_chr, 1);
            if loc_8quote_chr = 'N' then
               call tnou ('   (No 8-bit quoting.)', 22);
            else
               call tonl;
         end;

      when (show_repeat)
         do;
            call ioa$ ('Repeat character prefix I want to use "%c"%$', 99, loc_rep_chr, 1);
            if loc_rep_chr = ' ' then
               call tnou ('   (No repeat character processing.)', 36);
            else
               call tonl;
         end;

      when (show_wsize)
         call ioa$ ('Window size I want to use ........... %d%.', 99, loc_max_wsize);

      when (show_store)
         do;
            call tnoua ('File storage type is ................ ', 38);

            select (file_type);
               when (automatic_ft)
                  call tnou ('AUTOMATIC', 9);

               when (ascii_ft)
                  call tnou ('TEXT', 4);

               when (binary_ft)
                  call tnou ('BINARY', 6);

               otherwise
                  call tnou ('ILLEGAL', 7);

            end;

         end;

      when (show_incomplete)
         do;
            call tnoua ('Incomplete files are ................ ', 38);
            if del_incomplete then
               call tnou ('DELETED', 7);
            else
               call tnou ('SAVED', 5);
         end;

      when (show_pound)
         do;
            call tnoua ('DOS pound sign conversion is ........ ', 38);
            if pound_conversion then
               call tnou ('ON', 2);
            else
               call tnou ('OFF', 3);
         end;

      when (show_attributes)
         do;
            call tnoua ('Use of the file attributes is ....... ', 38);
            if use_attributes then
               call tnou ('ON', 2);
            else
               call tnou ('OFF', 3);
         end;

      when (show_warning)
         do;
            call tnoua ('File name collision warning is ...... ', 38);
            if filename_warning then
               call tnou ('ON', 2);
            else
               call tnou ('OFF', 3);
         end;

      when (ambiguous_cmd)
         call ioa$ ('Ambiguous SHOW option "%v". Type HELP for a list of options.%.', 99, cmd_option);

      otherwise
         call ioa$ ('Unrecognized SHOW option "%v". Type HELP for a list of options.%.', 99, cmd_option);

   end;      /* select */

   return;

   end;    /* Comnd_show */

/* ******************************* Comnd_set ******************************* */

Comnd_set : proc;

%Replace set_len by 11;

Dcl set_state (set_len) char (16) var static init (
          'DELAY',
          'PARITY',
          'QUOTE',
          '8QUOTE',
          'WINDOW',
          'FILETYPE',
          'POUND',
          'INCOMPLETE',
          'ATTRIBUTES',
          'REPEAT',
          'WARNING');

%Replace set_delay by 1,
         set_parity by 2,
         set_quote by 3,
         set_8quote by 4,
         set_wsize by 5,
         set_store by 6,
         set_pound by 7,
         set_incomplete by 8,
         set_attributes by 9,
         set_repeat by 10,
         set_warning by 11;

/* ************************************************************************* */

   command = type (cmd_option, addr (set_state), set_len);
   cmd_option = token(3);

   select (command);

      when (set_delay)
         if num_tok < 3 then
            call ioa$ ('No DELAY time given, the current value of %d seconds will be unchanged.%.',
                       99, delay);
         else
            if verify (cmd_option, '0123456789') ^= 0 then
               call ioa$ ('Invalid DELAY time given "%v".%.', 99, cmd_option);
            else                 /* Everything is okay at this point. */
               do;
                  delay = bin (cmd_option, 15);
                  call comnd_show (show_delay);
               end;

      when (set_parity)
         if cmd_option = 'M' | cmd_option = 'MARK' then
            do;
               do_transparent = false;
               do_8bit_chks = false;
               if loc_8quote_chr = 'Y' | loc_8quote_chr = 'N' then
                  do;
                     call tnou ('WARNING : 8-bit quoting MUST be used with MARK parity for binary file transfers.', 80);
                     call comnd_show (show_8quote);
                  end;
               call comnd_show (show_parity);
            end;
         else
            if cmd_option = 'N' | cmd_option = 'NONE' then
               do;
                  do_transparent = true;
                  do_8bit_chks = true;
                  call comnd_show (show_parity);
               end;
            else
               if cmd_option = '' then
                  do;
                     call tnou ('No PARITY option given. The current setting will be unchanged.', 62);
                     call comnd_show (show_parity);
                  end;
               else
                  call ioa$ ('Invalid PARITY option given "%v".%.', 99, cmd_option);

      when (set_quote)
         if length (cmd_option) > 1 then
            call ioa$ ('Invalid control quoting character given "%v".%/Only one character may be specified.%.', 99, cmd_option);
         else
            select (cmd_option);

               when ('')
                  do;
                     call tnou ('No control quoting character given. The current setting will be unchanged.', 74);
                     call comnd_show (show_quote);
                  end;

               when (loc_8quote_chr)
                  call ioa$ ('Invalid control quoting character given "%v".%/It is the same as the 8-bit quoting character.%.', 99, cmd_option);

               when (loc_rep_chr)
                  call ioa$ ('Invalid control quoting character given "%v".%/It is the same as the repeat character prefix.%.', 99, cmd_option);

               otherwise
                  if cmd_option < ' ' | cmd_option > '~' then
                     call tnou ('Invalid control quoting character given. It must be a printable ASCII character.', 80);
                  else
                     do;
                        loc_quote_chr = cmd_option;
                        call comnd_show (show_quote);
                     end;
            end;

      when (set_8quote)
         if length (cmd_option) > 1 then
            call ioa$ ('Invalid 8-bit quoting character given "%v".%/Only one character may be specified.%.', 99, cmd_option);
         else
            select (cmd_option);

               when ('')
                  do;
                     call tnou ('No 8-bit quoting character given. The current setting will be unchanged.', 72);
                     call comnd_show (show_8quote);
                  end;

               when (loc_quote_chr)
                  call ioa$ ('Invalid 8-bit quoting character given "%v".%/It is the same as the control quoting character.%.', 99, cmd_option);

               when (loc_rep_chr)
                  call ioa$ ('Invalid 8-bit quoting character given "%v".%/It is the same as the repeat character prefix.%.', 99, cmd_option);

               otherwise
                  do;
                     loc_8quote_chr = cmd_option;
                     if ^do_transparent & (cmd_option <= ' ' | (cmd_option > '>' &
                                           cmd_option < '`') | cmd_option > '~') then
                        do;
                           call tnou ('WARNING : 8-bit quoting MUST be used with MARK parity for binary file transfers.', 80);
                           call comnd_show (show_parity);
                        end;
                     call comnd_show (show_8quote);
                  end;
            end;

      when (set_repeat)
         if length (cmd_option) > 1 then
            call ioa$ ('Invalid repeat character prefix given "%v".%/Only one character may be specified.%.', 99, cmd_option);
         else
            select (cmd_option);

               when (loc_quote_chr)
                  call ioa$ ('Invalid repeat character prefix given "%v".%/It is the same as the control quoting character.%.', 99, cmd_option);

               when (loc_8quote_chr)
                  call ioa$ ('Invalid repeat character prefix given "%v".%/It is the same as the 8-bit quoting character.%.', 99, cmd_option);

               otherwise
                  if (cmd_option  < ' ' | (cmd_option > '>' & cmd_option < '`') | cmd_option > '~') & cmd_option ^= '' then
                     call tnou ('Invalid repeat character prefix given. It must be a printable ASCII character.', 78);
                  else
                     do;
                        if cmd_option = '' then
                           cmd_option = ' ';

                        loc_rep_chr = cmd_option;
                        call comnd_show (show_repeat);
                     end;
            end;

      when (set_wsize)
         if num_tok < 3 then
            do;
               call tnou ('No WINDOW size given, the current value will be unchanged.', 58);
               call comnd_show (show_wsize);
            end;
         else
            if verify (cmd_option, '0123456789') ^= 0 then
               call ioa$ ('Invalid WINDOW size given "%v".', 99, cmd_option);
            else
               do;
                  i = bin (cmd_option, 15);
                  if i < 0 | i > 31 then
                     call tnou ('Specified WINDOW size out of range. It must be between 0 and 31 inclusive.', 74);
                  else
                     do;
                        loc_max_wsize = i;
                        addr (loc_capas1) -> capas.windowing = (loc_max_wsize > 0);
                        call comnd_show (show_wsize);
                     end;
               end;

      when (set_store)
         select (cmd_option);

            when ('AU', 'AUTO', 'AUTOMATIC')
               do;
                  file_type = automatic_ft;
                  explicit_ft_set = false;
                  if ^explicit_pound_set then  /* Reset this in case it got set before. */
                     pound_conversion = true;
                  call comnd_show (show_store);
               end;

            when ('AS', 'ASCII', 'T', 'TEXT')
               do;
                  file_type = ascii_ft;
                  explicit_ft_set = true;
                  if ^explicit_pound_set then
                     pound_conversion = true;
                  call comnd_show (show_store);
               end;

            when ('B', 'BIN', 'BINARY', 'I', 'IMAGE')
               do;
                  file_type = binary_ft;
                  explicit_ft_set = true;
                  if ^explicit_pound_set then
                     pound_conversion = false;
                  call comnd_show (show_store);
               end;

            when ('')
               do;
                  call tnou ('No storage type given. The current setting will be unchanged.', 61);
                  call comnd_show (show_store);
               end;

            otherwise
               call ioa$ ('Invalid storage type "%v".%.', 99, cmd_option);

         end;

      when (set_pound)
         select (cmd_option);

            when ('ON', 'Y', 'YES')
               do;
                  pound_conversion = true;
                  explicit_pound_set = true;
                  call comnd_show (show_pound);
               end;

            when ('OFF', 'N', 'NO')
               do;
                  pound_conversion = false;
                  explicit_pound_set = true;
                  call comnd_show (show_pound);
               end;

            when ('')
               do;
                  call tnou ('No POUND option given. The current setting will be unchanged.', 61);
                  call comnd_show (show_pound);
               end;

            otherwise
               call ioa$ ('Invalid POUND option "%v".%.', 99, cmd_option);

         end;

      when (set_incomplete)
         select (cmd_option);

            when ('D', 'DEL', 'DELETE', 'DISCARD')
               do;
                  del_incomplete = true;
                  call comnd_show (show_incomplete);
               end;

            when ('S', 'SAVE', 'KEEP')
               do;
                  del_incomplete = false;
                  call comnd_show (show_incomplete);
               end;

            when ('')
               do;
                  call tnou ('No INCOMPLETE option given, the current setting will be unchanged.', 66);
                  call comnd_show (show_incomplete);
               end;

            otherwise
               call ioa$ ('Invalid INCOMPLETE option "%v".%.', 99, cmd_option);

         end;

      when (set_attributes)
         select (cmd_option);

            when ('ON', 'Y', 'YES')
               use_attributes = true;

            when ('OFF', 'N', 'NO')
               use_attributes = false;

            when ('')
               do;
                  call tnou ('No ATTRIBUTES option given, the current setting will be unchanged.', 66);
                  call comnd_show (show_attributes);
               end;

            otherwise
               call ioa$ ('Invalid ATTRIBUTES option "%v".%.', 99, cmd_option);

         end;

      when (set_warning)
         select (cmd_option);

            when ('ON', 'Y', 'YES')
               filename_warning = true;

            when ('OFF', 'N', 'NO')
               filename_warning = false;

            when ('')
               do;
                  call tnou ('No file name WARNING option given, the current setting will be unchanged.', 73);
                  call comnd_show (show_warning);
               end;

            otherwise
               call ioa$ ('Invalid file name WARNING option "%v".%.', 99, cmd_option);

         end;

      when (ambiguous_cmd)
         call ioa$ ('Ambiguous SET option "%v". Type HELP for a list of options.%.', 99, token(2));

      otherwise
         call ioa$ ('Unrecognized SET option "%v". Type HELP for a list of options.%.', 99, token(2));

   end;     /* select */

   return;

   end;   /* Comnd_set */

/* ********************************* Type ********************************** */

/* TYPE -- determine command type from a list of possibilities. */

Type : proc (str, table_ptr, table_len) returns (fixed bin);

Dcl str char (128) var,
    table_ptr ptr,
    table_len fixed bin;

Dcl (str_len, entry_found, i) fixed bin,
    table_entry char (16) var,
    table (1) char (16) var based;

/* ************************************************************************* */

   entry_found = 0;
   str_len = length (str);

   do i = 1 to table_len;
      table_entry = table_ptr -> table(i);

      if length (table_entry) >= str_len then
         if substr (table_entry, 1, str_len) = str then
            if entry_found ^= 0 then
               return (ambiguous_cmd);   /* More than one match found! */
            else
               entry_found = i;
   end;

   return (entry_found);

   end;          /* Type */

/* ******************************* Tokenize ******************************** */

Tokenize : proc (buff);

Dcl buff char (160) var;

/* ************************************************************************* */

   /* A command line is passed back split up into tokens. The code
      only expects and handles 3 options, any others are ignored. */

   do num_tok = 1 to num_tokens;
      token(num_tok) = '';
   end;

   buff = translate (buff, uppercase || ' ', lowercase || ',');

   buff = trim (buff, '11'b);

   do num_tok = 1 to num_tokens while (buff ^= '');
      token(num_tok) = before (buff, ' ');
      buff = trim (after (buff, ' '), '11'b);
   end;

   num_tok = num_tok - 1;

   return;

   end;           /* Tokenize */

/* ****************************** Comi_hndlr ******************************* */

Comi_hndlr : proc (point);

Dcl point ptr;

/* ************************************************************************* */

   /* This on-unit for the condition COMI_EOF$ makes life easier by treating
      the condition just as if the user had issued a POP command. We must
      remember that we were here though, so that the prompts come out okay.
   */

   from_comi_hndlr = true;

   go to comi_point;

   end;        /* Comi_hndlr */

/* ******************************* Get_unit ******************************** */

Get_unit : proc (code) returns (fixed bin);

Dcl code fixed bin;

Dcl (unit, rnw) fixed bin,
    pos fixed bin (31);

/* ************************************************************************* */

   code = 0;
   unit = 0;

   /* We start the file unit numbers at 7 to allow the lower ones to be used
      by other programs and, if the user PUSHes, commands like LISTING and
      BINARY (which use units 2 and 3) may also be used. The upper limit can,
      at the moment, only be guessed at. To allow a "decent" number of TAKE's
      to be nested we have used the figure of 127. This may need to be
      changed by other sites.
   */

   do unit = 7 to 127 until (code = e$unop);
      call prwf$$ (k$rpos, unit, null (), 0, pos, rnw, code);
   end;

   if code = 0 | code = e$dire | code = e$bunt then
      code = e$fuiu;

   if code = e$unop then
      code = 0;
   else
      unit = 0;

   return (unit);

   end;        /* Get_unit */

   end;      /* Comnd */
-------------------------------------------------------------------------------

/* CONVERT_FILE -- Convert uploaded file to Primos text file. */

Convert_file : proc returns (fixed bin);

$Insert *>insert>common.ins.plp
$Insert *>insert>kermit.ins.plp
$Insert *>insert>primos.ins.plp
$Insert *>insert>constants.ins.plp
$Insert syscom>keys.ins.pl1
$Insert syscom>errd.ins.pl1

Dcl temp_pathname char (128) var,
    buffer char (ibuffer_size) var,
    (temp_filename, basename) char (32) var,
    (code, type, nw, i, unit2, rnw, sufusd) fixed bin,
    fn char (13),
    unique_bits char (6) aligned,
    char_ptr ptr,
    character char (1);

Dcl 1 bit_char based,
      2 high_bit bit (1),
      2 next_bits bit (7);

/********************************************************************/

   buffer = '';
   snd_msg = '';
   char_ptr = addr (character);

   call srsfx$ (k$read + k$getu, path_name, file_unit, type, 0, '', basename, sufusd, code);
   if type > 1 & type ^= 7 then
      do;
         call clo$fu (file_unit, code);
         code = e$wft;
      end;

   file_opened = (code = 0);

   if code ^= 0 then
      do;
         snd_msg = 'Error opening file to convert on remote system. ';
         return (code);
      end;

   call uid$bt (unique_bits);
   call uid$ch (unique_bits, fn);
   temp_filename = fn || '.KERMIT.CONV';

   if ^non_null_dir then
      temp_pathname = temp_filename;
   else
      temp_pathname = dir_name || '>' || temp_filename;

   i = k$writ + k$getu;
   if type = 1 then
      i = i + k$ndam;
   else
      if type = 7 then
         i = i + k$ncam;

   call srsfx$ (i, temp_pathname, unit2, type, 0, '', basename, sufusd, code);
   if code ^= 0 then
      do;
         file_opened = false;
         call clo$fu (file_unit, rnw);
         snd_msg = 'Error opening temporary file on remote system.';
         return (code);
      end;

   do until (code ^= 0);

      call prwf$$ (k$read, file_unit, ibuffer_ptr, ibuffer_size_wds, 0, rnw, code);
      if code = e$eof & rnw ^= 0 then
         code = 0;

      if code = 0 then
         do;
            ibuflen = 2 * rnw;

            call convert_to_ascii;
            if code ^= 0 then
               snd_msg = 'Error converting the file on the remote system.';
         end;
      else
         if code ^= e$eof then
            snd_msg = 'Error reading from the file on the remote system.';
   end;

   file_opened = false;

   call clo$fu (file_unit, rnw);

   call clo$fu (unit2, rnw);

   if code = e$eof then
      do;
         code = 0;
         snd_msg = '';
      end;

   if code ^= 0 then
      do;
         call fil$dl (temp_pathname, rnw);
         snd_msg = 'Error in processing file conversion on the remote system.';
         return (code);
      end;
   else
      do;
         code = rnw;
         if code ^= 0 then
            do;
               snd_msg = 'Unable to close the output file on the remote system.';
               return (code);
            end;
      end;

   if non_null_dir then
      do;
         call at$ (k$setc, dir_name, code);
         if code ^= 0 then
            do;
               call fil$dl (temp_pathname, rnw);
               snd_msg = 'Error attaching to upload directory on remote system.';
               return (code);
            end;
      end;

   call fil$dl (file_name, code);
   if code ^= 0 then
      do;
         if non_null_dir then
            call at$hom (rnw);
         snd_msg = 'Unable to delete the original file on the remote system.';
         return (code);
      end;

   rnw = 0;
   if length (temp_filename) = length (file_name) then
      sufusd = 1;
   else
      sufusd = 0;

   call cnam$$ ((temp_filename), length (temp_filename), (file_name), length (file_name), code, sufusd);
   if code ^= 0 then
      snd_msg = 'Error trying to rename the temporary file on remote system.';

   if non_null_dir then
      call at$hom (rnw);

   if code = 0 then
      code = rnw;

   return (code);

/* **************************** Convert_to_ascii *************************** */

Convert_to_ascii : proc;

/* ************************************************************************* */

   code = 0;

   do i = 1 to ibuflen;

      character = substr (ibuffer, i, 1);
      char_ptr -> bit_char.high_bit = '1'b;

      select (character);

         when (cr_8bit_asc)
            eol_flag = 1;

         when (lf_8bit_asc)
            eol_flag = eol_flag + 1;

         otherwise
            eol_flag = 0;
      end;

      if eol_flag > 1 then
         do;
            sufusd = length (buffer);
            substr (buffer, sufusd, 1) = ' ';
            call wtlin$ (unit2, (buffer), divide (sufusd, 2, 15), code);
            if code ^= 0 then
               return;
            buffer = '';
         end;
      else
         buffer = buffer || character;
   end;

   return;

   end;       /* Convert_to_ascii */

   end;      /* Convert_file */
-------------------------------------------------------------------------------

/* DISCARD_OUTPUT -- Discard an output file. */

Discard_output : proc (code);

Dcl code fixed bin;

$Insert *>insert>common.ins.plp
$Insert *>insert>kermit.ins.plp
$Insert *>insert>primos.ins.plp
$Insert *>insert>constants.ins.plp
$Insert syscom>errd.ins.pl1

/* ************************************************************************* */

   code = 0;

   rec_file_type = automatic_ft;
   if ^explicit_ft_set then
      file_type = automatic_ft;

   if file_opened then
      do;
         call clo$fu (file_unit, code);
         if code = e$unop then
            code = 0;

         if code = 0 & del_incomplete then
            call fil$dl (path_name, code);

         if code = e$fntf then        /* Possible if the unit wasn't open. */
            code = 0;

         file_opened = false;
      end;

   return;

   end;      /* Discard_output */
-------------------------------------------------------------------------------

/* GENERIC_CMD -- Generic server command process. */

Generic_cmd : proc returns (fixed bin);

$Insert *>insert>common.ins.plp
$Insert *>insert>kermit.ins.plp
$Insert *>insert>primos.ins.plp
$Insert *>insert>constants.ins.plp
$Insert syscom>keys.ins.pl1
$Insert syscom>errd.ins.pl1

%Replace maxargs by 3,
         maxalen by 96;

Dcl (args, nargs) char (maxalen) var,
    arg (maxargs) char (maxalen) var;

Dcl (treename, line) char (128) var,
    basename char (32) var,
    fn char (13),
    unique_bits char (6) aligned,
    (print_header, continue) bit (1) aligned,
    (code, rnw, funit, type, dir_type, dir_unit, code2, sufusd, key) fixed bin,
    (to_user_num, to_name_len) fixed bin,
    errvec (4) fixed bin,
    to_name char (32),
    1 quota_info,
      2 (record_size, dir_used, max_quota, quota_used) fixed bin (31),
      2 (duff1, duff2, duff3, duff4) fixed bin (31),
    inf_array (8) fixed bin (31) based;

/* ************************************************************************* */

   call parse_cmd;           /* Parse any arguments sent. */

   select (set8 (substr (rec_msg, pkt_msg, 1))); /* Process the message type. */

      when (msg_gen_cwd)          /* CWD - Change Working Directory. */
         do;
            treename = arg(1);

            if arg(2) ^= '' then       /* Do we have a password ? */
               treename = treename || ' ' || arg(2);

            call change_dir (treename, code);

            if code = 0 then
               call send_packet (msg_ack, length (snd_msg), rec_seq);
            else
               do;
                  call get_error_msg (code);
                  snd_msg = 'Error trying to change directory. ' || errmsg;
                  call send_packet (msg_error, length (snd_msg), msg_number);
               end;
         end;

      when (msg_gen_finish)          /* FINISH command. */
         do;
            call send_packet (msg_ack, 0, rec_seq);
            return (ker_exit);
         end;

      when (msg_gen_logout)           /* LOGOUT command. */
         do;
            call send_packet (msg_ack, 0, rec_seq);
            call logo$$ (0, 0, '', 0, 0, code);
         end;

      when (msg_gen_delete)           /* DELETE command. */
         do;
            treename = arg(1);
            call fil$dl (treename, code);
            if code = 0 then
               do;
                  snd_msg = 'File deleted.';
                  call send_packet (msg_ack, length (snd_msg), rec_seq);
               end;
            else
               do;
                  call get_error_msg (code);
                  snd_msg = 'Unable to delete the file. ' || errmsg;
                  call send_packet (msg_error, length (snd_msg), msg_number);
               end;
         end;

      when (msg_gen_directory)        /* DIRECTORY command. */
         do;
            call uid$bt (unique_bits);
            call uid$ch (unique_bits, fn);

            treename = arg(1);

            if treename = '' then
               treename = fn || '.KERMIT.DIR';
            else
               treename = treename || '>' || fn || '.KERMIT.DIR';

            call set_path (treename);

            call srch$$ (k$rdwr + k$getu, (file_name), length (file_name), file_unit, type, code);
            if code ^= 0 then
               do;
                  call get_error_msg (code);
                  snd_msg = 'Error opening a temporary file. ' || errmsg;
                  call send_packet (msg_error, length (snd_msg), msg_number);

                  return (ker_normal);
               end;

            file_opened = true;

            call srsfx$ (k$read + k$getu, dir_name, dir_unit, dir_type, 0, '', basename, sufusd, code);
            if code ^= 0 then
               do;
                  call get_error_msg (code);
                  snd_msg = 'Error opening the directory. ' || errmsg;
                  call send_packet (msg_error, length (snd_msg), msg_number);

                  file_opened = false;
                  call clo$fu (file_unit, code);
                  call fil$dl (file_name, code);

                  return (ker_normal);
               end;

            continue = false;
            print_header = true;
            call dir$rd (k$init, dir_unit, dir_entry_ptr, dir_entry_size, code);

            do until (code ^= 0);
               call dir$rd (k$read, dir_unit, dir_entry_ptr, dir_entry_size, code);
               if code = 0 then
                  if trim (dir_entry.entryname, '01'b) ^= file_name then
                     do;
                        if print_header then
                           do;
                              print_header = false;
                              call wtlin$ (file_unit, '*** Start of Directory Listing. *** ', 18, code);
                           end;

                        if ^continue then
                           line = dir_entry.entryname;
                        else
                           do;
                              line = line || '    ' || dir_entry.entryname || '  ';
                              call wtlin$ (file_unit, (line), divide (length (line), 2, 15), code);
                           end;

                        if code = 0 then
                           continue = ^continue;

                     end;
            end;

            call clo$fu (dir_unit, code2);

            if code = e$eof then
               do;
                  code = 0;
                  if continue then
                     do;
                        line = line || '  ';
                        call wtlin$ (file_unit, (line), divide (length (line), 2, 15), code);
                     end;
                  else      /* We will be here if we had an empty directory. */
                     if print_header then
                        call wtlin$ (file_unit, '*** There are NO file system objects in this directory. *** ', 30, code);
               end;

            if code ^= 0 then
               do;
                  call get_error_msg (code);
                  snd_msg = 'Error listing the directory. ' || errmsg;
                  call send_packet (msg_error, length (snd_msg), msg_number);

                  file_opened = false;
                  call clo$fu (file_unit, code);
                  call fil$dl (file_name, code);

                  return (ker_normal);
               end;

            if ^print_header then
               call wtlin$ (file_unit, '*** End of Directory Listing. *** ', 17, code);

            call xsend_file;

            file_opened = false;

            call clo$fu (file_unit, code);
            call fil$dl (file_name, code);

         end;

      when (msg_gen_type)             /* TYPE command. */
         do;
            treename = arg(1);
            call set_path (treename);

            code = open_input ();
            if code = 0 then
               do;
                  state = state_x;
                  call send_switch;
               end;
            else
               do;
                  call get_error_msg (code);
                  snd_msg = 'Error accessing the file. ' || errmsg;
                  call send_packet (msg_error, length (snd_msg), msg_number);
               end;
         end;

      when (msg_gen_disk_usage)              /* Disk Usage. */
         do;
            treename = arg(1); /* Anything sent will actually be a directory. */
            if treename ^= '' then
               treename = treename || '>DUMMY_FILE_NAME';

            call set_path (treename);

            call q$read (dir_name, addr (quota_info) -> inf_array, 4, type, code);
            if code ^= 0 then
               do;
                  call get_error_msg (code);
                  snd_msg = 'Error reading the disk quota. ' || errmsg;
                  call send_packet (msg_error, length (snd_msg), msg_number);
               end;
            else
               do;
                  basename = trim (char (quota_info.quota_used), '10'b);

                  if type = 1 then
                     snd_msg = 'Not a quota directory. (' || basename || ' records used).';
                  else
                     snd_msg = basename || ' records used out of quota of ' ||
                               trim (char (quota_info.max_quota), '10'b) || '.';

                  call send_packet (msg_ack, length (snd_msg), rec_seq);
               end;

         end;

      when (msg_gen_rename)               /* RENAME command. */
         do;
            code = 0;

            treename = arg(1);
            call set_path (treename);

            if non_null_dir then
               call at$ (k$setc, dir_name, code);

            if code = 0 then
               do;
                  rnw = length (file_name);
                  type = length (arg(2));

                  if rnw = type then
                     sufusd = 1;
                  else
                     sufusd = 0;

                  call cnam$$ ((file_name), rnw, (arg(2)), type, code, sufusd);

                  if non_null_dir then
                     call at$hom (code2);
               end;

            if code ^= 0 then
               do;
                  call get_error_msg (code);
                  snd_msg = 'Error trying to change the file name. ' || errmsg;
                  call send_packet (msg_error, length (snd_msg), msg_number);
               end;
            else
               do;
                  snd_msg = 'File renamed.';
                  call send_packet (msg_ack, length (snd_msg), rec_seq);
               end;

         end;

      when (msg_gen_copy)             /* COPY command. */
         do;
            treename = arg(1);
            line = arg(2);

            call srsfx$ (k$read + k$getu, treename, file_unit, type, 0, '', basename, sufusd, code);
            if type > 1 & type ^= 7 then
               do;
                  call clo$fu (file_unit, code);
                  code = e$wft;
               end;

            if code ^= 0 then
               do;
                  call get_error_msg (code);
                  snd_msg = 'Unable to open the file to copy from. ' || errmsg;
                  call send_packet (msg_error, length (snd_msg), msg_number);
                  return (ker_normal);
               end;

            key = k$writ + k$getu;
            if type = 1 then
               key = key + k$ndam;
            else
               if type = 7 then
                  key = key + k$ncam;

            call srsfx$ (key, line, funit, type, 0, '', basename, sufusd, code);
            if code ^= 0 then
               do;
                  call get_error_msg (code);
                  snd_msg = 'Unable to open the file to copy to. ' || errmsg;
                  call send_packet (msg_error, length (snd_msg), msg_number);
                  return (ker_normal);
               end;

            do until (code ^= 0);
               call rdlin$ (file_unit, ibuffer, ibuffer_size_wds, code);
               if code = 0 then
                  call wtlin$ (funit, ibuffer, ibuffer_size_wds, code);
            end;

            call clo$fu (file_unit, code2);
            call clo$fu (funit, code2);

            if code = e$eof then
               code = 0;

            if code ^= 0 then
               do;
                  call fil$dl (line, code2);
                  call get_error_msg (code);
                  snd_msg = 'Error copying the file. ' || errmsg;
                  call send_packet (msg_error, length (snd_msg), msg_number);
               end;
            else
               do;
                  snd_msg = 'File copied.';
                  call send_packet (msg_ack, length (snd_msg), rec_seq);
               end;

         end;

      when (msg_gen_send)             /* SEND command. */
         do;
            line = after (arg(1), ' ');
            arg(1) = translate (trim (before (arg(1), ' '), '11'b), uppercase, lowercase);
            if substr (arg(1), 1, 1) = '-' then
               arg(1) = substr (arg(1), 2);

            if verify (arg(1), '+-0123456789') = 0 then    /* User number given. */
               do;
                  to_name = '';
                  to_name_len = 0;
                  to_user_num = bin (arg(1), 15);
                  if to_user_num <= 0 then
                     do;
                        snd_msg = 'Invalid user-number given.';
                        call send_packet (msg_error, length (snd_msg), msg_number);
                        return (ker_normal);
                     end;
               end;
            else
               do;
                  to_name = arg(1);
                  to_name_len = length (to_name);
                  to_user_num = 0;
               end;

            if length (line) > 80 then
               line = substr (line, 1, 80);
            rnw = length (line);

            errvec(2) = 1;
            call mgset$ (k$acpt, code);

            call smsg$ (1, to_name, to_name_len, to_user_num, '', 0, (line), rnw, errvec);

            call mgset$ (my_msg_state, code);
            if errvec(1) = 0 then
               do;
                  snd_msg = 'Message sent.';
                  call send_packet (msg_ack, length (snd_msg), rec_seq);
               end;
            else
               do;
                  call get_error_msg (errvec(1));
                  snd_msg = 'Unable to send the message. ' || errmsg;
                  call send_packet (msg_error, length (snd_msg), msg_number);
               end;

         end;

      when (msg_gen_who)              /* WHO command. */
         do;
            if substr (arg(1), 1, 1) = '-' then
               arg(1) = substr (arg(1), 2);

            if arg(1) = '' then
               do;
                  snd_msg = 'No user-id given.';
                  call send_packet (msg_error, length (snd_msg), msg_number);
                  return (ker_normal);
               end;

            if verify (arg(1), '+-0123456789') = 0 then  /* User number given. */
               do;
                  key = k$read;
                  to_name = '';
                  to_name_len = 32;
                  to_user_num = bin (arg(1), 15);
                  if to_user_num <= 0 then
                     do;
                        snd_msg = 'Invalid user-number given.';
                        call send_packet (msg_error, length (snd_msg), msg_number);
                        return (ker_normal);
                     end;
               end;
            else
               do;
                  key = 2;
                  to_name = arg(1);
                  to_name_len = length (to_name);
                  to_user_num = 0;
               end;

            call msg$st (key, to_user_num, '', 0, to_name, to_name_len, code);
            if code = k$none then
               do;
                  snd_msg = 'User ' || arg(1) || ' is not logged in.';
                  call send_packet (msg_error, length (snd_msg), msg_number);
               end;
            else
               do;
                  snd_msg = 'User ' || trim (to_name, '11'b) ||
                            ' is currently logged in as process number ' ||
                            trim (char (to_user_num), '11'b) || '.';
                  call send_packet (msg_ack, length (snd_msg), rec_seq);
               end;

         end;

      otherwise                       /* Unknown command. */
         do;
            snd_msg = 'Unimplemented command.';
            call send_packet (msg_error, length (snd_msg), msg_number);
            return (ker_unimplgen);
         end;

   end;     /* select */

   return (ker_normal);

/* ******************************* Parse_cmd ******************************* */

Parse_cmd : proc;

Dcl (arg_num, arg_len, i, temp, rep_count) fixed bin,
    do_trans bit (1) aligned,
    (chr, rem_quo) char (1);

/* ************************************************************************* */

   do_repeats = (loc_rep_chr = rem_rep_chr) & (loc_rep_chr ^= ' ');

   do i = 1 to maxargs;
      arg(i) = '';
   end;

   if length (rec_msg) <= pkt_tot_ovr_head then
      return;

   args = set8str (substr (rec_msg, pkt_tot_ovr_head, length (rec_msg) - pkt_tot_ovr_head));

   nargs = '';
   rem_quo = set8 (rem_quote_chr);   /* For local processing only. */

   i = 0;          /* Convert any quoted and repeated characters. */
   do while (i < length (args));
      i = i + 1;
      chr = substr (args, i, 1);
      rep_count = 1;

      if do_repeats then
         if chr = loc_rep_chr then
            do;
               i = i + 1;
               rep_count = knum (substr (args, i, 1));

               i = i + 1;
               chr = substr (args, i, 1);
            end;

      if chr = rem_quo then
         do;
            i = i + 1;
            chr = substr (args, i, 1);
            if chr >= query_8bit_asc & chr < grave_8bit_asc then
               chr = ctl (chr);
         end;

      do temp = 1 to rep_count;
         nargs = nargs || chr;
      end;

   end;

   i = 0;
   arg_num = 0;
   do_trans = (set8 (substr (rec_msg, pkt_msg, 1)) ^= msg_gen_send);

   do while (i < length (nargs));         /* Now fill in the argument list. */
      i = i + 1;
      arg_len = knum (substr (nargs, i, 1));
      arg_num = arg_num + 1;
      arg(arg_num) = substr (nargs, i + 1, arg_len);
      if do_trans then           /* Don't do this for the SEND command. */
         arg(arg_num) = translate (trim (arg(arg_num), '11'b), uppercase, lowercase);
      i = i + arg_len;
   end;

   return;

   end;       /* Parse_cmd */

/* ******************************* Xsend_file ****************************** */

Xsend_file : proc;

/* ************************************************************************* */

   call prwf$$ (k$posn + k$prea, file_unit, null (), 0, 0, rnw, code); /* Rewind the file. */
   if code ^= 0 then
      do;
         call get_error_msg (code);
         snd_msg = 'Unable to position to the beginning of the file. ' || errmsg;
         call send_packet (msg_error, length (snd_msg), msg_number);
      end;
   else
      do;
         file_pos = 0;
         ibuflen = 0;
         ibuf_ptr = 1;
         key = file_type;     /* Keep this for later. */
         file_type = ascii_ft;
         if ^explicit_pound_set then
            pound_conversion = true;
         ibuffer = '';

         state = state_x;     /* Send the file as text to be typed to the user. */
         call send_switch;

         file_type = key;     /* Reset the file type. */
      end;

   return;

   end;       /* Xsend_file */

   end;    /* Generic_cmd */
-------------------------------------------------------------------------------

/* GET_ATTR -- Get file attributes and put them in SND_MSG. */

Get_attr : proc;

$Insert *>insert>kermit.ins.plp
$Insert *>insert>common.ins.plp
$Insert *>insert>constants.ins.plp

%Replace primos by 'G';

Dcl 1 a_sub_pkt,
      2  type char (1),
      2  pkt_len char (1),
      2  data char (32) var;

Dcl sub_pkt_ptr ptr;

/* ************************************************************************* */

   sub_pkt_ptr = addr (a_sub_pkt);

   a_sub_pkt.type = '.';              /* Set up machine/OS sub-packet. */
   char2_ptr -> fb15_based = 33;              /* i.e. 1 + 32 */
   a_sub_pkt.pkt_len = char2(2);
   a_sub_pkt.data = primos;
   snd_msg = sub_pkt_ptr -> char2_based || a_sub_pkt.data;

   a_sub_pkt.type = '!';              /* Set up kbyte length sub-packet. */
   a_sub_pkt.data = trim (char (divide (file_len + 1023, 1024, 31)), '11'b);
   char2_ptr -> fb15_based = length (a_sub_pkt.data) + 32;
   a_sub_pkt.pkt_len = char2(2);
   snd_msg = snd_msg || sub_pkt_ptr -> char2_based || a_sub_pkt.data;

   a_sub_pkt.data = get_dtc ();       /* Set up DTC sub-packet. */
   if a_sub_pkt.data ^= '' then
      do;
         a_sub_pkt.type = '#';
         char2_ptr -> fb15_based = length (a_sub_pkt.data) + 32;
         a_sub_pkt.pkt_len = char2(2);
         snd_msg = snd_msg || sub_pkt_ptr -> char2_based || a_sub_pkt.data;
      end;

   a_sub_pkt.type = '1';        /* Set up the byte file length sub-packet. */
   a_sub_pkt.data = trim (char (file_len), '11'b);
   char2_ptr -> fb15_based = length (a_sub_pkt.data) + 32;
   a_sub_pkt.pkt_len = char2(2);
   snd_msg = snd_msg || sub_pkt_ptr -> char2_based || a_sub_pkt.data;

   if file_type = ascii_ft | file_type = binary_ft then
      do;
         a_sub_pkt.type = '"';

         if file_type = ascii_ft then
            a_sub_pkt.data = 'A';
         else
            a_sub_pkt.data = 'B';

         char2_ptr -> fb15_based = 33;
         a_sub_pkt.pkt_len = char2(2);

         snd_msg = snd_msg || sub_pkt_ptr -> char2_based || a_sub_pkt.data;
      end;

   return;

   end;       /* Get_attr */
-------------------------------------------------------------------------------

/* GET_DTC -- Get the DTC of the file given by "path_name". */

Get_dtc : proc returns (char (32) var);

$Insert *>insert>common.ins.plp
$Insert *>insert>kermit.ins.plp
$Insert *>insert>primos.ins.plp
$Insert syscom>keys.ins.pl1

Dcl (type, code, dow, funit, sufusd) fixed bin,
    formatted_date char (21),
    (buffer, basename) char (32) var;

/* ************************************************************************* */

   buffer = '';

   call srsfx$ (k$read + k$getu, dir_name, funit, type, 0, '', basename, sufusd, code);
   if code ^= 0 then
      do;
         call get_error_msg (code);
         call ioa$ ('Unable to open the directory %v. %v%.', 99, dir_name, errmsg);
         return (buffer);
      end;

   call ent$rd (funit, file_name, dir_entry_ptr, dir_entry_size, code);
   call clo$fu (funit, sufusd);        /* We don't need this anymore. */
   if code ^= 0 then
      do;
         call get_error_msg (code);
         call ioa$ ('Unable to read the directory entry for file %v. %v%.', 99, file_name, errmsg);
         return (buffer);
      end;

   call cv$fda (dir_entry.dtc, dow, formatted_date);
   if dow >= 0 then
      buffer = '19' || substr (formatted_date, 1, 2) || substr (formatted_date, 4, 2) ||
               substr (formatted_date, 7, 2) || ' ' || substr (formatted_date, 10, 8);

   return (buffer);

   end;      /* Get_dtc */
-------------------------------------------------------------------------------

/* GET_ERROR_MSG -- Get the PRIMOS error message from the given code. */

Get_error_msg : proc (code);

Dcl code fixed bin;

$Insert *>insert>common.ins.plp
$Insert *>insert>primos.ins.plp

/* ************************************************************************* */

   call ertxt$ (code, errmsg);

   if errmsg = '' then
      errmsg = '(Code = ' || trim (char (code), '11'b) || ')';

   return;

   end;       /* Get_error_msg */
-------------------------------------------------------------------------------

/* GET_LEN -- Determine logical length of file in bytes. */

Get_len : proc returns (fixed bin);

$Insert *>insert>common.ins.plp
$Insert *>insert>primos.ins.plp
$Insert *>insert>constants.ins.plp
$Insert syscom>keys.ins.pl1
$Insert syscom>errd.ins.pl1

Dcl (unit2, sufusd, type ,code, rnw) fixed bin,
    basename char (32) var;

/* ************************************************************************* */

   file_len = 0;
   file_pos = 0;

   /* The following call will work, but for large SAM files
      it may hold the file system lock for a time. */

   call prwf$$ (k$posn + k$prea, file_unit, null (), 0, bignum, rnw, code);
   if code = 0 then
      code = e$fitb;            /* The file is too big! */

   if code = e$eof then         /* Determine the EOF position. */
      call prwf$$ (k$rpos, file_unit, null (), 0, file_len, rnw, code);

   if code = e$eof then
      do;
         code = 0;              /* This will allow for empty files. */
         file_len = 0;

         return (code);
      end;

   if code ^= 0 then
      return (code);

   file_len = 2 * file_len;
   file_pos = file_len;

   /* PRIMOS keeps the file length in 2 byte words. The Kermit upload
      process will change the files read/write lock if the last byte is
      not significant. So we must now check the files read/write lock. */

   call srsfx$ (k$read + k$getu, dir_name, unit2, type, 0, '', basename, sufusd, code);
   if code ^= 0 then
      return (code);

   call ent$rd (unit2, file_name, dir_entry_ptr, dir_entry_size, code);
   call clo$fu (unit2, sufusd);        /* We don't need this anymore. */
   if code ^= 0 then
      return (code);

   if dir_entry.file_info.rwlock = k$none then
      file_len = file_len - 1;

   call prwf$$ (k$posn + k$prea, file_unit, null (), 0, 0, rnw, code); /* Rewind the file. */
   if code = 0 then
      file_pos = 0;

   return (code);

   end;       /* Get_len */
-------------------------------------------------------------------------------

/* KERMIT -- Main Kermit subroutine. */

Kermit : proc (cmd_line, code, com_name);

Dcl cmd_line char (256) var,
    com_name char (32) var,
    code fixed bin;

$Insert *>insert>common.ins.plp
$Insert *>insert>kermit.ins.plp
$Insert *>insert>primos.ins.plp
$Insert *>insert>constants.ins.plp
$Insert syscom>keys.ins.pl1
$Insert syscom>errd.ins.pl1

%Replace cl_width by 64;

Dcl cl_pic (11) char (cl_width) var static init (
    '-r, -rec, -receive tree;',
    '-s, -send tree;',
    '-a, -as, -alt, -alternate entry;',
    '-l, -log tree;',
    '-ft, -file, -file_type, -st, -store, -storage_type char;',
    '-p, -par, -parity char;',
    '-h, -help;',
    '-u, -usage;',
    '-ser, -server;',
    '-pou, -pound char;',
    'end' );

Dcl 1 cl_struc external,
      2 rec_flag bit (1) aligned,
      2 rec_path char (128) var,
      2 send_flag bit (1) aligned,
      2 send_path char (128) var,
      2 alt_flag bit (1) aligned,
      2 alt_name char (32) var,
      2 log_flag bit (1) aligned,
      2 log_path char (128) var,
      2 storage_flag bit (1) aligned,
      2 storage_type char (80) var,
      2 parity_flag bit (1) aligned,
      2 parity_type char (80) var,
      2 help_flag bit (1) aligned,
      2 usage_flag bit (1) aligned,
      2 ser_flag bit (1) aligned,
      2 pound_flag bit (1) aligned,
      2 pound_option char (80) var;

Dcl quit char (5) var,
    alarm char (6) var,
    (pix_index, bad_index) fixed bin;

/* ************************************************************************* */

   code = 0;

   call kermit_init;

   brk_lbl = done;
   quit = 'QUIT$';
   call mkonu$ (quit, bk_hndlr);          /* On-unit for quits. */

   alarm = 'ALARM$';
   call mkonu$ (alarm, timeout_hndlr);    /* On-unit for timeouts. */

   call cl$pix ('0002'b4, com_name, addr (cl_pic), cl_width, cmd_line,
                addr (cl_struc), pix_index, bad_index, code);
   if code ^= 0 then
      return;

   if cl_struc.help_flag then
      do;
         call print_cl_help;
         return;
      end;

   if cl_struc.usage_flag then
      do;
         call print_cl_usage;
         return;
      end;

   if (cl_struc.rec_flag & (cl_struc.send_flag | cl_struc.ser_flag)) |
      (cl_struc.send_flag & cl_struc.ser_flag) then
      do;
         code = e$null;
         call tnou ('Incompatible options; only ONE of SEND, RECEIVE, or SERVER may be given.', 72);
         return;
      end;

   explicit_pound_set = cl_struc.pound_flag;

   if cl_struc.pound_flag then
      select (cl_struc.pound_option);

         when ('OFF', 'N', 'NO')
            pound_conversion = false;

         when ('', 'ON', 'Y', 'YES')
            do;
               pound_conversion = true;
               if cl_struc.pound_option = '' then
                  call tnou ('No POUND option given, defaulting to ON for pound sign conversion.', 66);
            end;

         otherwise
            do;
               pound_conversion = true;
               call ioa$ ('Unknown POUND option "%v", defaulting to ON for pound sign conversion.%.',
                          99, cl_struc.pound_option);
            end;

      end;

   explicit_ft_set = cl_struc.storage_flag;

   if cl_struc.storage_flag then
      select (cl_struc.storage_type);

         when ('AS', 'ASC', 'ASCII', 'T', 'TEXT')
            file_type = ascii_ft;

         when ('B', 'BIN', 'BINARY', 'I', 'IMAGE')
            do;
               file_type = binary_ft;
               if ^explicit_pound_set then   /* We DON'T want this for binaries. */
                  pound_conversion = false;
            end;

         when ('', 'AU', 'AUTO', 'AUTOMATIC')
            do;
               file_type = automatic_ft;
               explicit_ft_set = false;      /* Assume we haven't set it. */
               if cl_struc.storage_type = '' then
                  call tnou ('No FILE TYPE specified, defaulting to AUTOMATIC.', 51);
            end;

         otherwise
            do;
               file_type = automatic_ft;
               explicit_ft_set = false;
               call ioa$ ('Unknown FILE TYPE "%v", defaulting to AUTOMATIC.%.', 99, cl_struc.storage_type);
            end;

      end;

   if cl_struc.parity_flag then
      select (cl_struc.parity_type);

         when ('', 'M', 'MARK')
            do;           /* No need to check the 8-bit quoting since it hasn't changed yet. */
               do_transparent = false;
               do_8bit_chks = false;

               if cl_struc.parity_type = '' then
                  call tnou ('No PARITY type specified, defaulting to MARK.', 45);
            end;

         when ('N', 'NONE')
            do;
               do_transparent = true;
               do_8bit_chks = true;
               loc_8quote_chr = 'Y';
            end;

         otherwise
            do;
               do_transparent = false;
               do_8bit_chks = false;
               call ioa$ ('Unknown PARITY type "%v", defaulting to MARK.%.', 99, cl_struc.parity_type);
            end;

      end;

   if cl_struc.alt_flag then
      if cl_struc.alt_name = '' then
         call tnou ('No ALTERNATE file name specified, none being used.', 50);
      else
         if fnchk$ (k$uprc, cl_struc.alt_name) then
            alternate_fname = cl_struc.alt_name;
         else
            do;
               code = e$bnam;
               call ioa$ ('Invalid ALTERNATE file name "%v".%.', 99, cl_struc.alt_name);
               return;
            end;

   if cl_struc.log_flag then  /* No log file opened yet, so no need to check. */

      call start_log_file;

   if cl_struc.rec_flag then
      call rec_setup;
   else
      if cl_struc.send_flag then
         if cl_struc.send_path = '' then
            do;
               call tnou ('No SEND pathname given; Interactive mode will be used.', 54);
               call comnd;
            end;
         else
            if tnchk$ (k$uprc + k$wldc, cl_struc.send_path) then
               call send_setup;
            else
               do;
                  code = e$itre;
                  call ioa$ ('Invalid SEND pathname(s) "%v".%.', 99, cl_struc.send_path);
               end;
      else
         if cl_struc.ser_flag then
            call server_setup;
         else
            call comnd;

Done :      /* Return point for the QUIT$ on-unit. */
            /* Since we are returning to PRIMOS we will close these files. */

   if take_level > 0 then
      do;
         call comi$$ ('TTY', 3, take_unit(take_level), bad_index);

         take_level = take_level - 1;
         do pix_index = 1 to take_level;
            call clo$fu (take_unit(pix_index), bad_index);
         end;
      end;

   if file_opened then
      call clo$fu (file_unit, bad_index);

   if log_opened then
      call clo$fu (log_unit, bad_index);

   return;

/* ******************************* Rec_setup ******************************* */

/* REC_SETUP -- Setup to receive a file. */

Rec_setup : proc;

/* ************************************************************************* */

   call xfer_mode (1, code);            /* Switch to transfer mode. */
   if code ^= 0 then
      return;

   state = state_r;
   call set_path (cl_struc.rec_path);
   call tnou ('Kermit receive started.', 23);

   call rec_switch ();         /* Start receiving now. */

   call xfer_mode (0, code);

   return;

   end;      /* Rec_setup */

/* ****************************** Send_setup ******************************* */

/* SEND_SETUP -- Setup to send a group of files. */

Send_setup : proc;

/* ************************************************************************* */

   call xfer_mode (1, code);           /* Switch to transfer mode. */
   if code ^= 0 then
      return;

   state = state_s;
   call set_path (cl_struc.send_path);
   call tnou ('Kermit send started.', 20);

   call send_switch ();                /* Start sending now. */

   call xfer_mode (0, code);

   return;

   end;        /* Send_setup */

/* ***************************** Server_setup ****************************** */

/* SERVER_SETUP -- Setup to start server. */

Server_setup : proc;

/* ************************************************************************* */

   call xfer_mode (1, code);          /* Switch to transfer mode. */
   if code ^= 0 then
      return;

   call tnou ('Kermit server started.', 22);

   call server;

   call xfer_mode (0, code);

   return;

   end;      /* Server_setup */

/* ***************************** Print_cl_usage **************************** */

Print_cl_usage : proc;

/* ************************************************************************* */

   bad_index = length (com_name) + 10;

   call ioa$ ('%/ Usage : %v [{-Receive [pathname] | -Send wildcard | -SERver}]%.', 99, com_name);
   call ioa$ ('%#x[-Alternate filename] [-Log [pathname]] [-Parity {MARK | NONE}]%.', 99, bad_index);
   call ioa$ ('%#x[-File_Type {AUTOMATIC | TEXT | BINARY}]%.', 99, bad_index);
   call ioa$ ('%#x[-POUnd {ON | OFF}] [-Help] [-Usage]%/%.', 99, bad_index);

   return;

   end;       /* Print_cl_usage */

/* ***************************** Print_cl_help ***************************** */

Print_cl_help : proc;

Dcl ans char (16) var;

/* ************************************************************************* */

   call print_cl_usage;

   call ioa$ (' The first three options are mutually exclusive, but if none are specified%.', 99);
   call ioa$ (' then the user enters an interactive mode and is prompted for commands. All%.', 99);
   call ioa$ (' of the options may be abbreviated to those letters in uppercase.%/%.', 99);
   call ioa$ (' The options are :%/%.', 99);
   call ioa$ ('%5x-Receive [pathname]%/%8xUpload ONE file with the specified name or its original filename.%.', 199);
   call ioa$ ('%/%5x-Send wildcard%/%8xDownload several files. Wildcards may be used, but the -ALTERNATE%.', 99);
   call ioa$ ('%8xoption is then ignored.%.', 99);
   call ioa$ ('%/%5x-SERver%/%8xEnter server mode. Files may be sent and received, and additional%.', 99);
   call ioa$ ('%8xcommands may be issued.%.', 99);

   ans = '';
   call tnoua ('More ? ', 7);
   call cl$get (ans, 16, code);
   if code ^= 0 then
      do;
         call get_error_msg (code);
         call ioa$ ('Error reading the command line. %v%.', 99, errmsg);
         return;
      end;

   if length (ans) > 0 then
      ans = translate (substr (trim (ans, '11'b), 1, 1), uppercase, lowercase);
   if ans ^= 'Y' & ans ^= '' then
      return;

   call ioa$ ('%/%5x-Alternate filename%/%8xAlternate file name for when ONE file is being sent.%.', 99);
   call ioa$ ('%/%5x-File_Type {AUTOMATIC | TEXT | BINARY}%/%8xSpecifies the type of file, %$', 99);
   call ioa$ ('or if AUTOMATIC is used then Kermit%.', 99);
   call ioa$ ('%8xwill try to determine its type. Default is AUTOMATIC.%.', 99);
   call ioa$ ('%/%5x-Parity {MARK | NONE}%/%8xSpecifies the character parity to %$', 99);
   call ioa$ ('use. Default is MARK.%.', 99);
   call ioa$ ('%/%5x-Log [pathname]%/%8xOpens a log file for recording the packets %$', 99);
   call ioa$ ('sent and received.%/%8xDefault log file name is KERMIT.LOG%.', 99);
   call ioa$ ('%/%5x-POUnd {ON | OFF}%/%8xDetermines whether to convert DOS %$', 99);
   call ioa$ ('pound signs. Default is ON.%.', 99);
   call ioa$ ('%/%5x-Help%/%8xDisplays this HELP message.%.', 99);
   call ioa$ ('%/%5x-Usage%/%8xDisplays the Kermit usage syntax only.%/%.', 99);

   return;

   end;       /* Print_cl_help */

/* ***************************** Start_log_file **************************** */

Start_log_file : proc;

/* ************************************************************************* */

   code = open_log (cl_struc.log_path);
   if code ^= 0 then
      do;
         call get_error_msg (code);
         call ioa$ ('Log file not opened. %v%.', 99, errmsg);
      end;

   return;

   end;        /* Start_log_file */

   end;    /* Kermit */
-------------------------------------------------------------------------------

/* KERMIT_INIT -- Initialize Kermit variables. */

Kermit_init : proc;

$Insert *>insert>common.ins.plp
$Insert *>insert>kermit.ins.plp
$Insert *>insert>primos.ins.plp
$Insert *>insert>constants.ins.plp
$Insert syscom>keys.ins.pl1

Dcl (user_num, code) fixed bin,
    b8 bit (8) aligned,
    b8_ptr ptr,
    u_name char (32);

/* ************************************************************************* */

   b8_ptr = addr (b8);
   kversion = 'Public domain version 8.00';
   kprompt = 'Kermit-R21';

   delay = init_delay;
   rec_seq = 0;
   msg_number = 0;
   snd_msg = '';
   rec_msg = '';
   rec_pkt_type = '';
   rec_length = 0;

   rec_file_size = -1;           /* Received file attributes. */
   rec_file_dtc = -1;
   rec_file_type = automatic_ft;
   use_attributes = true;

   do user_num = 0 to 63;
      msg_table.slot(user_num).msg = '';
      msg_table.slot(user_num).acked = false;
      msg_table.slot(user_num).retries = 0;
   end;

   tab_first = 0;                    /* Default transfer parameters. */
   tab_next = 0;
   state = 0;
   num_retries = 0;
   quote8_char = 'N';
   file_type = automatic_ft;         /* Unknown file type. */
   explicit_ft_set = false;
   first_read = true;
   filename_warning = true;
   do_repeats = false;
   do_windowing = false;
   do_transparent = false;
   do_flush = true;
   do_8bit_chks = false;
   auto_sum = true;
   log_opened = false;
   log_unit = 0;
   window_size = 1;
   errmsg = '';

   take_level = 0;
   do user_num = 1 to max_take_level;
      take_unit(user_num) = 0;
   end;

   loc_pkt_size = my_pkt_size;       /* Default send init parameters. */
   loc_npad = my_npad;
   b8 = my_pad_chr;
   loc_padchar = b8_ptr -> char1_based;
   loc_timeout = my_timeout;
   b8 = my_eol_chr;
   loc_eol = b8_ptr -> char1_based;
   loc_quote_chr = my_quote_chr;
   loc_8quote_chr = my_8quote_chr;
   loc_chk_type = my_chk_type;
   loc_rep_chr = my_rep_chr;
   loc_capas1 = my_capas1;
   loc_file_attrib = false;
   loc_windowing = false;
   loc_max_wsize = my_max_wsize;

   path_name = '';
   dir_name = '';
   non_null_dir = false;
   file_name = '';
   alternate_fname = '';
   file_unit = 0;
   file_opened = false;
   file_len = 0;
   file_pos = 0;

   do user_num = 1 to max_matches;
      matches(user_num) = '';
   end;

   num_matches = 0;
   file_idx = 0;

   del_incomplete = true;
   ibuffer = copy (' ', ibuffer_size);
   ibuffer_ptr = addr (ibuffer);
   ibuflen = 0;
   ibuf_ptr = 0;
   eol_flag = 0;
   char2_ptr = addr (char2);
   char2_ptr -> fb15_based = 0;
   pound_conversion = true;
   explicit_pound_set = false;

   do user_num = 0 to 255;
      trans_char(user_num) = '';
   end;

   dir_entry_ptr = addr (dir_entry);

   call erkl$$ (k$read, my_erase, my_kill, code); /* Keep these for our user. */
   if code ^= 0 then
      do;
         call get_error_msg (code);
         call ioa$ ('Error getting erase and kill characters. %v%.', 99, errmsg);
      end;

   my_duplex = duplx$ ('FFFF'b4);

   call user$ (user_num, code);    /* Get our MESSAGE status. */
   call msg$st (k$read, user_num, '', 0, u_name, 32, my_msg_state);

   b8 = '00'b4;                    /* Setup all the character codes we need. */
   nul_7bit_asc = b8_ptr -> char1_based;
   b8 = '80'b4;
   nul_8bit_asc = b8_ptr -> char1_based;

   b8 = ctrl_a_7bit_dec;
   ctrl_a_7bit_asc = b8_ptr -> char1_based;
   b8 = ctrl_a_8bit_dec;
   ctrl_a_8bit_asc = b8_ptr -> char1_based;

   b8 = '08'b4;
   bs_7bit_asc = b8_ptr -> char1_based;

   b8 = cr_7bit_dec;
   cr_7bit_asc = b8_ptr -> char1_based;

   rem_eol = cr_7bit_asc;        /* We need this for the FIRST packet sent. */

   b8 = cr_8bit_dec;
   cr_8bit_asc = b8_ptr -> char1_based;

   b8 = lf_7bit_dec;
   lf_7bit_asc = b8_ptr -> char1_based;

   b8 = lf_8bit_dec;
   lf_8bit_asc = b8_ptr -> char1_based;

   b8 = '0C'b4;
   ff_7bit_asc = b8_ptr -> char1_based;

   b8 = '91'b4;
   dc1_8bit_asc = b8_ptr -> char1_based;

   b8 = '1A'b4;
   ctrl_z_7bit_asc = b8_ptr -> char1_based;
   b8 = '9A'b4;
   ctrl_z_8bit_asc = b8_ptr -> char1_based;

   b8 = '3F'b4;
   query_7bit_asc = b8_ptr -> char1_based;

   b8 = '60'b4;
   grave_7bit_asc = b8_ptr -> char1_based;

   return;

   end;         /* Kermit_init */
-------------------------------------------------------------------------------

/* LOG_INFO -- Log one line of info to log file. */

Log_info : proc (data);

Dcl data char (256) var;

$Insert *>insert>common.ins.plp
$Insert *>insert>kermit.ins.plp
$Insert *>insert>primos.ins.plp
$Insert *>insert>constants.ins.plp

Dcl code fixed bin;

/* ************************************************************************* */

   if log_opened then
      do;
         call wtlin$ (log_unit, ('---- ' || data || '  '),
                      divide (length (data) + 6, 2, 15), code);
         if code ^= 0 then
            do;
               call get_error_msg (code);
               call ioa$ ('Unable to write to the log file. %v%/Closing the log file.%.',
                          99, errmsg);
               log_opened = false;
               call clo$fu (log_unit, code);
            end;
      end;

   return;

   end;    /* Log_info */
-------------------------------------------------------------------------------

/* LOG_PACKET -- Log Kermit packet to disk. */

Log_packet : proc (packet_type, seq_num, data);

$Insert *>insert>common.ins.plp

Dcl packet_type char (1),
    seq_num fixed bin,
    data char (max_msg) var;

$Insert *>insert>kermit.ins.plp
$Insert *>insert>primos.ins.plp
$Insert *>insert>constants.ins.plp

Dcl line char (256) var,
    code fixed bin;

/* ************************************************************************* */

   if ^log_opened then
      return;

   select (packet_type);

      when (msg_data)
         line = 'DATA ';

      when (msg_attrib)
         line = 'ATTR ';

      when (msg_ack)
         line = 'ACK  ';

      when (msg_nak)
         line = 'NAK  ';

      when (msg_snd_init)
         line = 'SNDI ';

      when (msg_break)
         line = 'BRK  ';

      when (msg_file)
         line = 'FILE ';

      when (msg_eof)
         line = 'EOF  ';

      when (msg_error)
         line = 'ERR  ';

      when (msg_rcv_init)
         line = 'RCVI ';

      when (msg_host_command)
         line = 'HOST ';

      when (msg_text)
         line = 'TEXT ';

      when (msg_init_info)
         line = 'INIT ';

      when (msg_kermit)
         line = 'KER  ';

      when (msg_kermit_generic)
         line = 'GEN  ';

      when (msg_timeout)
         line = 'TIME ';

      when (msg_check_err)
         line = 'CHK  ';

      otherwise
         line = '?? ' || packet_type || ' ';

   end;

   if seq_num < 10 then
      line = line || ' ';

   line = line || trim (char (seq_num), '11'b);     /* Append the seq. number. */

   if data ^= '' then                          /* Append the data. */
      line = line || ' "' || data || '"';

   call wtlin$ (log_unit, (line || '  '), divide (length (line) + 1, 2, 15), code);
   if code ^= 0 then
      do;
         call get_error_msg (code);
         call ioa$ ('Unable to log the packet. %v%/Closing the log file. %.', 99, errmsg);
         log_opened = false;
         call clo$fu (log_unit, code);
      end;

   return;

   end;        /* Log_packet */
-------------------------------------------------------------------------------

/* MATCH_FILE -- Match a wildcard spec from user to determine filenames. */

Match_file : proc returns (fixed bin);

$Insert *>insert>common.ins.plp
$Insert *>insert>kermit.ins.plp
$Insert *>insert>primos.ins.plp
$Insert syscom>keys.ins.pl1
$Insert syscom>errd.ins.pl1

Dcl (dir_unit, type, sufusd, code) fixed bin,
    (basename, fn, wild_name) char (32) var;

/* ************************************************************************* */

   code = 0;
   num_matches = 0;

   /* First we convert the filename to uppercase, and translate any
      wildcard characters from DOS to the PRIME equivelent. Apart from
      the one case below we cannot fully translate the wildcards, since
      we don't know what the user actually means.

      E.g. Given the file A.B.C, if the user types *.C do they just mean
           the files @.C, or do they mean @@.C which would include A.B.C. */

   if file_name = '*.*' then
      if non_null_dir then
         path_name = dir_name || '>@@';
      else
         path_name = '@@';

   path_name = translate (path_name, uppercase || '@+', lowercase || '*?');
   call set_path (path_name);

   if search (path_name, '@+') = 0 then     /* See if we have just one file name. */
      do;
         num_matches = 1;
         matches(1) = path_name;
         return (code);
      end;

   if search (dir_name, '@+') ^= 0 then      /* Wildcarded directories ? */
      return (e$itre);

   wild_name = file_name;

   call srsfx$ (k$read + k$getu, dir_name, dir_unit, type, 0, '', basename, sufusd, code);
   if code ^= 0 then
      return (code);

   call dir$rd (k$init, dir_unit, dir_entry_ptr, dir_entry_size, code);

   do until (code ^= 0);

      call dir$rd (k$read, dir_unit, dir_entry_ptr, dir_entry_size, code);

      if code = 0 & dir_entry.ecw.type = '02'b4 &
         (dir_entry.file_info.type < '02'b4 | dir_entry.file_info.type = '07'b4) then
         do;                  /* It's an ordinary SAM, DAM, or CAM file. */
            fn = trim (dir_entry.entryname, '11'b);
            if wild$ (wild_name, fn, code) then
               do;
                  num_matches = num_matches + 1;
                  if num_matches <= max_matches then
                     matches(num_matches) = fn;
                  else
                     code = e$tmvv;         /* Too many values for variable. */
               end;
         end;
   end;

   call clo$fu (dir_unit, sufusd);

   if code = e$eof then
      code = 0;

   return (code);

   end;     /* Match_file */
-------------------------------------------------------------------------------

/* NEXT_FILE -- Fetch next file of wildcard specification. */

Next_file : proc returns (fixed bin);

$Insert *>insert>common.ins.plp
$Insert *>insert>kermit.ins.plp
$Insert *>insert>constants.ins.plp

Dcl code fixed bin,
    test_flag bit (1) aligned;

/* ************************************************************************* */

   test_flag = false;

   do until (test_flag);
      if file_idx > num_matches | file_idx = 0 then  /* Check for the end of the table. */
         return (ker_nomorfiles);

      call set_path (matches(file_idx));  /* Get the next file name. */

      code = open_input ();               /* Try to open the file. */
      if code ^= 0 then
         do;
            call get_error_msg (code);
            call log_info ('Error opening ' || path_name || '. ' || errmsg);
            file_idx = file_idx + 1;      /* Try the next file. */
         end;
      else
         do;
            test_flag = true;

            if log_opened then
               do;
                  select (file_type);

                     when (ascii_ft)
                        errmsg = 'as ASCII file type.';

                     when (binary_ft)
                        errmsg = 'as BINARY file type.';

                     when (automatic_ft)
                        errmsg = 'with AUTOMATIC file type detection.';

                     otherwise
                        errmsg = 'with an ILLEGAL file type.';

                  end;

                  call log_info ('File ' || path_name || ' opened ' || errmsg);

                  if explicit_ft_set then
                     call log_info ('The file type has been explicitly set.');
                  else
                     if file_type ^= automatic_ft then
                        call log_info ('The file type has been automatically set.');
               end;
         end;

   end;

   if num_matches = 1 & (alternate_fname ^= '') then  /* Use alternate name if given. */
      do;
         file_name = alternate_fname;

         if log_opened then
            call log_info ('The file ' || path_name || ' will be sent using the alternate file name of ' || alternate_fname);

         if ^non_null_dir then
            path_name = file_name;
         else
            path_name = dir_name || '>' || file_name;
      end;

   file_idx = file_idx + 1;               /* Point to next file name. */

   return (ker_normal);

   end;       /* Next_file */
-------------------------------------------------------------------------------

/* OPEN_INPUT -- Open input file, determine its type and length. */

Open_input : proc returns (fixed bin);

$Insert *>insert>common.ins.plp
$Insert *>insert>kermit.ins.plp
$Insert *>insert>primos.ins.plp
$Insert *>insert>constants.ins.plp
$Insert syscom>keys.ins.pl1
$Insert syscom>errd.ins.pl1

Dcl (type, code, rnw, code2, sufusd) fixed bin,
    basename char (32) var;

/* ************************************************************************* */

   call srsfx$ (k$read + k$getu, path_name, file_unit, type, 0, '', basename, sufusd, code);

   if type > 1 & type ^= 7 then
      do;
         call clo$fu (file_unit, code);
         code = e$wft;
      end;

   file_opened = (code = 0);

   if code ^= 0 then
      return (code);

   code = get_len ();
   if code = 0 then
      do;
         if file_type = automatic_ft then  /* AUTOMATIC file type detection. */
            call ck_file_type;

         if code = 0 then
            return (code);
      end;

   file_opened = false;     /* At this point something is wrong, so  close the file. */
   call clo$fu (file_unit, code2);

   return (code);

/* ****************************** Ck_file_type ***************************** */

Ck_file_type : proc;

Dcl (character, prev_char) char (1),
    character_ptr ptr;

Dcl 1 bit_char based,
      2 high_bit bit (1),
      2 rest bit (7);

/* ************************************************************************* */

   /* Initialize local variables for file type checking. */

   code = 0;
   character = nul_7bit_asc;
   character_ptr = addr (character);

   if file_len = 0 then
      do;                        /* This allows for empty files. */
         ibuflen = 0;
         file_type = ascii_ft;
         return;
      end;

   call prwf$$ (k$read, file_unit, ibuffer_ptr, ibuffer_size_wds, 0, rnw, code);

   if code = e$eof & rnw ^= 0 then
      code = 0;

   ibuflen = 2 * rnw;
   file_pos = ibuflen;

   if code ^= 0 then
      return;

   file_type = ascii_ft;         /* Assume it's ASCII to begin with. */

   do ibuf_ptr = 1 to ibuflen while (file_type ^= binary_ft); /* This is the main checking loop. */

      prev_char = character;
      character = substr (ibuffer, ibuf_ptr, 1);

   /* If the high bit is off then check for some special
      characters before deciding that it IS a binary file. */

      if ^character_ptr -> bit_char.high_bit then
         if prev_char ^= dc1_8bit_asc &        /* Space compression. */
            ^(prev_char = lf_8bit_asc & character = nul_7bit_asc) & /* LFNUL */
            ^(character = bs_7bit_asc |        /* Back Space. */
              character = ff_7bit_asc) &       /* Form Feed. */
            ^(character = ctrl_a_7bit_asc &  /* CTRL-A for FORTRAN formats. */
              (prev_char = lf_8bit_asc | prev_char = nul_7bit_asc | prev_char = ctrl_a_7bit_asc)) &
            character ^= ctrl_z_7bit_asc then
                 file_type = binary_ft;

   end;

   if file_type ^= binary_ft & file_len = ibuflen then  /* ASCII files must end in LF or CTRL-Z. */
      do;
         if character = nul_7bit_asc then
            character = prev_char;

         if ^(character = lf_8bit_asc | character = ctrl_z_7bit_asc) then
            file_type = binary_ft;
      end;

   if file_type = binary_ft & ^explicit_pound_set then
      pound_conversion = false;

   ibuflen = 0;             /* Re-initialize some of our buffer variables. */
   ibuf_ptr = 1;
   ibuffer = '';

   call prwf$$ (k$posn + k$prea, file_unit, null (), 0, 0, rnw, code);

   if code = 0 then
      file_pos = 0;

   return;

   end;        /* Ck_file_type */

   end;      /* Open_input */
-------------------------------------------------------------------------------

/* OPEN_LOG -- Open an output log file. */

Open_log : proc (pathname) returns (fixed bin);

Dcl pathname char (128) var;

$Insert *>insert>common.ins.plp
$Insert *>insert>primos.ins.plp
$Insert syscom>keys.ins.pl1
$Insert syscom>errd.ins.pl1

Dcl (type, sufusd, code) fixed bin,
    basename char (32) var,
    fn char (128) var;

/* ************************************************************************* */

   fn = pathname;
   if fn = '' then
      fn = 'kermit.log';

   call fil$dl (fn, code);       /* Delete any old file first, if possible. */

   if code = 0 | code = e$fntf then
      call srsfx$ (k$writ + k$getu, fn, log_unit, type, 0, '', basename, sufusd, code);

   log_opened = (code = 0);

   return (code);

   end;      /* Open_log */
-------------------------------------------------------------------------------

/* OPEN_OUTPUT -- Open an output file. */

Open_output : proc returns (fixed bin);

$Insert *>insert>kermit.ins.plp
$Insert *>insert>common.ins.plp
$Insert *>insert>primos.ins.plp
$Insert *>insert>constants.ins.plp
$Insert syscom>keys.ins.pl1
$Insert syscom>errd.ins.pl1

Dcl (type, sufusd, code, num_len, i) fixed bin,
    (file_exists, new_file_name, overwrite) bit (1) aligned,
    new_path_ptr ptr,
    (treename, new_path) char (128) var,
    (basename, suffix) char (32) var;

Dcl 1 bvs based,
      2 len fixed bin,
      2 chars char (128);

%Replace dot by '.';

/* ************************************************************************* */

   file_exists = false;
   file_opened = false;
   new_file_name = false;

   if non_null_dir then
      if ^tnchk$ (k$uprc, dir_name) then
         return (e$itre);                 /* A bad directory name given. */

   if ^fnchk$ (k$uprc, file_name) then
      do;                                 /* Replace a bad file name. */
         new_file_name = true;
         file_name = 'KERMIT_FILE';

         if ^non_null_dir then
            path_name = file_name;
         else
            path_name = dir_name || '>' || file_name;
      end;

   if filename_warning then
      do;
         call srsfx$ (k$exst, path_name, file_unit, type, 0, '', basename, sufusd, code);
         if code = 0 then
            do;
               file_exists = true;
               new_path_ptr = addr (new_path);
               overwrite = (length (file_name) = 32);

               if overwrite then      /* See if we overwrite or append to the file name. */
                  num_len = 1;
               else
                  do;
                     num_len = 32 - length (file_name);
                     if num_len > 4 then
                        num_len = 4;
                  end;

               if index (file_name, dot) ^= 0 then
                  do;
                     treename = before (file_name, dot);
                     suffix = dot || after (file_name, dot);
                  end;
               else
                  do;
                     treename = file_name;
                     suffix = '';
                  end;

               if overwrite then
                  treename = substr (treename, 1, length (treename) - 1);

               do i = 1 to 9999 until (code ^= 0);
                  if overwrite then
                     if i = 10 then
                        do;
                           num_len = 2;
                           treename = substr (treename, 1, length (treename) - 1);
                        end;
                     else
                        if i = 100 then
                           do;
                              num_len = 3;
                              treename = substr (treename, 1, length (treename) - 1);
                           end;
                        else
                           if i = 1000 then
                              do;
                                 num_len = 4;
                                 treename = substr (treename, 1, length (treename) - 1);
                              end;

                  call ioa$rs (new_path_ptr -> bvs.chars, 128, new_path_ptr -> bvs.len,
                               '%v%#zd%v%$', 99, treename, num_len, i, suffix);

                  call srsfx$ (k$exst, new_path, file_unit, type, 0, '', basename, sufusd, code);
               end;

               if code = e$fntf then
                  call set_path (new_path);
               else
                  if code = 0 then
                     code = e$ialn;
            end;
      end;
   else
      call fil$dl (path_name, code);

   if code = 0 | code = e$fntf then
      do;
         call srsfx$ (k$writ + k$getu, path_name, file_unit, type, 0, '', basename, sufusd, code);
         if code = 0 then
            do;
               ibuffer = '';
               ibuf_ptr = 0;
            end;
      end;

   file_opened = (code = 0);

   if code = 0 then
      if new_file_name then
         code = e$bnam;          /* Say that the file name was bad. */
      else
         if file_exists then     /* Say that the file already exists. */
            code = e$exst;

   return (code);

   end;         /* Open_output */
-------------------------------------------------------------------------------

/* PRS_SEND_INIT -- Parse SND_INIT packet from remote Kermit. */

Prs_send_init : proc;

$Insert *>insert>common.ins.plp
$Insert *>insert>kermit.ins.plp
$Insert *>insert>constants.ins.plp

Dcl (cap_len, cap_pos, cap_byte) fixed bin,
    cap_ptr ptr;

/* ************************************************************************* */

   rem_pkt_size = 80;   /* Set the default values for fields not received. */
   rem_npad = 0;
   rem_padchar = nul_7bit_asc;
   rem_pad_chars = copy (rem_padchar, max_rem_pad_chrs);  /* Never received. */
   rem_timeout = 1;                 /* Timeout in minutes. */
   rem_eol = cr_7bit_asc;
   rem_quote_chr = '#';
   rem_8quote_chr = 'N';
   rem_chk_type = '1';
   rem_rep_chr = ' ';
   rem_capas1 = 0;
   rem_file_attrib = false;
   rem_windowing = false;
   rem_max_wsize = 1;

   select (length (rec_msg) - pkt_tot_ovr_head);  /* Process the packet according to its length. */

      when (p_si_bufsiz)
         goto pkt_lbl;

      when (p_si_timout)
         goto to_lbl;

      when (p_si_npad)
         goto np_lbl;

      when (p_si_pad)
         goto pc_lbl;

      when (p_si_eol)
        goto eol_lbl;

      when (p_si_quote)
         goto qc_lbl;

      when (p_si_8quote)
         goto ebqc_lbl;

      when (p_si_chk)
         goto chk_lbl;

      when (p_si_rep)
         go to rep_lbl;

      when (0)
         return;

   end;

   /* Longer messages drop through to check the capabilities. */

   cap_ptr = addr (rem_capas1);
   rem_capas1 = knum (substr (rec_msg, pkt_msg + p_si_capas, 1));
   rem_file_attrib = cap_ptr -> capas.file_attributes;
   rem_windowing = cap_ptr -> capas.windowing;

   /* Find the end of the variable length capabilities field. */

   cap_len = 1;
   cap_byte = rem_capas1;
   cap_ptr = addr (cap_byte);

   do while (cap_ptr -> capas.continues);
      cap_len = cap_len + 1;
      cap_byte = knum (substr (rec_msg, pkt_msg + p_si_capas + cap_len - 1, 1));
   end;

   cap_pos = pkt_msg + p_si_capas + cap_len;

   if rem_windowing then             /* Get the maximum window size. */
      rem_max_wsize = knum (substr (rec_msg, cap_pos, 1));

Rep_lbl :
   rem_rep_chr = substr (rec_msg, pkt_msg + p_si_rep, 1);

Chk_lbl :
   rem_chk_type = substr (rec_msg, pkt_msg + p_si_chk, 1);

Ebqc_lbl :
   rem_8quote_chr = substr (rec_msg, pkt_msg + p_si_8quote, 1);

Qc_lbl :
   rem_quote_chr = substr (rec_msg, pkt_msg + p_si_quote, 1);

Eol_lbl :
   char2_ptr -> fb15_based = knum (substr (rec_msg, pkt_msg + p_si_eol, 1));
   rem_eol = char2(2);

Pc_lbl :
   rem_padchar = ctl (substr (rec_msg, pkt_msg + p_si_pad, 1));
   rem_pad_chars = copy (rem_padchar, max_rem_pad_chrs);

Np_lbl :
   rem_npad = knum (substr (rec_msg, pkt_msg + p_si_npad, 1));

To_lbl :
   rem_timeout = knum (substr (rec_msg, pkt_msg + p_si_timout, 1)) + 59;
   rem_timeout = divide (rem_timeout, 60, 15); /* Set the timeout in minutes. */

Pkt_lbl :
   rem_pkt_size = knum (substr (rec_msg, pkt_msg + p_si_bufsiz, 1));

   return;

   end;        /* Prs_send_init */
-------------------------------------------------------------------------------

/* READ_INPUT -- Read input file and form data packet. */

Read_input : proc (code) returns (fixed bin);

Dcl code fixed bin;

$Insert *>insert>common.ins.plp
$Insert *>insert>kermit.ins.plp
$Insert *>insert>primos.ins.plp
$Insert *>insert>constants.ins.plp
$Insert syscom>keys.ins.pl1
$Insert syscom>errd.ins.pl1

Dcl crlf char (2),
    (prev_char, new_char) char (1),
    chr char (3) var,
    (rep_count, i, max_chars, rnw, ibuf_wds_less1, ibuf_size_less2) fixed bin;

/* ************************************************************************* */

   code = 0;
   snd_msg = '';              /* Clear sending buffer. */
   rep_count = 0;
   prev_char = nul_7bit_asc;
   char2_ptr -> fb15_based = 0;
   ibuf_wds_less1 = ibuffer_size_wds - 1;
   ibuf_size_less2 = ibuffer_size - 2;
   crlf = cr_8bit_asc || lf_8bit_asc;

   max_chars = rem_pkt_size - pkt_tot_ovr_head - 2; /* This allows for 8-bit, */
   if do_repeats then                /* control chars, but NOT repeats. */
      max_chars = max_chars - 2;     /* This now allows for repeat chars. */

Loop :

   do until (length (snd_msg) >= max_chars);       /* Main packet loop. */
      ibuf_ptr = ibuf_ptr + 1;
      if ibuf_ptr > ibuflen then
         do;
            call read_file;
            ibuf_ptr = 1;
            if code ^= 0 then
               leave loop;
         end;

      new_char = substr (ibuffer, ibuf_ptr, 1);

      if do_repeats then
         if (new_char = prev_char & rep_count < 94) | first_read then
            rep_count = rep_count + 1;
         else
            do;
               char2(2) = prev_char;
               chr = trans_char (char2_ptr -> fb15_based);

               if rep_count > 3 then
                  do;
                     char2_ptr -> fb15_based = rep_count + 32;
                     rep_count = 1;  /* We must do this for the do-loop. */
                     snd_msg = snd_msg || loc_rep_chr || char2(2);
                  end;

               do i = 1 to rep_count;
                  snd_msg = snd_msg || chr;
               end;

               rep_count = 1;

            end;
      else
         do;
            char2(2) = new_char;
            snd_msg = snd_msg || trans_char (char2_ptr -> fb15_based);
         end;

      first_read = false;
      prev_char = new_char;

   end;

   if code = e$eof then
      code = 0;

   if code = 0 & do_repeats then
      do;
         char2(2) = new_char;
         chr = trans_char (char2_ptr -> fb15_based);

         if rep_count > 3 then
            do;
               char2_ptr -> fb15_based = rep_count + 32;
               rep_count = 1;     /* We must do this for the do-loop. */
               snd_msg = snd_msg || loc_rep_chr || char2(2);
            end;

         do i = 1 to rep_count;
            snd_msg = snd_msg || chr;
         end;

      end;

   if code ^= 0 then
      return (ker_internalerr);
   else
      if length (snd_msg) = 0 then
         return (ker_eof);
      else
         return (ker_normal);

/* ******************************* Read_file ******************************* */

Read_file : proc;

/* ************************************************************************* */

   if file_type = ascii_ft then
      do;
         call rdlin$ (file_unit, ibuffer, ibuf_wds_less1, code);
         if code ^= 0 then
            do;
               ibuflen = 0;
               return;
            end;

         ibuflen = length (trim (substr (ibuffer, 1, ibuf_size_less2), '01'b));
         substr (ibuffer, ibuflen + 1, 2) = crlf;
         ibuflen = ibuflen + 2;

         ibuffer = clr8str ((ibuffer));
      end;
   else
      do;                                 /* BINARY files. */
         call prwf$$ (k$read, file_unit, ibuffer_ptr, ibuffer_size_wds, 0, rnw, code);
         if code = e$eof & rnw ^= 0 then
            code = 0;

         ibuflen = 2 * rnw;

         if code = 0 then
            do;
               file_pos = file_pos + ibuflen;

               if file_pos > file_len then
                  ibuflen = ibuflen - 1;
            end;

      end;

   return;

   end;              /* Read_file */

   end;            /* Read_input */
-------------------------------------------------------------------------------

/* REC_PACKET -- Receive a packet from remote Kermit. */

Rec_packet : proc;

$Insert *>insert>common.ins.plp
$Insert *>insert>kermit.ins.plp
$Insert *>insert>primos.ins.plp
$Insert *>insert>constants.ins.plp

Dcl (char_in, code, rec_msg_len) fixed bin,
    line char (max_msg) var;

/* ************************************************************************* */

   timeout = bad_return;        /* Local label used for Timeout condition. */

   call limit$ ('0602'b4, (rem_timeout), 0, code);

   do until (char_in = ctrl_a_8bit_dec | char_in = ctrl_a_7bit_dec);
      call c1in (char_in);
   end;

   call get_line;                     /* Get the rest of the message. */

   call limit$ ('0602'b4, 0, 0, code);       /* Turn off the timer. */

   rec_msg_len = length (rec_msg);
   if rec_msg_len < pkt_msg then   /* Check that the packet length is valid. */
      do;
         rec_pkt_type = msg_check_err;

         if log_opened then
            do;
               call log_info ('Packet length of ' || trim (char (rec_msg_len), '11'b) || ' is too short.');

               if rec_msg_len <= 1 then
                  line = '';
               else
                  line = substr (rec_msg, 2);

               call log_packet (rec_pkt_type, 0, line);
            end;

         return;

      end;

   rec_pkt_type = set8 (substr (rec_msg, pkt_type, 1));  /* Extract the fields from the packet. */
   rec_length = knum (substr (rec_msg, pkt_count, 1)) + 2;
   rec_seq = knum (substr (rec_msg, pkt_seq, 1));

   if rec_msg_len ^= rec_length then   /* Check that the packet length is correct. */
      do;
         rec_pkt_type = msg_check_err;

         if log_opened then
            do;
               call log_info ('Packet length byte (' || trim (char (rec_length - 2), '11'b) ||
                    ') is not equal to packet size (' || trim (char (rec_msg_len - 2), '11'b) || ').');

               if rec_msg_len <= 1 then
                  line = '';
               else
                  line = substr (rec_msg, 2);

               call log_packet (rec_pkt_type, 0, line);
            end;

         return;

      end;

   if ^check_checksum () then         /* Check the checksum. */
      if log_opened then
         do;
            if rec_msg_len <= 1 then
               line = '';
            else
               line = substr (rec_msg, 2);

            call log_packet (rec_pkt_type, 0, line);
         end;
      else
         ;
   else                     /* A good return. */
      if log_opened then
         do;
            if rec_msg_len <= pkt_msg then
               line = '';
            else
               line = substr (rec_msg, pkt_msg, rec_msg_len - pkt_msg);

            call log_packet (rec_pkt_type, rec_seq, line);
         end;

   return;

Bad_return :            /* If we get here then the Timeout condition has been raised. */
   rec_pkt_type = msg_timeout;
   call log_packet (rec_pkt_type, 0, '');

   return;

/* ******************************* Get_line ******************************** */

Get_line : proc;

Dcl rec_msg_buffer char (max_msg),
    last_char char (1),
    buflen fixed bin;

/* ************************************************************************* */

   call cnin$ (rec_msg_buffer, max_msg_less1, buflen);

   last_char = clr8 (substr (rec_msg_buffer, buflen, 1));

   if last_char = cr_7bit_asc | last_char = lf_7bit_asc then
      buflen = buflen - 1;

   rec_msg = ctrl_a_8bit_asc || substr (rec_msg_buffer, 1, buflen);

   return;

   end;         /* Get_line */

/* ***************************** Check_checksum **************************** */

Check_checksum : proc returns (bit (1) aligned);

Dcl (chksum, chksum7, chksum8, key, rec_len, rec_pkt_chksum) fixed bin;

/* ************************************************************************* */

   rec_len = rec_length - 1;
   rec_pkt_chksum = knum (substr (rec_msg, rec_length, 1));

   if auto_sum then      /* If checksum type is undetermined, then try both. */
      do;
         chksum7 = chks (0, substr (rec_msg, 1, rec_len));
         chksum8 = chks (1, substr (rec_msg, 1, rec_len));

         if (chksum7 ^= rec_pkt_chksum) & (chksum8 ^= rec_pkt_chksum) then
            do;
               rec_pkt_type = msg_check_err;
               call log_info ('Checksum error : wanted '||
                              trim (char (chksum7), '11'b) || ' or ' ||
                              trim (char (chksum8), '11'b) ||', but got ' ||
                              trim (char (rec_pkt_chksum), '11'b) || '.');
               return (false);
            end;

         if chksum7 ^= chksum8 then    /* Determine checksum type if undetermined. */
            do;
               auto_sum = false;
               do_8bit_chks = (chksum8 = rec_pkt_chksum);
               if do_8bit_chks then
                  call log_info ('Doing 8 bit checksums.');
               else
                  call log_info ('Doing 7 bit checksums.');
            end;

      end;
   else
      do;                 /* Checksum type already determined. */
         if do_8bit_chks then
            key = 1;
         else
            key = 0;

         chksum = chks (key, substr (rec_msg, 1, rec_len));

         if chksum ^= rec_pkt_chksum then
            do;
               rec_pkt_type = msg_check_err;
               char2(1) = nul_7bit_asc;
               char2(2) = substr (rec_msg, rec_length, 1);
               rec_pkt_chksum = char2_ptr -> fb15_based - 32;
               call log_info ('Checksum error : wanted ' ||
                              trim (char (chksum), '11'b) || ', but got ' ||
                              trim (char (rec_pkt_chksum), '11'b) || '.');
               return (false);
            end;
      end;

   return (true);

   end;          /* Check_checksum */

   end;        /* Rec_packet */
-------------------------------------------------------------------------------

/* REC_SWITCH -- Handle Kermit file receive protocol. */

Rec_switch : proc;

$Insert *>insert>common.ins.plp
$Insert *>insert>kermit.ins.plp
$Insert *>insert>primos.ins.plp
$Insert *>insert>constants.ins.plp
$Insert syscom>errd.ins.pl1

Dcl (temp, i, fs_attr_type, rep_count) fixed bin,
    new_path char (128) var,
    chr char (1),
    (single_file_rec, test_flag) bit (1) aligned;

/* ************************************************************************* */

   do_flush = true;
   num_retries = 0;          /* Initialize the number of retries. */
   single_file_rec = (path_name ^= '');

   if log_opened then
      do;
         if single_file_rec then
            errmsg = ' ' || path_name;
         else
            errmsg = '';

         call log_info ('');
         call log_info (kversion || ' receiving' || errmsg || '.');
      end;

   do while (true);

      select (state);

         when (state_r)
            state = rec_init ();

         when (state_rf)
            state = rec_file ();

         when (state_ra)
            state = rec_attrib ();

         when (state_rd)
            state = rec_data ();

         when (state_rdw)
            state = rec_windowing ();

         when (state_c)
            do;
               call sleep$ (3000);
               return;
            end;

         otherwise                    /* This includes state_a. */
            do;
               do_flush = true;
               call discard_output (i);
               if i ^= 0 then
                  do;
                     call get_error_msg (i);
                     snd_msg = 'Error trying to discard the output file. ' || errmsg;
                     call send_packet (msg_error, length (snd_msg), msg_number);
                  end;

               call sleep$ (3000);
               return;
            end;

      end;     /* select */

   end;     /* do while ... */

/* ******************************** Rec_init ******************************* */

Rec_init : proc returns (fixed bin);

/* ************************************************************************* */

   msg_number = 0;               /* Initialize sequence numbering. */

   if ^rec_message () then       /* Get a packet. */
      return (state_a);

   if rec_pkt_type = msg_snd_init then
      do;
         call ack_send_init;
         num_retries = 0;
         msg_number = mod (msg_number + 1, 64);
         return (state_rf);         /* Ready to receive file info. */
      end;
   else
      do;
         call send_packet (msg_nak, 0, rec_seq);
         return (state_a);
      end;

   end;      /* Rec_init */

/* ******************************* Rec_file ******************************** */

Rec_file : proc returns (fixed bin);

/* ************************************************************************* */

   if ^rec_message () then             /* Get a packet. */
      return (state_a);

   select (rec_pkt_type);

      when (msg_snd_init)
         if rec_seq = mod (msg_number - 1, 64) then
            do;
               if ^bump_retry () then
                  return (state_a);
               call ack_send_init;
               return (state);
            end;
         else
            do;
               snd_msg = 'Protocol error detected.';
               call send_packet (msg_error, length (snd_msg), msg_number);
               return (state_a);
            end;

      when (msg_file)
         do;
            if rec_seq ^= msg_number then
               do;
                  snd_msg = 'Protocol error detected.';
                  call send_packet (msg_error, length (snd_msg), msg_number);
                  return (state_a);
               end;

            if path_name = '' then   /* Get the pathname from the packet. */
               do;
                  if single_file_rec then
                     do;
                        snd_msg = 'Error : only ONE file upload allowed.';
                        call send_packet (msg_error, length (snd_msg), msg_number);
                        return (state_a);
                     end;

                  path_name = substr (rec_msg, pkt_msg, length (rec_msg) - pkt_msg);
                  path_name = trim (set8str (path_name), '11'b);

                  /* The pathname may have repeat character processing in it,
                     so we must handle this. 8-bit quoting and control quoting
                     are not allowed in path names, and so will be caught
                     later on. */

                  if do_repeats then
                     if index (path_name, loc_rep_chr) ^= 0 then
                        do;
                           new_path = '';

                           do i = 1 to length (path_name);
                              chr = substr (path_name, i, 1);

                              if chr = loc_rep_chr then
                                 do;
                                    i = i + 1;
                                    rep_count = knum (substr (path_name, i, 1));

                                    i = i + 1;
                                    chr = substr (path_name, i, 1);
                                 end;
                              else
                                 rep_count = 1;

                              do temp = 1 to rep_count;
                                 new_path = new_path || chr;
                              end;

                           end;

                           path_name = new_path;

                        end;

                  call set_path (path_name);

               end;

            i = open_output ();      /* Open the file for writing. */

            select (i);

               when (0)
                  snd_msg = '';

               when (e$exst)
                  do;            /* Acknowldege with our new file name. */
                     snd_msg = file_name;
                     call log_info ('File already exists. New file name is ' || file_name || '.');
                  end;

               when (e$bnam)
                  do;
                     snd_msg = file_name;
                     call log_info ('The file name is illegal, ' || file_name || ' will be used instead.');
                  end;

               when (e$ialn)
                  do;
                     snd_msg = 'File already exists. Unable to generate a new file name!';
                     call send_packet (msg_error, length (snd_msg), msg_number);
                     return (state_a);
                  end;

               otherwise
                  do;
                     call get_error_msg (i);
                     snd_msg = 'Error opening file on remote system. ' || errmsg;
                     call send_packet (msg_error, length (snd_msg), msg_number);
                     return (state_a);
                  end;
            end;

            if explicit_ft_set then
               do;
                  rec_file_type = file_type;

                  if log_opened then
                     do;
                        errmsg = 'The receiving file type has been explicitly set to ';

                        select (file_type);

                           when (ascii_ft)
                              errmsg = errmsg || 'ASCII.';

                           when (binary_ft)
                              errmsg = errmsg || 'BINARY.';

                           when (automatic_ft)      /* ? - This can't be! */
                              errmsg = errmsg || 'AUTOMATIC.';

                           otherwise                /* And what's this ? */
                              errmsg = errmsg || 'ILLEGAL.';

                        end;

                        call log_info ((errmsg));
                     end;
               end;
            else
               do;
                  rec_file_type = automatic_ft;
                  file_type = ascii_ft;       /* Assume this to start with. */

                  if log_opened then
                     do;
                        call log_info ('The receiving file type will be automatically detected.');
                        call log_info ('But ASCII file type will initially be assumed.');
                     end;
               end;

            call send_packet (msg_ack, length (snd_msg), msg_number);  /* ACK file header packet. */
            num_retries = 0;
            msg_number = mod (msg_number + 1, 64);

            if loc_file_attrib then    /* Get the file attributes if we can. */
               return (state_ra);
            else
               if do_windowing then
                  do;
                     tab_first = msg_number;
                     tab_next = tab_first;
                     do_flush = false;
                     return (state_rdw);
                  end;
               else
                  return (state_rd);
         end;

      when (msg_eof)
         if rec_seq = mod (msg_number - 1, 64) then
            do;
               if ^bump_retry () then
                  return (state_a);
               call send_packet (msg_ack, 0, rec_seq);
               return (state);
            end;
         else
            do;
               snd_msg = 'Protocol error detected.';
               call send_packet (msg_error, length (snd_msg), msg_number);
               return (state_a);
            end;

      when (msg_break)
         do;
            call send_packet (msg_ack, 0, rec_seq);
            return (state_c);
         end;

      when (msg_error)
         return (state_a);

      otherwise
         do;
            snd_msg = 'Unexpected packet type "' || rec_pkt_type || '" received on remote system.';
            call send_packet (msg_error, length (snd_msg), msg_number);
            return (state_a);
         end;

   end;      /* Select */

   end;    /* Rec_file */

/* ****************************** Rec_attrib ******************************* */

Rec_attrib : proc returns (fixed bin);

Dcl avail_disk_space fixed bin (31),
    code fixed bin,
    1 quota_info,
      2 (record_size, dir_used, max_quota, quota_used) fixed bin (31),
      2 (duff1, duff2, duff3, duff4) fixed bin (31),
    inf_array (8) fixed bin (31) based;

/* ************************************************************************* */

   if ^rec_message () then                 /* Get a packet. */
      return (state_a);

   select (rec_pkt_type);

      when (msg_attrib)
         do;
            call q$read (dir_name, addr (quota_info) -> inf_array, 4, temp, code);
            if code ^= 0 | temp = 1 then
               avail_disk_space = -1;
            else
               do;
                  avail_disk_space = quota_info.max_quota - quota_info.quota_used;
                  if quota_info.record_size ^= 1024 then
                     avail_disk_space = divide ((avail_disk_space * quota_info.record_size) + 1023, 1024, 31);
               end;

            call decode_attrs;

            if avail_disk_space = -1 | rec_file_size <= 0 | rec_file_size <= avail_disk_space then
               snd_msg = 'Y';
            else               /* ONLY reject the file if we run out of room. */
               do;
                  call discard_output (temp);

                  if fs_attr_type = 0 then
                     snd_msg = 'N!';
                  else
                     snd_msg = 'N1';
               end;

            if rec_file_dtc = 0 then
               snd_msg = snd_msg || '#';

            if file_type = illegal_ft then
               do;
                  rec_file_type = automatic_ft;
                  file_type = ascii_ft;  /* Reset this, but let the other side know. */
                  snd_msg = snd_msg || '"';
               end;

            call send_packet (msg_ack, length (snd_msg), rec_seq);
            num_retries = 0;
            msg_number = mod (msg_number + 1, 64);
            if substr (snd_msg, 1, 1) = 'N' then
               call log_info ('Unable to receive the file ' || file_name || '. File too big.');
            return (state);
         end;

      when (msg_data)
         do;
            if rec_seq ^= msg_number then    /* Out of sequence messages. */
               if rec_seq = mod (msg_number - 1, 64) then
                  do;
                     if ^bump_retry () then
                        return (state_a);
                     call send_packet (msg_ack, 0, rec_seq);
                     return (state);
                  end;
               else
                  do;
                     snd_msg = 'Protocol error detected.';
                     call send_packet (msg_error, length (snd_msg), msg_number);
                     return (state_a);
                  end;

            temp = write_output ();
            if temp ^= 0 then
               do;
                  call get_error_msg (temp);
                  snd_msg = 'Unable to write to output file. ' || errmsg;
                  call send_packet (msg_error, length (snd_msg), msg_number);
                  return (state_a);
               end;

            call send_packet (msg_ack, 0, rec_seq);
            num_retries = 0;
            msg_number = mod (msg_number + 1, 64);

            if do_windowing then
               do;
                  tab_first = msg_number;
                  tab_next = tab_first;
                  do_flush = false;
                  return (state_rdw);
               end;
            else
               return (state_rd);

         end;

      when (msg_file)
         if rec_seq = mod (msg_number - 1, 64) then
            do;
               if ^bump_retry () then
                  return (state_a);
               call send_packet (msg_ack, 0, rec_seq);
               return (state);
            end;
         else
            do;
               snd_msg = 'Protocol error detected.';
               call send_packet (msg_error, length (snd_msg), msg_number);
               return (state_a);
            end;

      when (msg_eof)
         if rec_seq = msg_number then
            do;
               i = close_output ();
               call set_path ('');    /* Knock out the file_name for later. */
               if i ^= 0 then
                  do;
                     call get_error_msg (i);
                     snd_msg = 'Unable to close output file on remote system. ' || errmsg;
                     call send_packet (msg_error, length (snd_msg), msg_number);
                     return (state_a);
                  end;

               call send_packet (msg_ack, 0, rec_seq);
               num_retries = 0;
               msg_number = mod (msg_number + 1, 64);

               return (state_rf);
            end;
         else
            do;
               snd_msg = 'Protocol error detected.';
               call send_packet (msg_error, length (snd_msg), msg_number);
               return (state_a);
            end;

      when (msg_error)
         return (state_a);

      otherwise
         do;
            snd_msg = 'Unexpected packet type "' || rec_pkt_type || '" received on remote system.';
            call send_packet (msg_error, length (snd_msg), msg_number);
            return (state_a);
         end;

   end;         /* select */

   end;     /* Rec_attrib */

/* ******************************** Rec_data ******************************* */

Rec_data : proc returns (fixed bin);

/* ************************************************************************* */

   if ^rec_message () then             /* Get a packet. */
      return (state_a);

   select (rec_pkt_type);

      when (msg_data)
         do;
            if rec_seq ^= msg_number then    /* Out of sequence messages. */
               do;
                  if rec_seq = mod (msg_number - 1, 64) then
                     do;
                        if ^bump_retry () then
                           return (state_a);
                        call send_packet (msg_ack, 0, rec_seq);
                        return (state);
                     end;
                  else
                     do;
                        snd_msg = 'Protocol error detected.';
                        call send_packet (msg_error, length (snd_msg), msg_number);
                        return (state_a);
                     end;
               end;

            temp = write_output ();
            if temp ^= 0 then
               do;
                  call get_error_msg (temp);
                  snd_msg = 'Unable to write to output file. ' || errmsg;
                  call send_packet (msg_error, length (snd_msg), msg_number);
                  return (state_a);
               end;

            call send_packet (msg_ack, 0, rec_seq);
            num_retries = 0;
            msg_number = mod (msg_number + 1, 64);
            return (state_rd);
         end;

      when (msg_file)
        if rec_seq = mod (msg_number - 1, 64) then
           do;
              if ^bump_retry () then
                  return (state_a);
              call send_packet (msg_ack, 0, rec_seq);
              return (state);
           end;
        else
           do;
              snd_msg = 'Protocol error detected.';
              call send_packet (msg_error, length (snd_msg), msg_number);
              return (state_a);
           end;

      when (msg_eof)
         do;
            if length (rec_msg) > pkt_msg then
               rec_msg = substr (rec_msg, pkt_msg, 1);
            else
               rec_msg = '';

            if rec_msg = 'D' then
               call discard_output (i);
            else
               i = close_output ();

            call set_path ('');         /* Do this for later. */

            if i ^= 0 then
               do;
                  call get_error_msg (i);
                  if rec_msg = 'D' then
                     snd_msg = 'Unable to discard the output file on remote system. ' || errmsg;
                  else
                     snd_msg = 'Unable to close output file on remote system. ' || errmsg;
                  call send_packet (msg_error, length (snd_msg), msg_number);
                  return (state_a);
               end;

            call send_packet (msg_ack, 0, rec_seq);
            num_retries = 0;
            msg_number = mod (rec_seq + 1, 64);
            return (state_rf);
         end;

      when (msg_error)
         return (state_a);

      otherwise
         do;
            snd_msg = 'Unexpected packet type "' || rec_pkt_type || '" received on remote system.';
            call send_packet (msg_error, length (snd_msg), msg_number);
            return (state_a);
         end;

   end;        /* select */

   end;     /* Rec_data */

/* ***************************** Rec_windowing ***************************** */

Rec_windowing : proc returns (fixed bin);

/* ************************************************************************* */

   call rec_packet;             /* Get input. */

   select (rec_pkt_type);

      when (msg_data)
         if ^between (rec_seq, tab_first, mod (tab_first + 2 * window_size - 1, 64)) then
            return (state);
         else
            do;
               call update_table;
               num_retries = 0;
               return (state);
            end;

      when (msg_check_err)
         do;          /* NAK for oldest unACKed entry in table. */
            call log_info ('Checksum error : NAK for oldest unACKed packet.');
            call nak_oldest (false);
            return (state);
         end;

      when (msg_eof)
         do;
            do_flush = true;
            if length (rec_msg) > pkt_msg then
               rec_msg = substr (rec_msg, pkt_msg, 1);
            else
               rec_msg = '';

            if rec_msg = 'D' then
               call discard_output (i);
            else
               do;
                  if ^flush_table ()  then
                     return (state_a);

                  i = close_output ();
               end;

            call set_path ('');             /* Do this for later. */

            if i ^= 0 then
               do;
                  call get_error_msg (i);
                  if rec_msg = 'D' then
                     snd_msg = 'Unable to discard the output file on remote system. ' || errmsg;
                  else
                     snd_msg = 'Unable to close output file on remote system. ' || errmsg;
                  call send_packet (msg_error, length (snd_msg), msg_number);
                  return (state_a);
               end;

            call send_packet (msg_ack, 0, rec_seq);
            msg_number = mod (rec_seq + 1, 64);
            return (state_rf);

         end;

      when (msg_error)
         return (state_a);

      when (msg_timeout)
         if num_retries > max_retries then
            do;
               snd_msg = 'Retry count exceeded on remote system.';
               call send_packet (msg_error, length (snd_msg), msg_number);
               return (state_a);
            end;
         else
            do;
               call log_info ('Timeout : NAK for most desired packet.');
               call nak_oldest (true);
               return (state);
            end;

      otherwise
         do;
            snd_msg = 'Unexpected packet type "' || rec_pkt_type || '" received on remote system.';
            call send_packet (msg_error, length (snd_msg), msg_number);
            return (state_a);
         end;

   end;      /* Select */

   end;   /* Rec_windowing */

/* ****************************** Rec_message ****************************** */

Rec_message : proc returns (bit (1) aligned);

/* ************************************************************************* */

   test_flag = false;

   do until (test_flag);

      call rec_packet;

      if rec_pkt_type = msg_timeout | rec_pkt_type = msg_check_err then
         do;
            if ^bump_retry () then
               return (false);
            call send_packet (msg_nak, 0, msg_number);
            num_retries = num_retries + 1;
         end;
      else
         test_flag = true;
   end;

   return (true);

   end;       /* Rec_message */

/* ***************************** Update_table ****************************** */

Update_table : proc;

Dcl save_msg char (max_msg) var;

/* ************************************************************************* */

   /* Make room in the table if necessary. */

   if between (rec_seq, mod (tab_first + window_size, 64), mod (tab_first - 1, 64)) then
      do;
         save_msg = rec_msg;

         i = tab_first;      /* Write the old table entries to the file. */
         do while (mod (i + window_size - 1, 64) ^= rec_seq);
            if ^msg_table.slot(i).acked then
               do;
                  snd_msg = 'Protocol error : receive table overrun.';
                  call send_packet (msg_error, length (snd_msg), msg_number);
                  state = state_a;
                  return;
               end;

            rec_msg = msg_table.slot(i).msg;

            temp = write_output ();
            if temp ^= 0 then
               do;
                  call get_error_msg (temp);
                  snd_msg = 'Unable to write to output file. ' || errmsg;
                  call send_packet (msg_error, length (snd_msg), msg_number);
                  state = state_a;
                  return;
               end;

            i = mod (i + 1, 64);
            tab_first = i;
         end;

         rec_msg = save_msg;          /* Restore rec_msg. */

      end;

   msg_table.slot(rec_seq).msg = rec_msg;   /* Add the new data packet to the table. */
   msg_table.slot(rec_seq).acked = true;
   msg_table.slot(rec_seq).retries = 0;

/* Clear the acked bit on any skipped pkts */

   if between (rec_seq, mod (tab_next + 1, 64), mod (tab_first - 1, 64)) then
      do;
         i = tab_next;
         do while (i ^= rec_seq);
            msg_table.slot(i).acked = false;
            msg_table.slot(i).retries = 0;
            call send_packet (msg_nak, 0, i);    /* NAK for the packet. */
            i = mod (i + 1, 64);
         end;
      end;

   if between (rec_seq, tab_next, mod (tab_first - 1, 64)) then
      do;             /* Update TAB_NEXT to be the next packet expected. */
         tab_next = mod (rec_seq + 1, 64);
         msg_number = tab_next;
      end;

   call send_packet (msg_ack, 0, rec_seq);    /* Acknowledge the packet. */

   return;

   end;      /* Update_table */

/* ****************************** Flush_table ****************************** */

Flush_table : proc returns (bit (1) aligned);

/* ************************************************************************* */

   i = tab_first;  /* Write the remainder of the receive table to the file. */

   do while (i ^= tab_next);
      if ^msg_table.slot(i).acked then
         do;
            snd_msg = 'Unacknowledged data packet when flushing table.';
            call send_packet (msg_error, length (snd_msg), msg_number);
            state = state_a;
            return (false);
         end;

      rec_msg = msg_table.slot(i).msg;

      temp = write_output ();
      if temp ^= 0 then
         do;
            call get_error_msg (temp);
            snd_msg = 'Unable to write to output file. ' || errmsg;
            call send_packet (msg_error, length (snd_msg), msg_number);
            state = state_a;
            return (false);
         end;

      i = mod (i + 1, 64);
   end;

   return (true);

   end;      /* Flush_table */

/* ****************************** Nak_oldest ******************************* */

Nak_oldest : proc (desire);

Dcl desire bit (1) aligned;

/* ************************************************************************* */

   i = tab_first;

   do until (i = tab_next);
      if ^msg_table.slot(i).acked then
         do;
            call send_packet (msg_nak, 0, i);
            return;
         end;

      i = mod (i + 1, 64);
   end;

   /* No packets to NAK, so NAK for next in hope of unblocking
      sender if a NAK for the most desired packet is required. */

   if desire then
      call send_packet (msg_nak, 0, tab_next);

   return;

   end;      /* Nak_oldest */

/* ******************************* Bump_retry ****************************** */

Bump_retry : proc returns (bit (1) aligned);

/* ************************************************************************* */

   if num_retries > max_retries then
      do;
         snd_msg = 'Retry limit exceeded on remote system.';
         call send_packet (msg_error, length (snd_msg), msg_number);
         state = state_a;
         return (false);
   end;

   num_retries = num_retries + 1;

   return (true);

   end;          /* Bump_retry */

/* ****************************** Decode_attrs ***************************** */

Decode_attrs : proc;

Dcl (str, data) char (max_msg) var,
    attr char (1),
    (len, found, code) fixed bin;

/* ************************************************************************* */

   rec_file_size = -1;    /* -1 = Unknown, 0 = Illegal, > 0 = Legal value. */
   rec_file_dtc = -1;

   found = 0;
   str = substr (rec_msg, pkt_msg, length (rec_msg) - pkt_msg);
   str = set8str (str);

   do while (length (str) > 0 & found < 5);

      attr = substr (str, 1, 1);

      len = knum (substr (str, 2, 1));

      data = substr (str, 3, len);
      str = substr (str, len + 3);

      select (attr);

         when ('!')             /* File size in Kbytes. */
            do;
               fs_attr_type = 0;
               rec_file_size = bin (trim (data, '11'b), 31);
            end;

         when ('1')             /* File size in bytes. */
            do;
               fs_attr_type = 1;
               rec_file_size = bin (trim (data, '11'b), 31);
               rec_file_size = divide (rec_file_size + 1023, 1024, 31);
            end;

         when ('#')             /* Date/Time file created. */
            do;
               if substr (data, 1, 2) = '19' then
                  data = substr (data, 3);    /* Knock off the century. */

               data = substr (data, 1, 2) || '-' || substr (data, 3, 2) ||
                      '-' || substr (data, 5, 2) || '.' || after (data, ' ');

               call cv$dtb (data, rec_file_dtc, code);
               if code ^= 0 then
                  rec_file_dtc = 0;

            end;

         when ('.')             /* Machine and OS. */
            if ^explicit_pound_set & (data = 'U8' | substr (data, 1, 1) = 'K') then
               pound_conversion = true;    /* U8 = MS-DOS, K = Atari. */

         when ('"')             /* Indication of file type. */
            if ^explicit_ft_set then     /* Might as well use this if we can. */
               do;
                  select (substr (data, 1, 1));

                     when ('A')
                        do;
                           rec_file_type = ascii_ft;    /* ASCII file. */
                           call log_info ('The received file type attribute is ASCII, this file type will be used.');
                        end;

                     when ('B')
                        do;
                           rec_file_type = binary_ft;   /* BINARY file. */
                           call log_info ('The received file type attribute is BINARY, this file type will be used.');
                        end;

                     when ('I')
                        do;
                           rec_file_type = binary_ft;   /* IMAGE file (BINARY). */
                           call log_info ('The received file type attribute is IMAGE, but BINARY file type will be used.');
                        end;

                     otherwise
                        do;
                           rec_file_type = illegal_ft;  /* ILLEGAL file type. */
                           call log_info ('The received file type attribute is ILLEGAL.');
                           call log_info ('The file type will be automatically detected, but ASCII will initially be used.');
                        end;

                  end;

                  file_type = rec_file_type;

               end;

         otherwise
            found = found - 1;        /* Didn't find one we wanted. */

      end;

      found = found + 1;        /* Assume that we did find one. */

   end;

   return;

   end;          /* Decode_attrs */

   end;       /* Rec_switch */
-------------------------------------------------------------------------------

/* REN_HNDLR -- On_unit for returning after a PUSH. */

Ren_hndlr : proc (dummy);

Dcl dummy ptr;

$Insert *>insert>common.ins.plp

/* ************************************************************************* */

   /* "ren_lbl" is a label variable which is set to a local label
      in COMND. This enables us to create the on-unit once at startup
      yet have it return to a sub-procedure when the condition arises.
   */

   goto ren_lbl;

   end;       /* Ren_hndlr */
-------------------------------------------------------------------------------

/* SEND_PACKET -- Send Kermit packet to user. */

Send_packet : proc (type, pkt_len, seq_num);

Dcl type        char (1),    /* Type of packet to send. */
    pkt_len     fixed bin,   /* Length of packet to send. */
    seq_num     fixed bin;   /* Sequence number of packet. */

$Insert *>insert>common.ins.plp
$Insert *>insert>kermit.ins.plp
$Insert *>insert>primos.ins.plp
$Insert *>insert>constants.ins.plp
$Insert syscom>keys.ins.pl1

Dcl msg char (max_msg) var,
    (temp, msg_length, chksum) fixed bin;

/* ************************************************************************* */

   if rem_npad > 0 then          /* Do any packet filling required. */
      call tnoua (rem_pad_chars, rem_npad);

   /* Store the header information into the message. */

   char2_ptr -> fb15_based = pkt_len + pkt_ovr_head + 32;
   msg = ctrl_a_8bit_asc || char2(2);

   char2_ptr -> fb15_based = seq_num + 32;
   msg = msg || char2(2) || type;

   if pkt_len ^= 0 then
      msg = msg || snd_msg;

   msg_length = length (msg);

   if do_transparent then   /* If transparent, then clear all the high bits. */
      do;
         if type = msg_data then
            temp = pkt_type;
         else
            temp = msg_length;

         substr (msg, 1, temp) = clr8str (substr (msg, 1, temp));
      end;

   temp = 0;               /* Do the initial checksum calculation. */
   if do_8bit_chks then
      temp = 1;

   chksum = chks (temp, msg);

   char2_ptr -> fb15_based = chksum + 32;
   msg = msg || char2(2) || rem_eol;

   msg_length = msg_length + 2;

   if do_flush then            /* Flush the input buffer. */
      call tty$rs (k$inb, temp);

   call tnoua ((msg), msg_length);           /* Now send the message. */

   if log_opened then                 /* Log the packet if necessary. */
      do;
         if pkt_len = 0 then
            msg = '';
         else
            msg = snd_msg;

         call log_packet (type, seq_num, msg);
      end;

   return;

   end;         /* Send_packet */
-------------------------------------------------------------------------------

/* SEND_SWITCH -- Handles Kermit file send protocol. */

Send_switch : proc;

$Insert *>insert>common.ins.plp
$Insert *>insert>kermit.ins.plp
$Insert *>insert>primos.ins.plp
$Insert *>insert>constants.ins.plp

Dcl (stop_xfer, stop_trans, test_flag) bit (1) aligned,
    (code, temp) fixed bin;

/* ************************************************************************* */

   num_retries = 0;                 /* Initialize number of retries. */
   msg_number = 0;                  /* Initial message number. */
   do_flush = true;
   test_flag = false;

   if log_opened then
      do;
         call log_info ('');
         call log_info (kversion || ' sending ' || path_name || '.');
      end;

   if delay ^= 0 then                   /* Sleep if we need to. */
      call sleep$ (1000 * delay);

   do until (test_flag);

      select (state);

         when (state_s, state_x)
            state = send_init ();

         when (state_sf, state_xf)
            state = send_file ();

         when (state_sa)
            state = send_attrib ();

         when (state_sd)
            state = send_data ();

         when (state_sdw)
            state = send_windowing ();

         when (state_sz)
            state = send_eof ();

         when (state_sb)
            state = send_break ();

         when (state_c)
            test_flag = true;

         otherwise               /* Includes state_a. */
            do;
              do_flush = true;
              test_flag = true;
              if file_opened then
                 call close_input;
            end;

      end;      /* select */

   end;      /* loop */

   return;

/* ****************************** Send_init ******************************** */

Send_init : proc returns (fixed bin);

Dcl eol_bin fixed bin,
    eol char (1);

/* ************************************************************************* */

   /* setup our send_init parameters. */

   char2(1) = nul_7bit_asc;
   char2(2) = loc_eol;
   char2_ptr -> fb15_based = char2_ptr -> fb15_based + 32;   /* Set the printable bit. */
   eol = char2(2);

   eol_bin = loc_pkt_size + 32;
   temp = loc_timeout + 32;

   snd_msg = substr (addr (eol_bin) -> char2_based, 2, 1) ||
             substr (addr (temp) -> char2_based, 2, 1);

   eol_bin = loc_npad + 32;
   temp = loc_capas1 + 32;

   snd_msg = snd_msg || substr (addr (eol_bin) -> char2_based, 2, 1) ||
             ctl (loc_padchar) || eol || loc_quote_chr || loc_8quote_chr ||
             loc_chk_type || loc_rep_chr || substr (addr (temp) -> char2_based, 2, 1);

   temp = loc_max_wsize + 32;
   snd_msg = snd_msg || substr (addr (temp) -> char2_based, 2, 1);

   loc_file_attrib = addr (loc_capas1) -> capas.file_attributes;
   loc_windowing = addr (loc_capas1) -> capas.windowing;

   call send_packet (msg_snd_init, length (snd_msg), msg_number);  /* Send the packet. */

   if ^get_response () then          /* Get a response from the remote side. */
      return (state);

   call prs_send_init;           /* Process ACK response. */
   call set_params;

   if state = state_x then  /* Text transfer : the file is already open. */
      return (state_xf);

   temp = match_file ();
   if temp ^= 0 then
      do;
         call get_error_msg (temp);
         snd_msg = 'Unable to match files on remote system. ' || errmsg;
         call send_packet (msg_error, length (snd_msg), msg_number);
         return (state_a);
      end;

   if num_matches = 0 then           /* Check for no matching files. */
      do;
         snd_msg = 'No matching files on remote system.';
         call send_packet (msg_error, length (snd_msg), msg_number);
         return (state_a);
      end;

   file_idx = 1;           /* Send the first file. */

   return (state_sf);

   end;             /* Send_init */

/* ******************************* Send_file ******************************* */

Send_file : proc returns (fixed bin);

Dcl test_flag bit (1) aligned;

/* ************************************************************************* */

   stop_xfer = false;       /* Initialize the file interrupt flags. */
   stop_trans = false;
   first_read = true;       /* Say that this is the first read of the file. */
   test_flag = true;

   if state = state_sf then      /* File transfer : send the file name. */
      if next_file () ^= ker_normal then
         return (state_sb);
      else
         snd_msg = clr8str (file_name);

   do while (test_flag);

      if state = state_sf then
         call send_packet (msg_file, length (file_name), msg_number);
      else
         call send_packet (msg_text, 0, msg_number);

      if ^get_response () then      /* Get a response from the remote side. */
         if state = state_a then
            return (state_a);
         else
            ;
      else
         test_flag = false;

   end;

   if log_opened then        /* See if our file name was acceptable. */
      do;
         temp = length (rec_msg);
         if temp > pkt_msg then
            call log_info ('The file will be received as ' || substr (rec_msg, pkt_msg, temp - pkt_msg) || '.');
      end;

   call setup_trans_char;    /* Setup the character translation table. */

   /* If this is a file transfer, and attributes are expected, send them. */

   if (state = state_sf) & rem_file_attrib then
      return (state_sa);

   if do_windowing then             /* Otherwise, transmit the data. */
      do;
         tab_first = msg_number;
         tab_next = msg_number;
         do_flush = false;
         return (state_sdw);
      end;
   else
      return (state_sd);

   end;         /* Send_file */

/* ****************************** Send_attrib ****************************** */

Send_attrib : proc returns (fixed bin);

Dcl test_flag bit (1) aligned;

/* ************************************************************************* */

   test_flag = true;

   call get_attr;            /* Form the attribute packet. */

   do while (test_flag);     /* Send the data packet. */

      call send_packet (msg_attrib, length (snd_msg), msg_number);

      if ^get_response () then    /* Get a response from the remote side. */
         if state = state_a then
            return (state_a);
         else
            ;
      else
         test_flag = false;
   end;

   if length (rec_msg) > pkt_msg then
      rec_msg = substr (rec_msg, pkt_msg, 1);
   else
      rec_msg = '';

   if rec_msg = 'N' then      /* We cannot send this file for some reason. */
      do;
         stop_xfer = true;
         return (state_sz);
      end;

   return (state_sd);  /* Send the first data packet (always non-windowing). */

   end;     /* Send_attrib */

/* ******************************* Send_data ******************************* */

Send_data : proc returns (fixed bin);

Dcl status fixed bin,
    test_flag bit (1) aligned;

/* ************************************************************************* */

   test_flag = true;

   status = read_input (code);      /* Get the next buffer of data. */

   select (status);

      when (ker_normal)
         ;

      when (ker_eof)
         return (state_sz);

      otherwise
         do;
            call get_error_msg (code);
            snd_msg = 'Error reading file on remote system. ' || errmsg;
            call send_packet (msg_error, length (snd_msg), msg_number);
            return (state_a);
         end;
   end;

   do while (test_flag);      /* Send the data packet. */

      call send_packet (msg_data, length (snd_msg), msg_number);

      if ^get_response () then    /* Get the response from the remote side. */
         if state = state_a then
            return (state_a);
         else
            ;
      else
         test_flag = false;
   end;

   if length (rec_msg) > pkt_msg then    /* Check for file transfer interruption. */
      rec_msg = substr (rec_msg, pkt_msg, 1);
   else
      rec_msg = '';

   stop_xfer = (rec_msg = 'X');
   stop_trans = (rec_msg = 'Z');

   if stop_xfer | stop_trans then
      return (state_sz);

   if do_windowing then  /* If we are windowing, then change to SDW state. */
      do;
         tab_first = msg_number;
         tab_next = msg_number;
         do_flush = false;
         return (state_sdw);
      end;
   else
      return (state_sd);

   end;            /* Send_data */

/* ***************************** Send_windowing **************************** */

Send_windowing : proc returns (fixed bin);

Dcl status fixed bin;

/* ************************************************************************* */

   status = read_input (code);   /* Get the next buffer of data. */

   select (status);

      when (ker_normal)
         ;

      when (ker_eof)
         if ^prs_input (true) then
            return (state_a);
         else
            return (state_sz);

      otherwise
         do;
            call get_error_msg (code);
            snd_msg = 'Error reading file on remote system. ' || errmsg;
            call send_packet (msg_error, length (snd_msg), msg_number);
            return (state_a);
         end;
   end;

   msg_table.slot(msg_number).msg = snd_msg;       /* Update the table. */
   msg_table.slot(msg_number).acked = false;
   msg_table.slot(msg_number).retries = 0;

   call send_packet (msg_data, length (snd_msg), msg_number);   /* Send the data packet. */

   msg_number = mod (msg_number + 1, 64);   /* Increment the message number. */
   tab_next = msg_number;

   if ^prs_input (false) then     /* Get a response from the remote side. */
      return (state_a);

   if stop_xfer | stop_trans then  /* Check for file transfer interruption. */
      return (state_sz);

   return (state_sdw);

   end;               /* Send_windowing */

/* ******************************* Send_eof ******************************** */

Send_eof : proc returns (fixed bin);

/* ************************************************************************* */

   do_flush = true;         /* Start flushing input before each output. */

   call close_input;

   if stop_xfer | stop_trans then  /* Check for file transfer interruption. */
      do;
         call log_info ('File transfer interrupted.');

         snd_msg = 'D';           /* Discard indication. */
         msg_number = mod (rec_seq + 1, 64);       /* Reset sequence number. */
         call sleep$ (5000); /* Wait 5 secs to allow receiver to flush input. */
         call send_packet (msg_eof, length (snd_msg), msg_number);
      end;
   else
      call send_packet (msg_eof, 0, msg_number); /* Normal EOF : send end-of-file indicator packet. */

   if ^get_response () then       /* Get a response from the remote side. */
      return (state);

   if stop_trans then
      return (state_sb);

   return (state_sf);

   end;           /* Send_eof */

/* ******************************* Send_break ****************************** */

Send_break : proc returns (fixed bin);

/* ************************************************************************* */

   call send_packet (msg_break, 0, msg_number); /* Send end-of-file-set indicator packet. */

   if ^get_response () then    /* Get a response from the remote side. */
      return (state);

   return (state_c);

   end;            /* Send_break */

/* ****************************** Get_response ***************************** */

Get_response : proc returns (bit (1) aligned);

Dcl fail bit (1) aligned;

/* ************************************************************************* */

   fail = false;

   call rec_packet;    /* Get a packet from the remote side. */

   select (rec_pkt_type);          /* Check the packet type. */

      when (msg_timeout, msg_check_err)        /* Timeout. */
         fail = true;

      when (msg_ack)                           /* ACK type. */
         if rec_seq ^= msg_number then
            fail = true;

      when (msg_nak)                           /* NAK type. */

              /* Treat an ACK to packet n+1 as an ACK of packet n.
                 This covers the case when the ACK to packet n is lost, and the
                 remote later sends a NAK. Any other NAKs cause a retransmit. */

         if rec_seq ^= mod (msg_number + 1, 64) then
            fail = true;

      when(msg_error)                          /* Error type. */
         do;
            state = state_a;
            return (false);
         end;

      otherwise
         do;
            snd_msg = 'Unexpected packet type "' || rec_pkt_type || '" received on remote system.';
            call send_packet (msg_error, length (snd_msg), msg_number);
            state = state_a;
            return (false);
         end;
   end;       /* Select */

   if ^fail then          /* A good response. */
      do;
         num_retries = 0;
         msg_number = mod (msg_number + 1, 64);
         return (true);
      end;

   if num_retries > max_retries then         /*  No response ? */
      do;
         num_retries = 0;
         snd_msg = 'Retry limit exceeded on remote system.';
         call send_packet (msg_error, length (snd_msg), msg_number);
         state = state_a;
      end;
   else
      num_retries = num_retries + 1;

   return (false);

   end;             /* Get_response */

/* ******************************* Prs_input ******************************* */

Prs_input : proc (eof) returns (bit (1) aligned);

Dcl eof bit (1) aligned;

Dcl i fixed bin;

/* ************************************************************************* */

Get_pkt :

   if eof then   /* Wait for a packet until all are acknowledged. */
      if tab_first = tab_next then
         return (true);
      else
         goto rec_pkt;

   /* If the window is not blocked, make sure there is input. */

   if tab_next ^= mod (tab_first + window_size, 64) then
      if ^tty$in () then
          return (true);
      else
         goto rec_pkt;

   /* Window is blocked : Check for special case. */

   if msg_table.slot(tab_first).retries = 0 then
      do;
         i = mod (tab_first + 1, 64);    /* If some later packet has been received,
                                            then resend earliest one. */

         do while (i ^= mod (tab_first + window_size, 64));
            if msg_table.slot(i).acked then
               do;
                  i = tab_first;
                  call log_info ('Resend - window blocked.');
                  goto resend;
               end;
            i = mod (i + 1, 64);
         end;
      end;

Rec_pkt :                /* Receive a packet from the remote side. */

   call rec_packet;

   select (rec_pkt_type);          /* Check the packet type. */

      when (msg_timeout)
         do;
            i = tab_first;         /* Resend oldest unacked packet. */
            do while (msg_table.slot(i).acked);
               i = mod (i + 1, 64);
               if i = tab_next then
                  return (true);
            end;

            call log_info ('Resend - timeout.');
         end;

      when (msg_check_err)
         do;
            call log_info ('Checksum error - ignore packet.');
            goto get_pkt;
         end;

      when (msg_ack)
         do;               /* Check for ACK/Interrupt packets. */
            if length (rec_msg) > pkt_msg then
               rec_msg = set8 (substr (rec_msg, pkt_msg, 1));
            else
               rec_msg = '';

            stop_xfer = (rec_msg = 'X');
            stop_trans = (rec_msg = 'Z');

            if stop_xfer | stop_trans then
               return (true);

        /* If the ACK is within bounds, process it. */

            if between (rec_seq, tab_first, mod (tab_next - 1, 64)) then
               do;
                  msg_table.slot(rec_seq).acked = true;
                  i = tab_first;

                  do while (msg_table.slot(i).acked);
                     i = mod (i + 1, 64);
                     if i = tab_next then
                        leave;
                  end;

                  tab_first = i;
               end;

            goto get_pkt;

         end;

      when (msg_nak)
         do;

                /* If the NAK is within window, resend requested packet,
                   otherwise resend earliest, hoping for an ACK. */

            if between (rec_seq, tab_first, mod (tab_next - 1, 64)) then
               do;
                  call log_info ('NAK - resend packet.');
                  i = rec_seq;
               end;
            else
               do;
                  call log_info ('NAK - resend earliest packet.');
                  i = tab_first;
               end;
         end;

      when (msg_error)
         do;                 /* Error type. */
            state = state_a;
            return (false);
         end;

      otherwise
         do;
            snd_msg = 'Unexpected packet type "' || rec_pkt_type || '" received on remote system.';
            call send_packet (msg_error, length (snd_msg), msg_number);
            state = state_a;
            return (false);
         end;
   end;        /* Select */

Resend :                   /* Resend the packet. */

   msg_table.slot(i).acked = false;
   if msg_table.slot(i).retries > max_retries then
      do;
         snd_msg = 'Retry limit exceeded on remote system.';
         call send_packet (msg_error, length (snd_msg), msg_number);
         return (false);
      end;

   snd_msg = msg_table.slot(i).msg;
   msg_table.slot(i).retries =  msg_table.slot(i).retries + 1;
   call send_packet (msg_data, length (snd_msg), i);

   goto get_pkt;

   end;          /* Prs_input */

   end;        /* Send_switch */
-------------------------------------------------------------------------------

/* SERVER -- Kermit server process. */

Server : proc;

$Insert *>insert>common.ins.plp
$Insert *>insert>kermit.ins.plp
$Insert *>insert>constants.ins.plp

Dcl (rep_count, temp, i) fixed bin,
    new_path char (128) var,
    chr char (1);

/* ************************************************************************* */

   num_retries = 0;         /* Initialize retry count. */

   do while (true);         /* Main server loop. */

      msg_number = 0;       /* Reinitialize sequence numbering. */

      call rec_packet;      /* Get input from line. */

      select (rec_pkt_type);   /* Process message type. */

         when (msg_timeout)
            call send_packet (msg_nak, 0, msg_number);

         when (msg_init_info)
            call ack_send_init;

         when (msg_snd_init)
            do;
               call ack_send_init;
               msg_number = mod (msg_number + 1, 64);
               state = state_rf;
               call set_path ('');
               call rec_switch;
            end;

         when (msg_rcv_init)
            do;
               if rec_length > pkt_msg then
                  do;
                     path_name = set8str (substr (rec_msg, pkt_msg, length (rec_msg) - pkt_msg));
                     path_name = trim (path_name, '11'b);

                  /* The pathname may have repeat character processing in it,
                     so we must handle this. 8-bit quoting and control quoting
                     are not allowed in path names, and so will be caught
                     later on. */

                     if do_repeats then
                        if index (path_name, loc_rep_chr) ^= 0 then
                           do;
                              new_path = '';

                              do i = 1 to length (path_name);
                                 chr = substr (path_name, i, 1);

                                 if chr = loc_rep_chr then
                                    do;
                                       i = i + 1;
                                       rep_count = knum (substr (path_name, i, 1));

                                       i = i + 1;
                                       chr = substr (path_name, i, 1);
                                    end;
                                 else
                                    rep_count = 1;

                                 do temp = 1 to rep_count;
                                    new_path = new_path || chr;
                                 end;

                              end;

                              path_name = new_path;

                           end;

                     call set_path (path_name);
                  end;

               i = delay;         /* Save this old value for later. */
               delay = 0;         /* No delay time for the server. */
               state = state_s;

               call send_switch;
               delay = i;         /* Now restore the old delay time. */
            end;

         when (msg_kermit_generic)          /* Generic kermit commands. */
            if generic_cmd () = ker_exit then
               return;

      end;      /* select */

   end;      /* do while */

   return;

   end;      /* Server */
-------------------------------------------------------------------------------
/*
   This routine sets up the trans_char character translation table
   for either ASCII or binary files. the table is used to translate
   each character of file data to a representation suitable for
   transmission. The QUOTE8_CHAR determines whether the data receives
   8-bit quoting in addition to control character quoting.
*/

Setup_trans_char : proc;

$Insert *>insert>common.ins.plp
$Insert *>insert>kermit.ins.plp

Dcl (c, sq_bin, s8q_bin, rep_bin) fixed bin,
    c_ptr ptr,
    conv_chrs char (3) var,
    (sq, chr) char (1);

/* ************************************************************************* */

   c_ptr = addr (c);
   char2(1) = nul_7bit_asc;

   sq = clr8 (loc_quote_chr);      /* Control quote character. */
   char2(2) = sq;
   sq_bin = char2_ptr -> fb15_based;

   char2(2) = clr8 (quote8_char);  /* 8-bit quote character. */
   s8q_bin = char2_ptr -> fb15_based;

   char2(2) = clr8 (loc_rep_chr);  /* Repeat character prefix. */
   rep_bin = char2_ptr -> fb15_based;

   do c = 0 to 255;
      chr = substr (c_ptr -> char2_based, 2, 1);

      if (c < 32) | ((c >= 127) & (c < 160)) | (c = 255) then  /* Control chars. */
         conv_chrs = sq || ctl (chr);
      else
         if (c = sq_bin) | (c = sq_bin + 128) then  /* Control prefix. */
            conv_chrs = sq || chr;
         else
            if (quote8_char ^= 'N') & ((c = s8q_bin) | (c = s8q_bin + 128)) then
               conv_chrs = sq || chr;       /* 8-bit quote prefix. */
            else
               if do_repeats & ((c = rep_bin) | (c = rep_bin + 128)) then
                  conv_chrs = sq || chr;    /* Repeat character prefix. */
               else
                  conv_chrs = chr;  /* Normal character. */

      if (quote8_char ^= 'N') & (c >= 128) then  /* Apply 8-bit quoting. */
         trans_char(c) = quote8_char || trans_char(c - 128);
      else
         trans_char(c) = conv_chrs;

   end;

   if pound_conversion then
      trans_char(28) = trans_char(156);  /* Pound sign conversion for DOS. */

   return;

   end;       /* Setup_trans_char */
-------------------------------------------------------------------------------

/* SET_PARAMS -- determine the file transfer parameters. */

Set_params : proc;

$Insert *>insert>common.ins.plp
$Insert *>insert>kermit.ins.plp
$Insert *>insert>constants.ins.plp

Dcl rem_8q char (1);

/* ************************************************************************* */

   rem_8q = set8 (rem_8quote_chr);  /* Set the top bit for local processing. */

   quote8_char = 'N';     /* Assume no 8-bit quoting at first. */

   if loc_8quote_chr = 'Y' then
      if quote8_ok (rem_8q) then           /* Check on the remote side. */
         quote8_char = rem_8quote_chr;
      else
         ;
   else
      if quote8_ok (loc_8quote_chr) then
         if rem_8q = 'Y' | rem_8q = loc_8quote_chr then /* See if remote agrees. */
            quote8_char = loc_8quote_chr;

   do_repeats = (loc_rep_chr = rem_rep_chr) & (loc_rep_chr ^= ' ');

   do_windowing = loc_windowing & rem_windowing;   /* Determine window size to use. */

   if do_windowing then
      if loc_max_wsize <= rem_max_wsize then
         window_size = loc_max_wsize;
      else
         window_size = rem_max_wsize;
   else
      window_size = 1;

   return;

/* ******************************* Quote8_ok ******************************* */

Quote8_ok : proc (c) returns (bit (1) aligned);

Dcl c char (1);

Dcl n fixed bin;

/* ************************************************************************* */

   char2(1) = nul_7bit_asc;
   char2(2) = c;
   n = char2_ptr -> fb15_based;

   if n > 128 then
      n = n - 128;

   if ((n >= 33) & (n <= 62)) | ((n >= 96) & (n <= 126)) then
      return (true);
   else
      return (false);

   end;        /* Quote8_ok */

   end;     /* Set_params */
-------------------------------------------------------------------------------

/* SET_PATH -- Set the pathname, directory name, and file name variables. */

Set_path : proc (treename);

Dcl treename char (128) var;

$Insert *>insert>common.ins.plp
$Insert *>insert>primos.ins.plp
$Insert *>insert>constants.ins.plp
$Insert syscom>keys.ins.pl1

Dcl (funit, new_dir_len, code) fixed bin,
    temp_path char (128) var,
    new_dir_name char (128);

/* ************************************************************************* */

   dir_name = '';
   file_name = '';
   non_null_dir = false;
   path_name = trim (treename, '11'b);

   if path_name = '*' then
      path_name = '';

   if path_name = '' then
      return;

   temp_path = reverse (path_name);
   file_name = reverse (before (temp_path, '>'));
   dir_name = reverse (after (temp_path, '>'));

   if dir_name = '*' then
      dir_name = '';

   non_null_dir = (dir_name ^= '');

   if non_null_dir then    /* We need to do this to get the partition name. */
      do;
         call at$ (k$setc, dir_name, code);
         if code = 0 then
            do;
               call gpath$ (k$cura, funit, new_dir_name, 128, new_dir_len, code);
               if code = 0 then
                  do;
                     dir_name = substr (new_dir_name, 1, new_dir_len);
                     path_name = dir_name || '>' || file_name;
                  end;
            end;

         call at$hom (code);

      end;

   return;

   end;       /* Set_path */
-------------------------------------------------------------------------------

/* TIMEOUT_HNDLR -- On_unit for receive timeout (ALARM$ condition). */

Timeout_hndlr : proc (dummy);

Dcl dummy ptr;

$Insert *>insert>common.ins.plp

/* ************************************************************************* */

   /* "timeout" is a label variable which is set to a local label
      in REC_PACKET every time that routine is called. This enables
      us to create the on-unit once at startup yet have it return to
      a sub-procedure when the condition arises.
   */

   goto timeout;

   end;       /* Timeout_hndlr */
-------------------------------------------------------------------------------

/* CTL -- Toggle character's "control" bit. */

Ctl : proc (char_str) returns (char (1));

Dcl char_str char (1);

$Insert *>insert>common.ins.plp
$Insert *>insert>kermit.ins.plp

Dcl bit8 bit (8) aligned,
    bit8_ptr ptr,
    fb fixed bin;

Dcl 1 b8 based,
      2 high_bit bit (1),
      2 ctrl_bit bit (1),
      2 b6 bit (6);

/* ************************************************************************* */

   bit8_ptr = addr (bit8);
   bit8_ptr -> char1_based = char_str;
   bit8_ptr -> b8.ctrl_bit = ^(bit8_ptr -> b8.ctrl_bit);

   return (bit8_ptr -> char1_based);

/* ********************************* Knum ********************************** */

/* KNUM -- Kermit function to make character a number. */

Knum : entry (char_k) returns (fixed bin);

Dcl char_k char (1);

/* ************************************************************************* */

   fb = 0;
   substr (addr (fb) -> char2_based, 2, 1) = char_k;

   if fb >= 128 then
      fb = fb - 128;

   fb = fb - 32;              /* Turn off "printable" bit. */

   return (fb);

/* ********************************* Set8 ********************************** */

/* SET8 -- Set high bit on a character. */

Set8 : entry (ch1) returns (char (1));

Dcl ch1 char (1);

/* ************************************************************************* */

   bit8_ptr = addr (bit8);
   bit8_ptr -> char1_based = ch1;
   bit8_ptr -> b8.high_bit = '1'b;

   return (bit8_ptr -> char1_based);

/* ********************************* Clr8 ********************************** */

/* CLR8 -- Clear high bit on a character. */

Clr8 : entry (ch1) returns (char (1));

/* ************************************************************************* */

   bit8_ptr = addr (bit8);
   bit8_ptr -> char1_based = ch1;
   bit8_ptr -> b8.high_bit = '0'b;

   return (bit8_ptr -> char1_based);

/* ******************************** Set8str ******************************** */

/* SET8STR -- Set high bit on all characters in a string. */

Set8str : entry (str1) returns (char (ibuffer_size) var);

Dcl str1 char (ibuffer_size) var;

Dcl str2 char (ibuffer_size) var,
    (str_ptr, str_ptr2) ptr,
    (i, j) fixed bin;

/* ************************************************************************* */

   str2 = '';
   j = length (str1);
   str_ptr = addrel (addr (str1), 1);
   str_ptr2 = addr (str2);
   str_ptr2 -> fb15_based = j;             /* Set the string length. */
   str_ptr2 = addrel (str_ptr2, 1);

   do i = 1 to j by 2;       /* Process the string 2 characters at a time. */
      str_ptr2 -> bit16_based = str_ptr -> bit16_based | '8080'b4;
      str_ptr = addrel (str_ptr, 1);
      str_ptr2 = addrel (str_ptr2, 1);
   end;

   if mod (j, 2) > 0 then    /* We mustn't forget the last odd character. */
      str_ptr2 -> bit8_based = str_ptr -> bit8_based | '80'b4;

   return (str2);

/* ******************************** Clr8str ******************************** */

/* CLR8STR -- Clear high bit on all characters in a string. */

Clr8str : entry (str1) returns (char (ibuffer_size) var);

/* ************************************************************************* */

   str2 = '';
   j = length (str1);
   str_ptr = addrel (addr (str1), 1);
   str_ptr2 = addr (str2);
   str_ptr2 -> fb15_based = j;             /* Set the string length. */
   str_ptr2 = addrel (str_ptr2, 1);

   do i = 1 to j by 2;       /* Process the string 2 characters at a time. */
      str_ptr2 -> bit16_based = str_ptr -> bit16_based & '7F7F'b4;
      str_ptr = addrel (str_ptr, 1);
      str_ptr2 = addrel (str_ptr2, 1);
   end;

   if mod (j, 2) > 0 then    /* We mustn't forget the last odd character. */
      str_ptr2 -> bit8_based = str_ptr -> bit8_based & '7F'b4;

   return (str2);

/* ******************************** Between ******************************** */

Between : entry (num, lo, hi) returns (bit (1) aligned);

Dcl (num, lo, hi) fixed bin;

/* ************************************************************************* */

   if lo <= hi then
      return ((num >= lo) & (num <= hi));
   else
      return ((num <= hi) | (num >= lo));

   end;       /* Utilities */
-------------------------------------------------------------------------------

/* WRITE_IBUF -- Write intermediate buffer to disk file. */

Write_ibuf : proc (key, code);

Dcl (key, code) fixed bin;

$Insert *>insert>common.ins.plp
$Insert *>insert>kermit.ins.plp
$Insert *>insert>primos.ins.plp
$Insert *>insert>constants.ins.plp
$Insert syscom>keys.ins.pl1

Dcl rnw fixed bin;

/* ************************************************************************* */

   code = 0;

   /* Initially we try to write the file out as an ASCII file, unless the
      file type has been set or any 8-bit characters are seen. */

   if file_type ^= binary_ft then
      call write_text;

   /* If write_text decides it's actually a binary file, it will change FILE_TYPE. */

   if file_type = binary_ft then
      call write_binary;

   return;

/* ***************************** Write_binary ****************************** */

Write_binary : proc;

Dcl rwl_key (2) fixed bin,
    odd bit (1) aligned;

/* ************************************************************************* */

   /* This code adds an extra CTRL-Z to ibuffer if the file length is odd,
   /* this enables us to write out an even number of characters and not lose
   /* the last character. The file read/write lock is set to NONE to show this.
   /* The file length is decremented by 1 in OPEN_INPUT (downloading) if the
   /* rwlock is set to NONE (3). Note : this scheme for preserving the exact
   /* character length of the file will only work if the uploading process has
   /* OWNER (O) or PROTECT (P) access to the file. Otherwise the lock is not
   /* changed and the extra CTRL-Z will be downloaded. The error is not reported. */

   odd = (mod (ibuf_ptr, 2) = 1);

   if key = 1 then     /* If key indicates this is the end of the file ... */
      if odd then
         do;
            ibuf_ptr = ibuf_ptr + 1;
            substr (ibuffer, ibuf_ptr, 1) = ctrl_z_7bit_asc;

            if non_null_dir then
               call at$ (k$setc, dir_name, code);

            rwl_key(1) = k$none;
            rwl_key(2) = 0;

            if code = 0 then
               call satr$$ (k$rwlk, (file_name), length (file_name), addr (rwl_key) -> fb31_based, code);

            if non_null_dir then
               call at$hom (code);
         end;

   call prwf$$ (k$writ, file_unit, ibuffer_ptr, divide (ibuf_ptr, 2, 15), 0, rnw, code);

   if odd then
      do;                /* Keep the last odd character. */
         substr (ibuffer, 1, 1) = substr (ibuffer, ibuf_ptr, 1);
         ibuf_ptr = 1;
      end;
   else
      ibuf_ptr = 0;      /* Reset position pointer to start of ibuffer. */

   return;

   end;       /* Write_binary */

/* ******************************* Write_text ****************************** */

Write_text : proc;

Dcl tbuffer char (2048),
    (i, tbuf_ptr, save_cnt) fixed bin,
    (character, prev_char) char (1),
    char_ptr ptr,
    crlf_seen bit (1) aligned;

Dcl 1 bit_char based,
      2 high_bit bit (1),
      2 next_bits bit (7);

/* ************************************************************************* */

   eol_flag = 0;
   tbuf_ptr = 0;
   crlf_seen = false;
   prev_char = nul_7bit_asc;
   char_ptr = addr (character);

   do i = 1 to ibuf_ptr;  /* Set top bit on all chars, and convert EOL sequences. */
      character = substr (ibuffer, i, 1);
      if prev_char ^= dc1_8bit_asc then
         char_ptr -> bit_char.high_bit = '1'b;

      prev_char = character;

      if character = cr_8bit_asc then
         eol_flag = 1;
      else
         if character = lf_8bit_asc then
            eol_flag = eol_flag + 1;
         else
            eol_flag = 0;

      if eol_flag < 2 then         /* Store normal characters. */
         do;
            tbuf_ptr = tbuf_ptr + 1;
            substr (tbuffer, tbuf_ptr, 1) = character;
         end;
      else
         do;                        /* Convert CRLF to LF or LFNUL. */
            crlf_seen = true;
            substr (tbuffer, tbuf_ptr, 1) = lf_8bit_asc;
            if mod (tbuf_ptr, 2) ^= 0 then
               do;
                  tbuf_ptr = tbuf_ptr + 1;
                  substr (tbuffer, tbuf_ptr, 1) = nul_7bit_asc;
               end;
         end;
   end;

   if tbuf_ptr = 0 then
      return;

   save_cnt = 0;

   if key = 0 then            /* Save the CTRL-Z or CR or odd character. */
      do;
         character = substr (tbuffer, tbuf_ptr, 1);
         if character = ctrl_z_8bit_asc | character = cr_8bit_asc then
            save_cnt = 1;

         if mod (tbuf_ptr - save_cnt, 2) = 1 then
            do;
               save_cnt = save_cnt + 1;

               if substr (tbuffer, tbuf_ptr - save_cnt, 1) = dc1_8bit_asc then
                  save_cnt = save_cnt + 2;
            end;

         if save_cnt > 0 then
            do;
               substr (ibuffer, 1, save_cnt) = substr (ibuffer, ibuf_ptr - save_cnt + 1, save_cnt);
               tbuf_ptr = tbuf_ptr - save_cnt;
            end;

         ibuf_ptr = save_cnt;
      end;
   else
      do;                /* Last write to file. */
         if rec_file_type = automatic_ft & ^crlf_seen then
            do;
               rec_file_type = binary_ft; /* If the file is read in one go, */
               file_type = binary_ft; /* and doesn't end in CRLF, then it's BINARY. */
               if log_opened then
                  call log_info ('BINARY file type has been detected, and will now be used.');
               return;
            end;

         if substr (tbuffer, tbuf_ptr, 1) = ctrl_z_8bit_asc then
            tbuf_ptr = tbuf_ptr - 1;        /* Remove the last CTRL-Z. */

         if tbuf_ptr > 0 then
            if substr (tbuffer, tbuf_ptr, 1) ^= lf_8bit_asc then
               if tbuf_ptr > 1 then
                  if substr (tbuffer, tbuf_ptr - 1, 2) ^= lf_8bit_asc || nul_7bit_asc then
                     do;
                        tbuf_ptr = tbuf_ptr + 1;
                        substr (tbuffer, tbuf_ptr, 1) = lf_8bit_asc;
                     end;
                  else
                     ;
               else
                  do;
                     tbuf_ptr = tbuf_ptr + 1;
                     substr (tbuffer, tbuf_ptr, 1) = lf_8bit_asc;
                  end;

         if mod (tbuf_ptr, 2) = 1 then
            do;
               tbuf_ptr = tbuf_ptr + 1;
               substr (tbuffer, tbuf_ptr, 1) = nul_7bit_asc;
            end;

         ibuf_ptr = 0;
      end;

   call prwf$$ (k$writ, file_unit, addr (tbuffer), divide (tbuf_ptr, 2, 15), 0, rnw, code);

   return;

   end;            /* Write_text */

   end;        /* Write_ibuf */
-------------------------------------------------------------------------------

/* WRITE_OUTPUT -- Write data to output file. */

Write_output : proc returns (fixed bin);

$Insert *>insert>kermit.ins.plp
$Insert *>insert>common.ins.plp
$Insert *>insert>constants.ins.plp

Dcl (counter, rec_msg_len, code, rep_count, next, end) fixed bin,
    (character, chr, space_7bit_asc) char (1),
    rem_pound_str char (2),
    (do_8bit_quoting, parity, compress_spaces) bit (1) aligned;

/* ************************************************************************* */

   code = 0;
   char2(1) = nul_7bit_asc;
   rec_msg_len = length (rec_msg) - 1;
   do_8bit_quoting = (quote8_char ^= 'N');
   space_7bit_asc = clr8 (' ');
   rem_pound_str = rem_quote_chr || '\';

   do counter = pkt_msg to rec_msg_len until (code ^= 0);

      character = substr (rec_msg, counter, 1);
      rep_count = 1;
      parity = false;

      if do_repeats then              /* Process repeat characters. */
         if character = loc_rep_chr then
            do;
               counter = counter + 1;
               rep_count = knum (substr (rec_msg, counter, 1));

               counter = counter + 1;
               character = substr (rec_msg, counter, 1);
            end;

      if do_8bit_quoting then         /* Process 8-bit quoting. */
         if character = quote8_char then
            do;
               parity = true;
               counter = counter + 1;
               character = substr (rec_msg, counter, 1);
               if rec_file_type = automatic_ft & (substr (rec_msg, counter, 2) ^= rem_pound_str) then
                  do;
                     rec_file_type = binary_ft;
                     file_type = binary_ft;       /* It's a BINARY file. */
                     if log_opened then
                        call log_info ('BINARY file type has been detected, and will now be used.');
                  end;
            end;

      if character = rem_quote_chr then   /* Process control character quoting. */
         do;
            counter = counter + 1;
            character = substr (rec_msg, counter, 1);
            chr = clr8 (character);
            if chr >= query_7bit_asc & chr < grave_7bit_asc then
               character = ctl (character);
         end;

      if do_8bit_quoting then        /* Now we can add the parity. */
         if parity then
            character = set8 (character);
         else
            character = clr8 (character);
      else
         if do_transparent then
            if rec_file_type = automatic_ft & character >= nul_8bit_asc then
               do;
                  rec_file_type = binary_ft;
                  file_type = binary_ft;    /* It's a BINARY file. */
                  if log_opened then
                     call log_info ('BINARY file type has been detected, and will now be used.');
               end;

/* Store in intermediate buffer. */

      if file_type = ascii_ft & character = space_7bit_asc & rep_count > 2 then
         do;         /* Spaces are a special case, allow for 2 characters. */
            next = 2;
            compress_spaces = true;
         end;
      else
         do;
            next = rep_count;
            compress_spaces = false;
         end;

      if ibuf_ptr + next > ibuffer_size then
         call write_ibuf (0, code);       /* Make some space if necessary. */

      if compress_spaces then
         do;
            ibuf_ptr = ibuf_ptr + 1;
            substr (ibuffer, ibuf_ptr, 1) = dc1_8bit_asc;
            char2_ptr -> fb15_based = rep_count;
            character = char2(2);
            rep_count = 1;
         end;

      next = ibuf_ptr + 1;
      end = ibuf_ptr + rep_count;

      do ibuf_ptr = next to end;
         substr (ibuffer, ibuf_ptr, 1) = character;
      end;

      ibuf_ptr = ibuf_ptr - 1;     /* Adjustment for the do loop. */

      if ibuf_ptr >= ibuffer_size then  /* Write out the buffer if its full. */
         call write_ibuf (0, code);

   end;            /* do until */

   return (code);

   end;         /* Write_output */
-------------------------------------------------------------------------------

/* XFER_MODE -- Set or reset packet transfer mode. */

Xfer_mode : proc (key, code);

Dcl (key, code) fixed bin;

$Insert *>insert>common.ins.plp
$Insert *>insert>kermit.ins.plp
$Insert *>insert>primos.ins.plp
$Insert syscom>keys.ins.pl1

/* ************************************************************************* */

   code = 0;

   select (key);

      when (0)          /* Reset to interactive use. */
         do;
            if ^do_transparent then
               addr (code) -> bit16_based = duplx$ (my_duplex);

            call erkl$$ (k$writ, my_erase, my_kill, code);

            call mgset$ (my_msg_state, code);
         end;

      when (1)               /* Set up for packet transfer. */
         do;
            if ^do_transparent then
               addr (code) -> bit16_based = duplx$ ('A000'b4);  /* Set to half duplex. */

            call erkl$$ (k$writ, '
            call mgset$ (k$rjct, code);  /* Reject any messages we may receive. */

            auto_sum = do_transparent;   /* Set if we have no parity. */
         end;

      otherwise
         code = -1;

   end;

   return;

   end;      /* Xfer_mode */

/* END OF PRIME8.SRC */
