Columbia Kermit/kermit.zip/aospascal/aosk2.pas

Pascal/Delphi Source File | 2020-01-01 | 22KB | 922 lines

PROGRAM     KERMIT (INPUT,OUTPUT);

CONST
    OUTPUTFILE = '@LIST';
    INPUTFILE = '@DATA';
    NL = '<012>';
    CR = '<015>';
    SEND_QCHR = '#';
    REC_ELN = '<4>';
    MARK = '<1>';

    NAMELENGTH = 15;
    MAXBUFF = 100;   (* Maximun packet length can handle *)

TYPE
    PACHEADER = RECORD
        SEQ : INTEGER;
        PTYPE : CHAR;
        CHECK : CHAR;
    END;
    PACDATA = RECORD
        DATA :  PACKED ARRAY [ 1 .. MAXBUFF] OF CHAR;
        LENGTH : INTEGER
    END;

    NAMETYPE = PACKED ARRAY [ 1 .. NAMELENGTH] OF CHAR;

VAR
    DISK,OUTSCREEN,INSCREEN: TEXT;

    SEND_ELN, REC_QCHR: CHAR;
    SEND_MLEN, REC_MLEN :INTEGER;
    EIGHTBIT,CENDLN,KCHAR_ELN, DEBUG , IGNORE_PARMS:BOOLEAN;


INCLUDE BOOLEAN.PAS;       (* Need for XXOR and XAND funtion call *)

(* _______________________________________________________________
        Opens screen files
*)
PROCEDURE OPEN_SCREEN;
BEGIN
    RESET(OUTSCREEN,OUTPUTFILE);
    RESET(INSCREEN,INPUTFILE,MAXBUFF*2)
END;

(* _______________________________________________________________
        opens files
    1. Opens the three files
    2. Enacts a delay
    3. Possible MODES
        'C' = rewrite file
        'R' = reset file
*)
PROCEDURE OPEN_FILE(DATANAME:NAMETYPE;MODE:CHAR);

VAR
    FILENAME: STRING 20;
    Y,INDEX :INTEGER;

BEGIN
    FOR Y := 1 TO NAMELENGTH  DO
        IF DATANAME[Y] <> ' '
           THEN APPEND(FILENAME,DATANAME[Y]);
    IF DEBUG = TRUE THEN
        BEGIN
             WRITELN('OPENING FILE MODE - ',MODE);
              WRITELN('     LENGTH OF STRING: ',LENGTH(FILENAME));
        END;

    IF MODE = 'C'
        THEN REWRITE(DISK,FILENAME)
        ELSE RESET (DISK,FILENAME, 200);
    OPEN_SCREEN;
END;

(* _______________________________________________________________
        Increments the sequence number
*)
FUNCTION ADDSEQ (INDEX:INTEGER):INTEGER;

BEGIN
    IF (INDEX+1) = 64  THEN ADDSEQ := 0
               ELSE ADDSEQ := INDEX+1
END;


(* _______________________________________________________________
                 Returns the KERMIT type Ascii character
*)
FUNCTION KCHAR (NUMBER:INTEGER) :CHAR;
BEGIN
    KCHAR := CHR (NUMBER + 32)
END;

(* _______________________________________________________________
        Return the KERMIT type integer value of a CHAR
*)
FUNCTION UNKCHAR (BYTE:CHAR) :INTEGER;
BEGIN
    UNKCHAR := (ORD(BYTE) - 32);
END;

(* _______________________________________________________________
        Returns the integer value for a control character
*)
FUNCTION CTL (VALUE:INTEGER):INTEGER;
BEGIN
    CTL := XXOR (VALUE , 64)
END;

(* _______________________________________________________________
         Return a one byte checksum
    1. If CTYPE = 'C' then the sum is Changed if the character is
       a control character, REC_QCHR or NL then then actual
        sent value is automatically added to SUM
    2. If CTYPE <> 'C' then just a Straight checksum is produced
    3. The XAND function is used
*)
FUNCTION CHECKSUM (HEADER:PACHEADER ; DATA:PACDATA; CTYPE:CHAR): CHAR;

VAR
    VAL,HVAL:INTEGER;
    X,SUM :WHOLE;

