Category : Modula II Source Code
Archive   : PCKERM.ZIP
Filename : PAD.MOD

IMPLEMENTATION MODULE PAD; (* Packet Assembler/Disassembler for Kermit *)

FROM InOut IMPORT
Write, WriteString, WriteInt, WriteHex, WriteLn;

FROM Terminal IMPORT
ReadString, Read, KeyPressed;

FROM Strings IMPORT
Length;

FROM BitByteOps IMPORT
ByteXor;

FROM FileSystem IMPORT
File;

FROM Files IMPORT
Status, FileType, Open, Create, CloseFile, Get, Put, DoWrite;

FROM DataLink IMPORT
FlushUART, SendPacket, ReceivePacket;

IMPORT ASCII;


CONST
myMAXL = 94;
myTIME = 10;
myNPAD = 0;
myPADC = 0C;
myEOL = 0C;
myQCTL = '#';
myQBIN = '&';
myCHKT = '1'; (* one character checksum *)
MAXtrys = 5;

TYPE
(* From Definition Module:
PacketType = ARRAY [1..100] OF CHAR;
*)
PathnameType = ARRAY [0..40] OF CHAR;

VAR
yourMAXL : INTEGER; (* maximum packet length -- up to 94 *)
yourTIME : INTEGER; (* time out -- seconds *)
(* From Definition Module
yourNPAD : INTEGER; (* number of padding characters *)
yourPADC : CHAR; (* padding characters *)
yourEOL : CHAR; (* End Of Line -- terminator *)
*)
yourQCTL : CHAR; (* character for quoting controls '#' *)
yourQBIN : CHAR; (* character for quoting binary '&' *)
yourCHKT : CHAR; (* check type -- 1 = checksum, etc. *)
sF, rF : File; (* files being sent/received *)
sFname, rFname : PathnameType;
sP, rP : PacketType; (* packets sent/received *)
sSeq, rSeq : INTEGER; (* sequence numbers *)
PktNbr : INTEGER; (* actual packet number -- no repeats up to 32,000 *)


PROCEDURE Char (c : INTEGER) : CHAR;
(* converts a number 0-94 into a printable character *)
BEGIN
RETURN (CHR (CARDINAL (ABS (c) + 32)));
END Char;


PROCEDURE UnChar (c : CHAR) : INTEGER;
(* converts a character into its corresponding number *)
BEGIN
RETURN (ABS (INTEGER (ORD (c)) - 32));
END UnChar;


PROCEDURE Aborted() : BOOLEAN;

VAR
ch : CHAR;

BEGIN
IF KeyPressed() THEN
Read (ch);
IF ch = 033C THEN (* Escape *)
RETURN TRUE;
END;
END;
RETURN FALSE;
END Aborted;


PROCEDURE TellError (Seq : INTEGER);
(* Send error packet *)
BEGIN
sP[1] := Char (15);
sP[2] := Char (Seq);
sP[3] := 'E'; (* E-type packet *)
sP[4] := 'R'; (* error message starts *)
sP[5] := 'e';
sP[6] := 'm';
sP[7] := 'o';
sP[8] := 't';
sP[9] := 'e';
sP[10] := ' ';
sP[11] := 'A';
sP[12] := 'b';
sP[13] := 'o';
sP[14] := 'r';
sP[15] := 't';
sP[16] := 0C;
SendPacket (sP);
END TellError;


PROCEDURE ShowError (p : PacketType);
(* Output contents of error packet to the screen *)

VAR
i : INTEGER;

BEGIN
FOR i := 4 TO UnChar (p[1]) DO
Write (p[i]);
END;
WriteLn;
END ShowError;


PROCEDURE youInit (type : CHAR);
(* I initialization YOU for Send and Receive *)
BEGIN
sP[1] := Char (11); (* Length *)
sP[2] := Char (0); (* Sequence *)
sP[3] := type;
sP[4] := Char (myMAXL);
sP[5] := Char (myTIME);
sP[6] := Char (myNPAD);
sP[7] := CHAR (ByteXor (myPADC, 100C));
sP[8] := Char (ORD (myEOL));
sP[9] := myQCTL;
sP[10] := myQBIN;
sP[11] := myCHKT;
sP[12] := 0C; (* terminator *)
SendPacket (sP);
END youInit;


PROCEDURE myInit;
(* YOU initialize ME for Send and Receive *)

VAR
len : INTEGER;