BEGIN
    SUM := DATA.LENGTH + 3 + 32;
    SUM := SUM + HEADER.SEQ + 32;
    SUM := SUM + ORD (HEADER.PTYPE);
    FOR X := 1 TO DATA.LENGTH DO
        BEGIN
            HVAL  := ORD(DATA.DATA[X]);
            VAL := XAND(HVAL,127);
            IF ((VAL <= 31) OR (VAL = 127)) AND (CTYPE = 'C')
            THEN SUM := SUM + ORD(REC_QCHR) + CTL(HVAL)+1
            ELSE IF (VAL=ORD(REC_QCHR)) AND (CTYPE = 'C')
                THEN SUM := SUM + ORD(REC_QCHR)+HVAL+1
                ELSE SUM := SUM + HVAL;
        END;
    SUM := XAND(SUM,255);
    X := SUM + ( XAND(SUM,192) DIV 64 );
    CHECKSUM := KCHAR ( XAND(X,63) )
END;

(* _______________________________________________________________
         Assembles packet form and writes Packet out
*)
PROCEDURE SEND_PACKET (HEADER:PACHEADER ; DATA:PACDATA);

VAR
    PACKET : PACKED ARRAY [ 1 .. MAXBUFF+10] OF CHAR;
    X, INDEX :INTEGER;

BEGIN
    IF DEBUG THEN
        BEGIN
             WRITELN('SENDING PACKET');
            WRITELN('     SEQUENCE: ',HEADER.SEQ);
            WRITELN('     DATA.LENGTH: ',DATA.LENGTH)
        END;


    X := 0;

    PACKET[(X+1)] := MARK;
    PACKET[(X+2)] := KCHAR(DATA.LENGTH+3);
    PACKET[(X+3)] := KCHAR(HEADER.SEQ);
    PACKET[(X+4)] := HEADER.PTYPE;
    X := X+4;

    FOR INDEX := 1 TO DATA.LENGTH  DO
        PACKET[(X+INDEX)] := DATA.DATA[INDEX];
    X := X + DATA.LENGTH;

    PACKET[(X+1)] := HEADER.CHECK;
    PACKET[(X+2)] := SEND_ELN;
    WRITE (OUTSCREEN, PACKET:(X+2) );
    IF DEBUG THEN
       BEGIN
        WRITELN('Packet length: ',X+2);
         WRITELN('SENT PACKET')
       END;
END;

(* _______________________________________________________________
               Creates a zero length data control packet
*)
PROCEDURE CREATE_CONTROL_PACKET (VAR HEADER:PACHEADER; VAR DATA:PACDATA;
            PACTYPE:CHAR; INDEX:INTEGER);

BEGIN
    HEADER.PTYPE := PACTYPE;
    HEADER.SEQ := INDEX;
    DATA.LENGTH := 0;
    HEADER.CHECK := CHECKSUM (HEADER, DATA, 'S')
END;


(* _______________________________________________________________
         Reads in a packet from the screen
     1. MARK must contain the mark character
     2. Default for HEADER.PTYPE = ' '
     3. Default for HEADER.SEQ = -1
    4. Packet must not contain the EOF character -  REC_ELN -
    5. If CHECK = S at entry control de-quoting is not done
    6. There are three possible returned values for CHECK
        ' ' = receive okay
        'E' = Checksum wrong, EOF marker before whole
            Packet can be read, or can't find MARK
        'T' = timed out when reading packet (Unimplimented)

*)
PROCEDURE RECEIVE_PACKET (VAR HEADER:PACHEADER; VAR DATA:PACDATA; VAR CHECK:CHAR);

VAR
    PACKET : PACKED ARRAY [1 .. MAXBUFF+10] OF CHAR;
    X,Y, LOOP :INTEGER;
    HCHECK,BYTE : CHAR;
    DEQUOTE :BOOLEAN;

BEGIN
    IF DEBUG THEN
        BEGIN
            WRITELN ('RECEIVING: ')
        END;

    X := 0;
    IF CHECK <> 'S' THEN DEQUOTE := TRUE
            ELSE DEQUOTE := FALSE;
    CHECK := ' ';
    REPEAT
        X := X+1;
        IF EOF(INSCREEN) THEN
            BEGIN
                RESET(INSCREEN);
                X := X+1
            END;
        READ (INSCREEN, BYTE);
        IF DEBUG THEN
            WRITELN('SEARCH FOR MARK, GOT: ',ORD(BYTE))
    UNTIL (BYTE = MARK) OR (X = 6);
    IF X = 6 THEN CHECK := 'E';

    X := 1;
    HEADER.SEQ := -1;
    HEADER.PTYPE := ' ';
     FOR X := 1 TO 3 DO
        BEGIN
           IF EOF(INSCREEN) THEN CHECK := 'E'
                    ELSE READ(INSCREEN,BYTE);
           IF DEBUG THEN
               WRITELN('READING BYTE- GOT: ',ORD(BYTE));
           IF X = 1 THEN
            DATA.LENGTH := UNKCHAR(BYTE) - 3;
           IF X = 2 THEN
            HEADER.SEQ := UNKCHAR (BYTE);
           IF X = 3 THEN
                HEADER.PTYPE := BYTE
        END;

    Y := 0;
        X := 1;
    LOOP := 1;
    IF EOF(INSCREEN) THEN CHECK := 'E'
              ELSE READ(INSCREEN,BYTE);

    WHILE (LOOP <= DATA.LENGTH) AND (CHECK <> 'E') DO
        BEGIN
           IF DEBUG THEN
            WRITELN(DATA.LENGTH,' READING BYTE, GOT: ',ORD(BYTE));
           IF Y = 1 THEN
            BEGIN
              Y := 2;
              IF CHR(XAND(ORD(BYTE),127)) = REC_QCHR
                  THEN DATA.DATA[X] := BYTE
                  ELSE DATA.DATA[X] := CHR(CTL(ORD(BYTE)))
            END;
           IF (BYTE=REC_QCHR) AND (Y=0) AND DEQUOTE
            THEN BEGIN
                Y := 1;
                DATA.LENGTH := DATA.LENGTH - 1
                 END;
           IF Y = 0
            THEN DATA.DATA[X] := BYTE
            ELSE IF Y=2 THEN Y := 0;

           IF EOF(INSCREEN) THEN CHECK := 'E'
                    ELSE READ(INSCREEN,BYTE);
           IF Y <> 1 THEN
            BEGIN
                X:= X+1;
                LOOP := LOOP +1
            END
        END;

       IF CHECK <> 'E' THEN
       BEGIN
        HEADER.CHECK := BYTE;
        IF DEQUOTE
            THEN HCHECK := CHECKSUM(HEADER,DATA,'C')
            ELSE HCHECK := CHECKSUM(HEADER,DATA,'S');
        IF NOT( HEADER.CHECK = HCHECK)
            THEN CHECK := 'E'
       END;
    RESET(INSCREEN);

    IF DEBUG THEN
        BEGIN
            WRITELN('FINISHED RECEIVING PACKET');
            WRITELN('       SEQUENCE: ',HEADER.SEQ);
            WRITELN('   HEADER.PTYPE: ',HEADER.PTYPE);
            WRITELN('    DATA-LENGTH: ',DATA.LENGTH);
            WRITELN('          CHECK:',CHECK);
            WRITELN('         HEADER.CHECK: ',HEADER.CHECK);
            WRITELN('    RETURNED CHECKSUM: ',HCHECK)
        END
END;

(* _______________________________________________________________
         Extracts the information from initial packet
     1. sets SEND_MLEN, SEND_ELN
*)
PROCEDURE SET_DEFAULTS ( HEADER:PACHEADER; DATA:PACDATA );

BEGIN
    IF DEBUG THEN WRITELN('SETTING DEFAULTS');
    IF (DATA.LENGTH => 1) AND (DATA.DATA[1] <> ' ')
          THEN SEND_MLEN := UNKCHAR (DATA.DATA[1])
        ELSE SEND_MLEN := 80;

    IF (DATA.LENGTH => 5) AND (DATA.DATA[5] <> ' ')
          THEN IF KCHAR_ELN
              THEN SEND_ELN := CHR(UNKCHAR(DATA.DATA[5]))
             ELSE SEND_ELN := DATA.DATA[5]
        ELSE SEND_ELN := CR;

    IF (DATA.LENGTH => 6) AND (DATA.DATA[6] <> ' ')
        THEN REC_QCHR := DATA.DATA[6]
        ELSE REC_QCHR := '#';
    IF DEBUG THEN
      BEGIN
         WRITELN('HAVE SET DEFAULTS');
        WRITELN('   QUOTE CHAR FROM OTHER KERMIT: ',REC_QCHR);
        WRITELN('   MAX LENGTH OF SEND PACKET: ', SEND_MLEN);
        WRITELN('   SEND-EOLN CHAR (ASCII): ',ORD(SEND_ELN))
       END