BEGIN
len := UnChar (rP[1]);
IF len >= 4 THEN
yourMAXL := UnChar (rP[4]);
ELSE
yourMAXL := 94;
END;
IF len >= 5 THEN
yourTIME := UnChar (rP[5]);
ELSE
yourTIME := 10;
END;
IF len >= 6 THEN
yourNPAD := UnChar (rP[6]);
ELSE
yourNPAD := 0;
END;
IF len >= 7 THEN
yourPADC := CHAR (ByteXor (rP[7], 100C));
ELSE
yourPADC := 0C;
END;
IF len >= 8 THEN
yourEOL := CHR (UnChar (rP[8]));
ELSE
yourEOL := 0C;
END;
IF len >= 9 THEN
yourQCTL := rP[9];
ELSE
yourQCTL := 0C;
END;
IF len >= 10 THEN
yourQBIN := rP[10];
ELSE
yourQBIN := 0C;
END;
IF len >= 11 THEN
yourCHKT := rP[11];
IF yourCHKT # myCHKT THEN
yourCHKT := '1';
END;
ELSE
yourCHKT := '1';
END;
END myInit;


PROCEDURE SendInit;
BEGIN
youInit ('S');
END SendInit;


PROCEDURE SendFileName;

VAR
i, j : INTEGER;

BEGIN
(* send file name *)
i := 4; j := 0;
WHILE sFname[j] # 0C DO
sP[i] := sFname[j];
INC (i); INC (j);
END;
sP[1] := Char (j + 3);
sP[2] := Char (sSeq);
sP[3] := 'F'; (* filename packet *)
sP[i] := 0C;
SendPacket (sP);
END SendFileName;


PROCEDURE SendEOF;
BEGIN
sP[1] := Char (3);
sP[2] := Char (sSeq);
sP[3] := 'Z'; (* end of file *)
sP[4] := 0C;
SendPacket (sP);
END SendEOF;



PROCEDURE SendEOT;
BEGIN
sP[1] := Char (3);
sP[2] := Char (sSeq);
sP[3] := 'B'; (* break -- end of transmit *)
sP[4] := 0C;
SendPacket (sP);
END SendEOT;


PROCEDURE GetAck() : BOOLEAN;
(* Look for acknowledgement -- retry on timeouts or NAKs *)

VAR
Type : CHAR;
Seq : INTEGER;
retrys : INTEGER;
AckOK : BOOLEAN;

BEGIN
WriteString ("Sent Packet #");
WriteInt (PktNbr, 5);
WriteString (" (ID: "); WriteHex (sSeq, 4);
WriteString ("h)");
WriteLn;

retrys := MAXtrys;
LOOP
IF Aborted() THEN
TellError (sSeq);
RETURN FALSE;
END;
IF (ReceivePacket (rP)) THEN
Seq := UnChar (rP[2]);
Type := rP[3];
IF (Seq = sSeq) AND (Type = 'Y') THEN
AckOK := TRUE;
ELSIF (Seq = (sSeq + 1) MOD 64) AND (Type = 'N') THEN
AckOK := TRUE; (* NAK for (n + 1) taken as ACK for n *)
ELSIF Type = 'E' THEN
ShowError (rP);
AckOK := FALSE;
retrys := 0;
ELSE
AckOK := FALSE;
END;
ELSE
AckOK := FALSE;
END;
IF AckOK OR (retrys = 0) THEN
EXIT;
ELSE
WriteString ("Resending Packet #");
WriteInt (PktNbr, 5);
WriteString (" (ID: "); WriteHex (sSeq, 4);
WriteString ("h)");
WriteLn;
DEC (retrys);
FlushUART;
SendPacket (sP);
END;
END;

IF AckOK THEN
INC (PktNbr);
sSeq := (sSeq + 1) MOD 64;
RETURN TRUE;
ELSE
RETURN FALSE;
END;
END GetAck;


PROCEDURE GetInitAck() : BOOLEAN;
(* configuration for remote station *)
BEGIN
IF GetAck() THEN
myInit;
RETURN TRUE;
ELSE
RETURN FALSE;
END;
END GetInitAck;


PROCEDURE Send;
(* Sends a file after prompting for filename *)

VAR
ch : CHAR;
i : INTEGER;

BEGIN
WriteString ("Send: (filename?): ");
ReadString (sFname);
WriteLn;
IF Length (sFname) = 0 THEN
RETURN;
END;
IF Open (sF, sFname) # Done THEN
WriteString ("No such file: "); WriteString (sFname);
WriteLn;
RETURN;
END;
WriteString ("( to abort file transfer.)");
WriteLn; WriteLn;
FlushUART;
sSeq := 0; PktNbr := 0;
SendInit; (* my configuration information *)
IF NOT GetInitAck() THEN (* get your configuration information *)
WriteString ("Excessive Errors..."); WriteLn;
RETURN;
END;

SendFileName;
IF NOT GetAck() THEN
WriteString ("Excessive Errors..."); WriteLn;
RETURN;
END;

(* send file *)
i := 4;
LOOP
IF Aborted() THEN
TellError (sSeq);
RETURN;
END;
IF Get (sF, ch) = EOF THEN (* send current packet & terminate *)
sP[1] := Char (i - 1);
sP[2] := Char (sSeq);
sP[3] := 'D'; (* data packet *)
sP[i] := 0C; (* indicate end of packet *)
SendPacket (sP);
IF NOT GetAck() THEN
WriteString ("Excessive Errors..."); WriteLn;
RETURN;
END;
SendEOF;
IF NOT GetAck() THEN
WriteString ("Excessive Errors..."); WriteLn;
RETURN;
END;
SendEOT;
IF NOT GetAck() THEN
WriteString ("Excessive Errors..."); WriteLn;
RETURN;
END;
EXIT;
END;

IF i >= (yourMAXL - 4) THEN (* send current packet *)
sP[1] := Char (i - 1);
sP[2] := Char (sSeq);
sP[3] := 'D';
sP[i] := 0C;
SendPacket (sP);
IF NOT GetAck() THEN
WriteString ("Excessive Errors..."); WriteLn;
RETURN;
END;
i := 4;
END;

(* add character to current packet -- update count *)
IF ch > 177C THEN (* must be quoted (QBIN) and altered *)
(* toggle bit 7 to turn it off *)
ch := CHAR (ByteXor (ch, 200C));
sP[i] := myQBIN; INC (i);
END;
IF (ch < 40C) OR (ch = 177C) THEN (* quote (QCTL) and alter *)
(* toggle bit 6 to turn it on *)
ch := CHAR (ByteXor (ch, 100C));
sP[i] := myQCTL; INC (i);
END;
IF (ch = myQCTL) OR (ch = myQBIN) THEN (* must send it quoted *)
sP[i] := myQCTL; INC (i);
END;
sP[i] := ch; INC (i);
END; (* loop *)

IF CloseFile (sF, Input) # Done THEN
WriteString ("Problem closing source file..."); WriteLn;
END;
END Send;


PROCEDURE ReceiveInit() : BOOLEAN;
(* receive my initialization information from you *)

VAR
RecOK : BOOLEAN;
errors : INTEGER;

BEGIN
errors := 0;
LOOP
IF Aborted() THEN
TellError (rSeq);
RETURN FALSE;
END;
RecOK := (ReceivePacket (rP)) AND (rP[3] = 'S');
IF RecOK OR (errors = MAXtrys) THEN
EXIT;
ELSE
INC (errors);
SendNak;
END;
END;

IF RecOK THEN
myInit;
RETURN TRUE;
ELSE
RETURN FALSE;
END;
END ReceiveInit;


PROCEDURE SendInitAck;
(* acknowledge your initialization of ME and send mine for YOU *)
BEGIN
WriteString ("Received Packet #");
WriteInt (PktNbr, 5);
WriteString (" (ID: "); WriteHex (rSeq, 4);
WriteString ("h)");
WriteLn;
INC (PktNbr);
rSeq := (rSeq + 1) MOD 64;
youInit ('Y');
END SendInitAck;


PROCEDURE ValidFileChar (VAR ch : CHAR) : BOOLEAN;
(* checks if character is one of 'A'..'Z', '0'..'9', makes upper case *)
BEGIN
ch := CAP (ch);
RETURN ((ch >= 'A') AND (ch <= 'Z')) OR ((ch >= '0') AND (ch <= '9'));
END ValidFileChar;


TYPE
HeaderType = (name, eot, fail);

PROCEDURE ReceiveHeader() : HeaderType;
(* receive the filename -- alter for local conditions, if necessary *)

VAR
i, j, k : INTEGER;
RecOK : BOOLEAN;
errors : INTEGER;

BEGIN
errors := 0;
LOOP
RecOK := ReceivePacket (rP) AND ((rP[3] = 'F') OR (rP[3] = 'B'));
IF errors = MAXtrys THEN
RETURN fail;
ELSIF RecOK AND (rP[3] = 'F') THEN
i := 4; (* data starts here *)
j := 0; (* beginning of filename string *)
WHILE (ValidFileChar (rP[i])) AND (j < 8) DO
rFname[j] := rP[i];
INC (i); INC (j);
END;
REPEAT
INC (i);
UNTIL (ValidFileChar (rP[i])) OR (rP[i] = 0C);
rFname[j] := '.'; INC (j);
k := 0;
WHILE (ValidFileChar (rP[i])) AND (k < 3) DO
rFname[j + k] := rP[i];
INC (i); INC (k);
END;
rFname[j + k] := 0C;
WriteString ("Filename = "); WriteString (rFname); WriteLn;
RETURN name;
ELSIF RecOK AND (rP[3] = 'B') THEN
RETURN eot;
ELSE
INC (errors);
SendNak;
END;
END;
END ReceiveHeader;