END;

(* _______________________________________________________________
         Creates a packet for the initial connection
*)
PROCEDURE CREATE_SEND_INIT (VAR HEADER:PACHEADER; VAR DATA:PACDATA; INDEX: INTEGER);

VAR
    X : INTEGER;

BEGIN
    IF DEBUG THEN WRITELN('CREATING SEND-INIT PACKET');
    HEADER.PTYPE := 'S';
    HEADER.SEQ := INDEX;
    DATA.LENGTH := 10;
    WITH DATA
        DO BEGIN
            DATA[1] := KCHAR(REC_MLEN);  (* Max packet lenth *)
            DATA[2] := KCHAR(15); (* sec. before time out *)
            DATA[3] := KCHAR(0);   (* # of pad char need *)
            DATA[4] := ' ';     (* pad character *)
            IF KCHAR_ELN
                THEN DATA[5] := KCHAR(ORD(REC_ELN))
                ELSE DATA[5] := REC_ELN;
            DATA[6] := SEND_QCHR;    (* Char for control quote *)
            DATA[7] := 'N';     (* No 8 Bit quote *)
            DATA[8] := '1';     (* Normal checksum *)
            DATA[9] := ' ';     (* No repeat char *)
            DATA[10] := KCHAR(0)    (* Capacity byte *)
        END;
    FOR X := 11 TO 14 DO
        DATA.DATA[X] := ' ';
    HEADER.CHECK := CHECKSUM (HEADER,DATA,'S');
    IF DEBUG THEN WRITELN('HAVE CREATED SEND INIT PACKET')
END;

(* _______________________________________________________________
         Sends packet until E or Y or B reply received
    1. Will not do anything if REPLY initially E
    2. Possible values of REPLY on exit are E and Y
    3. If Initial value of REPLY = S
         dequoting will not be done on receive
*)
PROCEDURE SEND_LOOP (HEADER:PACHEADER; DATA:PACDATA; VAR REPLY:CHAR);

VAR
    HOLD :PACHEADER;
    HOLDDATA :PACDATA;
    CHECK ,HREPLY :CHAR;
    TRYS :INTEGER;

BEGIN
    IF DEBUG THEN WRITELN('STARTING SEND LOOP');
    TRYS := 1;
    IF REPLY = 'S' THEN HREPLY := 'S'
               ELSE HREPLY := ' ';
    IF NOT(REPLY = 'E') THEN REPLY := ' ';
    WHILE NOT ((REPLY = 'Y') OR (REPLY = 'E'))
        DO BEGIN
            SEND_PACKET (HEADER, DATA);
            REPEAT
               CHECK := HREPLY;
               RECEIVE_PACKET (HOLD, HOLDDATA, CHECK);
               IF CHECK = 'E' THEN HOLD.SEQ := -1;
               IF CHECK = 'T' THEN HOLD.SEQ := -1;
               IF HOLD.SEQ = ADDSEQ(HEADER.SEQ) THEN
                HOLD.SEQ := -1;
            UNTIL (HOLD.SEQ = -1) OR (HOLD.SEQ=HEADER.SEQ);
            IF HOLD.SEQ = -1  THEN REPLY := ' '
                      ELSE REPLY := HOLD.PTYPE;
            IF TRYS <= 5
                THEN TRYS := TRYS+1
                ELSE REPLY := 'E'
        END;
    IF DEBUG THEN WRITELN('FINISHING SEND LOOP')
END;

(* _______________________________________________________________
         Creates file header packet
*)
PROCEDURE CREATE_FILE_HEADER (VAR HEADER:PACHEADER; VAR DATA:PACDATA;
                INDEX:INTEGER ;DATAFILE:NAMETYPE);

VAR
    X :INTEGER;

BEGIN
    IF DEBUG THEN
        WRITELN('CREATING FILE HEADER');
    HEADER.PTYPE := 'F';
    HEADER.SEQ := INDEX;
    X := 1;
    WHILE (X < NAMELENGTH) AND (DATAFILE[X] <> ' ') DO
        BEGIN
            DATA.DATA[X] := DATAFILE[X];
            X := X+1
        END;
    DATA.LENGTH := X - 1;
    HEADER.CHECK := CHECKSUM (HEADER,DATA,'S');
    IF DEBUG THEN
        WRITELN('CREATED FILE HEADER')
END;

(* _______________________________________________________________
         Creates a data packet
    1. The XAND function is used, and a character is QUOTED if
        it should be quoted with the high bit turned OFF
        regardless of the actual value of the high bit
*)
PROCEDURE CREATE_DATA_PACKET (VAR HEADER:PACHEADER; VAR DATA:PACDATA; INDEX:INTEGER);

VAR
    X,Y,VALUE,HVALUE :INTEGER;
    BYTE :CHAR ;

BEGIN
    IF DEBUG THEN
        BEGIN
             WRITELN('CREATING DATA PACKET');
            WRITELN('   SEND_MLEN:', SEND_MLEN);
        END;
    HEADER.PTYPE := 'D';
    HEADER.SEQ := INDEX;

    X := 1;
    WHILE   NOT( EOF(DISK) ) AND ((X+4) <= (SEND_MLEN-7)) DO
       BEGIN
        READ (DISK,BYTE);
        VALUE := ORD (BYTE);
        HVALUE := XAND(VALUE,127);
        IF NOT EIGHTBIT THEN
           BEGIN
             VALUE := HVALUE;
            BYTE := CHR(VALUE)
            END;
        Y := X;
        IF (HVALUE <= 31) OR (HVALUE = 127) THEN
               BEGIN
               DATA.DATA[X] := SEND_QCHR;
               X := X+1;
               DATA.DATA[X] := CHR( CTL(VALUE) )
            END;
        IF HVALUE  =  ORD(SEND_QCHR)  THEN
            BEGIN
                 DATA.DATA[X] := SEND_QCHR;
              X := X+1;
              DATA.DATA[X] := BYTE;
            END;
        IF (BYTE = NL) AND CENDLN THEN
            BEGIN
              DATA.DATA[X] := 'M';
                    X := X+1;
              DATA.DATA[X] := SEND_QCHR;
              X := X+1;
              DATA.DATA[X] := 'J'
            END;
        IF Y = X THEN
            DATA.DATA[X] := BYTE;
        X := X+1;
       END;
    DATA.LENGTH :=  X-1;
    HEADER.CHECK := CHECKSUM (HEADER, DATA,'S');
    IF DEBUG THEN WRITELN('HAVE CREATED DATA PACKET')
END;


(* _______________________________________________________________
                Does the send routine to send DATAFILE
    1. the files must be open
    2. closes the files
*)
PROCEDURE SEND_ROUTINE(DATAFILE:NAMETYPE);

VAR
    HEADER, HOLD_HEADER:PACHEADER;
    DATA, HOLD_DATA : PACDATA;
    INDEX : INTEGER;
    REPLY : CHAR;

BEGIN
    INDEX := 0;

    CREATE_SEND_INIT (HEADER, DATA, INDEX);
    REPEAT
        SEND_PACKET(HEADER,DATA);
        REPLY := 'S';
        RECEIVE_PACKET(HOLD_HEADER,HOLD_DATA,REPLY);
        IF DEBUG THEN
            BEGIN
            WRITELN(HOLD_HEADER.PTYPE,'-',REPLY,'-');
            REPLY := ' ';
            END;
    UNTIL ((HOLD_HEADER.PTYPE = 'Y') AND (REPLY = ' '));
    IF NOT IGNORE_PARMS THEN
        SET_DEFAULTS (HOLD_HEADER, HOLD_DATA);

    INDEX := ADDSEQ(INDEX);
    CREATE_FILE_HEADER ( HEADER, DATA, INDEX, DATAFILE);
    SEND_LOOP (HEADER, DATA, REPLY);

    WHILE NOT( EOF(DISK) OR (REPLY = 'E') )
        DO BEGIN
            INDEX := ADDSEQ (INDEX);
            CREATE_DATA_PACKET (HEADER,DATA,INDEX);
            SEND_LOOP (HEADER, DATA, REPLY)
        END;

    INDEX := ADDSEQ (INDEX);
    CREATE_CONTROL_PACKET (HEADER, DATA, 'Z' , INDEX);
    SEND_LOOP (HEADER, DATA, REPLY );

    INDEX := ADDSEQ (INDEX);
    CREATE_CONTROL_PACKET (HEADER,DATA, 'B', INDEX);
    SEND_LOOP (HEADER, DATA, REPLY);

    CLOSE (DISK);
    CLOSE (OUTSCREEN);
    CLOSE (INSCREEN)
END;

(* ------------------------------------------------------------------

*)
PROCEDURE SEND;

VAR
    X:INTEGER;
    DATAFILE:NAMETYPE;

BEGIN
    WRITE(' Name of the file: ');
    FOR X:= 1 TO NAMELENGTH DO
         IF NOT(EOLN(INPUT))
            THEN READ(DATAFILE[X])
            ELSE DATAFILE[X] := ' ';
    READLN;
    OPEN_FILE(DATAFILE,'R');
    SEND_ROUTINE(DATAFILE);
END;

(* ------------------------------------------------------------------
        Receives data packets and constructs file
    1. Opens up DISK and closes it
    2. HEADER and DATA must be the F packet
    3. Will receive D packets until Z packet (end of file)
    4. Changes CR LF to NL
*)
PROCEDURE RECEIVE_LOOP(VAR HEADER:PACHEADER; VAR DATA:PACDATA);

VAR
    X,F,R,INDEX:INTEGER;
    REPLY,RTYPE :CHAR;
    DATAFILE :NAMETYPE;

BEGIN
    IF DEBUG THEN WRITELN('STARTING RECEIVE_LOOP');

    INDEX := HEADER.SEQ+1;

    FOR X:= 1 TO NAMELENGTH DO
        IF (DATA.DATA[X] <> ' ') AND (X <= DATA.LENGTH)
            THEN DATAFILE[X] := DATA.DATA[X]
            ELSE DATAFILE[X] := ' ';
    OPEN_FILE(DATAFILE,'C');
    CREATE_CONTROL_PACKET(HEADER,DATA,'Y',HEADER.SEQ);
    SEND_PACKET(HEADER,DATA);


        RTYPE :=  ' ';
    WHILE (RTYPE <> 'Z') AND (RTYPE <> 'E') DO
       BEGIN
           RECEIVE_PACKET(HEADER,DATA,REPLY);
           RTYPE := HEADER.PTYPE;
           IF DEBUG THEN WRITELN('Index - ',INDEX);
           IF  REPLY = ' ' THEN
          BEGIN
             IF (HEADER.SEQ = INDEX) AND (RTYPE = 'D')
              THEN BEGIN
                  INDEX := ADDSEQ(INDEX);
                  R := 0;
                  F := -3;
                  FOR X:= 1 TO DATA.LENGTH DO
                BEGIN
                  DATA.DATA[(X-R)] := DATA.DATA[X];
                  IF DATA.DATA[X] = '<15>' THEN F := X;
                  IF (DATA.DATA[X] = '<12>') AND (F=X-1)
                    AND CENDLN THEN
                         BEGIN
                         R := R+1;
                        DATA.DATA[(X-R)] := NL
                         END;
                END;
                  DATA.LENGTH := DATA.LENGTH - R;
                  IF DEBUG  THEN
                BEGIN
                   WRITELN('R offset is - ',R);
                   WRITELN('Writting Disk- ',DATA.LENGTH);
                END;
                     WRITE(DISK,DATA.DATA:DATA.LENGTH)
              END;
                     CREATE_CONTROL_PACKET(HEADER,DATA,'Y',HEADER.SEQ)
          END;
           IF REPLY <> ' ' THEN
           CREATE_CONTROL_PACKET(HEADER,DATA,'N',HEADER.SEQ);
           SEND_PACKET(HEADER,DATA)
       END;

    CLOSE(DISK);
    IF DEBUG THEN WRITELN('FINISHING RECEIVE_LOOP')
END;

(* ------------------------------------------------------------------
        The secondary Receive Routine
    set up this way to facilitate server implimentation
*)
PROCEDURE RECEIVE_ROUTINE(VAR HEADER:PACHEADER; VAR DATA:PACDATA);

VAR
    X:INTEGER;
    REPLY:CHAR;

BEGIN
    IF NOT IGNORE_PARMS THEN
        SET_DEFAULTS(HEADER,DATA);

    CREATE_SEND_INIT(HEADER,DATA,0);
    HEADER.PTYPE := 'Y';
    HEADER.CHECK := CHR(ORD(HEADER.CHECK) +6);
    SEND_PACKET(HEADER,DATA);

    REPEAT
         REPLY := 'S';
         RECEIVE_PACKET(HEADER,DATA,REPLY);
         IF REPLY <> ' ' THEN
         BEGIN
           CREATE_CONTROL_PACKET(HEADER,DATA,'N',HEADER.SEQ);
               SEND_PACKET(HEADER,DATA)
         END;
         IF  (REPLY = ' ') AND (HEADER.PTYPE<>'B') THEN
            RECEIVE_LOOP(HEADER,DATA)
    UNTIL (HEADER.PTYPE = 'E') OR (HEADER.PTYPE = 'B');

    IF HEADER.PTYPE <> 'E' THEN
        BEGIN
           CREATE_CONTROL_PACKET(HEADER,DATA,'Y',HEADER.SEQ);
           SEND_PACKET(HEADER,DATA)
        END
END;

(* ------------------------------------------------------------------

*)
PROCEDURE RECEIVE;

VAR
    HEADER:PACHEADER;
    DATA:PACDATA;
    REPLY :CHAR;

BEGIN
    OPEN_SCREEN;
    REPLY := 'S';
    RECEIVE_PACKET(HEADER,DATA,REPLY);
    WHILE (REPLY <> ' ') DO
        BEGIN
            CREATE_CONTROL_PACKET(HEADER,DATA,'N',0);
            SEND_PACKET(HEADER,DATA);
            REPLY := 'S';
            RECEIVE_PACKET(HEADER,DATA,REPLY);
        END;
    RECEIVE_ROUTINE(HEADER,DATA);
END;

(* ------------------------------------------------------------------

*)
PROCEDURE SERVER;

VAR
    DATAFILE:NAMETYPE;
    CHECK:CHAR;
    HEADER:PACHEADER;
    DATA:PACDATA;
    X:INTEGER;

BEGIN
    WRITELN('Server started.  You may return to micro');
    REPEAT
        OPEN_SCREEN;
    REPEAT
        CHECK := 'S';
        RECEIVE_PACKET(HEADER,DATA,CHECK);
    UNTIL (CHECK=' ');

    IF HEADER.PTYPE = 'R' THEN
      BEGIN
        IF DEBUG THEN WRITELN('SERVER BEGINNING SEND');
        FOR X:= 1 TO NAMELENGTH DO
            IF DATA.LENGTH => X
                THEN DATAFILE[X] := DATA.DATA[X]
                ELSE DATAFILE[X] := ' ';
        OPEN_FILE(DATAFILE,'R');
        SEND_ROUTINE(DATAFILE);
      END;
    IF HEADER.PTYPE = 'S' THEN
       BEGIN
        IF DEBUG THEN WRITELN('SERVER BEGINNING RECEIVE');
        RECEIVE_ROUTINE(HEADER,DATA);
       END;
    UNTIL HEADER.PTYPE = 'G';

    CREATE_CONTROL_PACKET(HEADER,DATA,'Y',HEADER.SEQ);
    SEND_PACKET(HEADER,DATA);
END;

(* ------------------------------------------------------------------

        USER INTERFACE ROUTINES

   ----------------------------------------------------------------- *)

(* _______________________________________________________________
        Displays value of Kermit parameters
*)
PROCEDURE DISPLAY_DEFAULTS;
BEGIN
    WRITELN;
    WRITELN(' Sending End of line character (ASCII): ',ORD(SEND_ELN));
    WRITELN(' Maximum Sending packet length: ',SEND_MLEN);
    WRITELN(' Maximum Receiving packet length: ',REC_MLEN);
    WRITELN(' Quote character used in receiving: ',REC_QCHR);
    WRITE(' Eigth bit I-O: ');
    IF DEBUG THEN WRITELN('ON')
         ELSE WRITELN('OFF');
    WRITE(' Debug flag: ');
    IF DEBUG THEN WRITELN('ON')
         ELSE WRITELN('OFF');
    WRITE(' Ignore the parameters other Kermit sends: ');
    IF IGNORE_PARMS THEN WRITELN('ON')
            ELSE WRITELN('OFF');
    WRITE(' Make the EOLN character printable in SEND INIT: ');
    IF KCHAR_ELN THEN WRITELN('ON')
             ELSE WRITELN('OFF');
    WRITE(' Change CRLF to NL on input and the reverse on output: ');
    IF CENDLN  THEN WRITELN('ON')
           ELSE WRITELN('OFF');
    WRITELN
END;

(* _______________________________________________________________
       Allows one to change the initial default settings
*)
PROCEDURE CHANGE_DEFAULTS;

VAR
    STATE,CHOICE :CHAR;
    OPTION :CHAR;
    VALUE : INTEGER;

   FUNCTION GET_ON:BOOLEAN;
       BEGIN
        REPEAT
            WRITE('Input choice (Y=ON , N=OFF): ');
            READLN(CHOICE);
            IF NOT((CHOICE='Y') OR (CHOICE='N'))
                THEN WRITELN('Invalid entry')
        UNTIL (CHOICE='Y') OR (CHOICE='N');
        IF CHOICE = 'Y'
            THEN GET_ON := TRUE
            ELSE GET_ON := FALSE
       END;

BEGIN
    WRITE('Change: ');
    IF EOLN(INPUT)
        THEN OPTION := ' '
        ELSE READ(OPTION);
    READLN;
    WRITE('<27>','<30>','<30>','<30>','<30>','<30>','<30>');
    WRITE('<30>','<30>','<30>','      ');
    CASE OPTION OF
        'E' : BEGIN
              VALUE := ORD(CR);
              WRITE('ASCII number of SEND EOL character: ');
              READLN(VALUE);
              SEND_ELN := CHR(VALUE)
              END;
        'S' : BEGIN
              WRITE('Maximum Length of Send Packet: ');
              READLN(VALUE);
              IF EIGHTBIT
                THEN SEND_MLEN := VALUE
                ELSE SEND_MLEN := XAND(VALUE,95);
              END;
        'R' : BEGIN
              WRITE('Maximum Length of Receive Packet: ');
              READLN(VALUE);
              IF EIGHTBIT
                THEN REC_MLEN := VALUE
                ELSE REC_MLEN := XAND(VALUE,95);
              END;
        'Q' : BEGIN
              VALUE := ORD('#');
              WRITE('ASCII number of QUOTE character: ');
              READLN(VALUE);
              REC_QCHR := CHR(VALUE)
              END;
        '8' : EIGHTBIT := GET_ON;
        'D' : DEBUG := GET_ON;
        'C' : CENDLN := GET_ON;
        'I' : IGNORE_PARMS := GET_ON;
        'M' : KCHAR_ELN := GET_ON;
        'H' : BEGIN
             WRITELN;
             WRITELN;
             WRITELN(' E - End of line character for sending packets');
             WRITELN(' D - Debug flag');
             WRITELN(' S - Maximun Length of Send Packet');
             WRITELN(' R - Maximun Length of Receive Packet');
             WRITELN(' M - Make EOLN printable in SEND INIT');
             WRITELN(' 8 - Use eight bit I-O');
             WRITELN(' C - Change NL to CRLF and CRLF to NL');
             WRITELN(' Q - Quote character in receiving');
             WRITELN(' H - this Help message');
             WRITELN(' I - Ignore the parameters set by other Kermit');
             WRITELN
              END;
        OTHERWISE
        WRITELN('INVALID ENTRY');
    END;
    WRITELN
END;

(* _______________________________________________________________

*)
PROCEDURE MAIN;

VAR
    OPTION: CHAR;

BEGIN
    REC_QCHR := '#';
    SEND_ELN := CR;
    SEND_MLEN := 74;
    REC_MLEN := 94;
    KCHAR_ELN := TRUE;
    IGNORE_PARMS := TRUE;
    DEBUG := FALSE;
    EIGHTBIT := FALSE;
    CENDLN := TRUE;
    REPEAT
        WRITE ('KERMIT-DG> ');
        READLN (OPTION);
          CASE OPTION OF
            'S' : SEND ;
            'R' : RECEIVE;
            'I' : SERVER;
            'E' : WRITELN('TERMINATING');
            'C' : CHANGE_DEFAULTS;
            'D' : DISPLAY_DEFAULTS;
          OTHERWISE
            WRITELN ('BAD INPUT')
          END
    UNTIL ( OPTION = 'E');
END;

(* ------------------------------------------------------------------
        The Program block

   -----------------------------------------------------------------
*)
BEGIN
    MAIN
END.