PROCEDURE SendNak;
BEGIN
WriteString ("Requesting Repeat of Packet #");
WriteInt (PktNbr, 5);
WriteString (" (ID: "); WriteHex (rSeq, 4);
WriteString ("h)");
WriteLn;
FlushUART;
sP[1] := Char (3); (* LEN *)
sP[2] := Char (rSeq);
sP[3] := 'N'; (* negative acknowledgement *)
sP[4] := 0C;
SendPacket (sP);
END SendNak;


PROCEDURE SendAck (Seq : INTEGER);
BEGIN
IF Seq # rSeq THEN
WriteString ("Duplicate Packet ");
ELSE
WriteString ("Received Packet #"); WriteInt (PktNbr, 5);
rSeq := (rSeq + 1) MOD 64;
INC (PktNbr);
END;
WriteString (" (ID: "); WriteHex (Seq, 4);
WriteString ("h)");
WriteLn;
sP[1] := Char (3);
sP[2] := Char (Seq);
sP[3] := 'Y'; (* acknowledgement *)
sP[4] := 0C;
SendPacket (sP);
END SendAck;


PROCEDURE Receive;
(* Receives a file (or files) *)

VAR
ch, Type : CHAR;
Seq : INTEGER;
i : INTEGER;
EOF, EOT, QBIN : BOOLEAN;
errors : INTEGER;

BEGIN
WriteString ("Ready to receive file(s)..."); WriteLn;
WriteString ("( to abort file transfer.)");
WriteLn; WriteLn;
FlushUART;
rSeq := 0; PktNbr := 0;
IF NOT ReceiveInit() THEN (* your configuration information *)
WriteString ("Excessive Errors..."); WriteLn;
RETURN;
END;
SendInitAck; (* send my configuration information *)
EOT := FALSE;
WHILE NOT EOT DO
IF Aborted() THEN
TellError (rSeq);
RETURN;
END;
CASE ReceiveHeader() OF
eot : EOT := TRUE; EOF := TRUE;
| name : IF Create (rF, rFname) # Done THEN
WriteString ("Unable to open file: ");
WriteString (rFname); WriteLn;
RETURN;
ELSE
PktNbr := 1;
EOF := FALSE;
END;
| fail : WriteString ("Excessive Errors..."); WriteLn;
RETURN;
END;
SendAck (rSeq); (* acknowledge for name or eot *)
WHILE NOT EOF DO
IF Aborted() THEN
TellError (rSeq);
RETURN;
END;
IF ReceivePacket (rP) THEN
Seq := UnChar (rP[2]);
Type := rP[3];
IF Type = 'Z' THEN
EOF := TRUE;
IF CloseFile (rF, Output) # Done THEN
WriteString ("Error closing file: ");
WriteString (rFname); WriteLn;
RETURN;
END;
SendAck (rSeq);
ELSIF Type = 'E' THEN
ShowError (rP);
RETURN;
ELSIF (Type = 'D') AND ((Seq + 1) MOD 64 = rSeq) THEN
(* discard duplicate packet, and Ack anyway *)
SendAck (Seq);
ELSIF (Type = 'D') AND (Seq = rSeq) THEN
(* put packet into file buffer *)
i := 4; (* first data in packet *)
WHILE rP[i] # 0C DO
ch := rP[i]; INC (i);
IF ch = yourQBIN THEN
ch := rP[i]; INC (i);
QBIN := TRUE;
ELSE
QBIN := FALSE;
END;
IF ch = yourQCTL THEN
ch := rP[i]; INC (i);
IF (ch # yourQCTL) AND (ch # yourQBIN) THEN
ch := CHAR (ByteXor (ch, 100C));
END;
END;
IF QBIN THEN
ch := CHAR (ByteXor (ch, 200C));
END;
Put (ch);
END;


(* write file buffer to disk *)
IF DoWrite (rF) # Done THEN
WriteString ("Error writing to file: ");
WriteString (rFname); WriteLn;
RETURN;
END;
errors := 0;
SendAck (rSeq);
ELSE
INC (errors);
IF errors = MAXtrys THEN
WriteString ("Excessive errors..."); WriteLn;
RETURN;
ELSE
SendNak;
END;
END;
ELSE
INC (errors);
IF errors = MAXtrys THEN
WriteString ("Excessive errors..."); WriteLn;
RETURN;
ELSE
SendNak;
END;
END;
END;
END;
END Receive;


BEGIN (* module initialization *)
yourEOL := ASCII.cr;
yourNPAD := 0;
yourPADC := 0C;
END PAD.