Category : Modula II Source Code
Archive   : TALK3.ZIP
Filename : XMODEM2.MOD

 
Output of file : XMODEM2.MOD contained in archive : TALK3.ZIP
IMPLEMENTATION MODULE XModem2;

(* (C) Copyright 1987 Fitted Software Tools. All rights reserved.

This module is part of the example multitasking communications program
provided with the Fitted Software Tools' Modula-2 development system.

Registered users may use this program as is, or they may modify it to
suit their needs or as an exercise.

If you develop interesting derivatives of this program and would like
to share it with others, we encourage you to upload a copy to our BBS.


Updated to include XMODEM CRC
11/3/88 wsa
*)
(* $L+ *)


FROM SYSTEM IMPORT ADR;
FROM System IMPORT Move;
FROM InOut IMPORT WriteString, WriteCard;
FROM Keyboard IMPORT KeyPressed, GetKeyCh;
FROM ASCII IMPORT SOH, ACK, NAK, EOT, CAN;
FROM RS232 IMPORT Init, GetCom, PutCom;
FROM Display IMPORT Goto;
FROM Windows IMPORT Window, OpenWindow, CloseCurWindow;
FROM LongJump IMPORT JumpBuffer, SetJump, LongJump;
FROM Files IMPORT Read, Write;
FROM Ticker IMPORT Ticks, OneSecond, TenSeconds, OneMinute;
FROM CRC IMPORT ComputeCRC;

CONST
commentLine = 0;
commentPos = 1;
statLine = 1;
statPos = 1;
errLine = 2;
errPos = 1;

BlockSize = 128;
BlockHigh = BlockSize - 1;
BlockFactor = 64;

VAR jumpBuff :JumpBuffer;
fileBuffer :ARRAY [0..BlockSize*BlockFactor-1] OF CHAR;


PROCEDURE SendFile( filename :ARRAY OF CHAR;
fd :INTEGER;
UseCRC :BOOLEAN;
VAR ok :BOOLEAN );
VAR c :CHAR;
w :Window;
BEGIN
OpenWindow( w, 9,22, 13,75, TRUE, "XModem file transfer" );
Goto( commentLine, commentPos );
WriteString( "Sending file " ); WriteString( filename );
IF SetJump( jumpBuff ) = 0 THEN
Send( fd, UseCRC );
success( "File transfer terminated" );
END;
GetKeyCh( c );
CloseCurWindow;
END SendFile;


PROCEDURE ReceiveFile( filename :ARRAY OF CHAR;
fd :INTEGER;
UseCRC :BOOLEAN;
VAR ok :BOOLEAN );
VAR c :CHAR;
w :Window;
BEGIN
OpenWindow( w, 9,22, 13,75, TRUE, "XModem file transfer" );
Goto( commentLine, commentPos );
WriteString( "Receiving file " ); WriteString( filename );
IF SetJump( jumpBuff ) = 0 THEN
Rcv( fd, UseCRC );
success( "File transfer terminated" );
END;
GetKeyCh(c);
CloseCurWindow;
END ReceiveFile;


PROCEDURE Send( fd :INTEGER; UseCRC :BOOLEAN );
VAR i, n :CARDINAL;
blockCount, sumck :CARDINAL;
errors :CARDINAL;
c, blk :CHAR;
ok :BOOLEAN;
buff :ARRAY [0..BlockHigh] OF CHAR;
crc :CARDINAL; (* wsa *)

PROCEDURE AbortXmit( msg :ARRAY OF CHAR );
BEGIN
error( msg );
LongJump( jumpBuff, 1 );
END AbortXmit;

PROCEDURE UpdtStatus;
BEGIN
Goto( statLine, statPos );
WriteString( "Blocks sent: " );
WriteCard( blockCount, 1 );
WriteString( ", Errors: " );
WriteCard( errors, 1 );
END UpdtStatus;


BEGIN
blockCount := 0; blk := 1C;
errors := 0;
LOOP
GetCh( c, OneMinute, ok );
IF NOT ok THEN AbortXmit( "no receiver" ) END;
IF c = CAN THEN AbortXmit( "cancelled by receiver" ) END;
IF c = NAK THEN UseCRC := FALSE; EXIT END; (* wsa *)
IF c = "C" THEN UseCRC := TRUE; EXIT END (* wsa *)
END;
LOOP
UpdtStatus;
Read( fd, ADR(buff), BlockSize, n );
IF n = 0 THEN EXIT END;
IF n < BlockSize THEN
WHILE n < BlockSize DO buff[n] := 0C; INC(n) END;
END;
LOOP
PutCom( SOH );
PutCom( blk ); PutCom( CHR(255 - ORD(blk)) );
sumck := 0; crc := 0; (* wsa *)
FOR i := 0 TO BlockHigh DO
PutCom( buff[i] );
IF UseCRC THEN (* wsa *)
crc := ComputeCRC( crc, buff[i] ); (* wsa *)
ELSE (* wsa *)
INC( sumck, ORD(buff[i]) );
END; (* wsa *)
END;
IF UseCRC THEN (* wsa *)
crc := ComputeCRC( crc, 0C ); (* wsa *)
crc := ComputeCRC( crc, 0C ); (* wsa *)
PutCom( CHR(crc DIV 100H) ); (* wsa *)
PutCom( CHR(crc MOD 100H) ); (* wsa *)
ELSE
PutCom( CHR(sumck MOD 100H) ); (* wsa *)
END; (* wsa *)
GetCh( c, TenSeconds, ok );
IF NOT ok THEN AbortXmit( "timeout" ) END;
IF c = ACK THEN
INC( blockCount );
blk := CHR(blockCount+1);
EXIT;
ELSIF c = CAN THEN AbortXmit( "cancelled by receiver" )
ELSE
INC( errors );
END;
END;
END;
PutCom( EOT );
END Send;


PROCEDURE Rcv( fd :INTEGER; UseCRC :BOOLEAN );
VAR i : CARDINAL;
blk, blk1 : CHAR;
blockCount : CARDINAL;
lastblk, nextblk : CHAR;
sumck, sumck1 : CARDINAL;
timeouts, errors,
retries, crctries : CARDINAL; (* wsa *)
c, crc1, crc2 : CHAR;
ok : BOOLEAN;
buff : ARRAY [0..BlockHigh] OF CHAR;
inBuffer : CARDINAL;
crc : CARDINAL; (* wsa *)

PROCEDURE AbortRcv( msg :ARRAY OF CHAR );
BEGIN
error( msg );
LongJump( jumpBuff, 1 );
END AbortRcv;

PROCEDURE WriteBuff( flush :BOOLEAN );
VAR n :CARDINAL;
BEGIN
Move( ADR(buff), ADR(fileBuffer[inBuffer*BlockSize]), BlockSize );
INC( inBuffer );
IF (inBuffer = BlockFactor) OR flush THEN
Write( fd, ADR(fileBuffer), inBuffer*BlockSize, n );
IF n <> inBuffer*BlockSize THEN
AbortRcv( "error writing to file" );
END;
inBuffer := 0;
END;
END WriteBuff;

PROCEDURE UpdtStatus;
BEGIN
Goto( statLine, statPos );
WriteString( "Blocks received: " );
WriteCard( blockCount, 1 );
WriteString( ", Errors: " );
WriteCard( errors+retries, 1 );
END UpdtStatus;

BEGIN
inBuffer := 0;
blockCount := 0; lastblk := 0C; nextblk := 1C;
errors := 0; retries := 0; crctries := 0; (* wsa *)
IF UseCRC THEN (* wsa *)
PutCom( "C" );
ELSE (* wsa *)
PutCom( NAK );
END; (* wsa *)
LOOP
UpdtStatus;
timeouts := 0;
LOOP
GetCh( c, TenSeconds, ok );
IF ok THEN
IF c = SOH THEN EXIT END;
IF c = CAN THEN AbortRcv( "cancelled by sender" ) END; (* wsa *)
IF c = EOT THEN
WriteBuff( TRUE );
PutCom( ACK );
RETURN;
END;
ELSE
IF timeouts > 6 THEN AbortRcv( "timeout" ) END;
FlushInput;
IF UseCRC THEN (* wsa *)
PutCom( "C" ); (* wsa *)
ELSE (* wsa *)
PutCom( NAK );
END; (* wsa *)
INC( timeouts );
INC( crctries ); (* wsa *)
UseCRC := (crctries < 3); (* wsa *)
END;
END;
GetCh( blk, OneSecond, ok );
IF NOT ok THEN AbortRcv( "timeout" ) END;
GetCh( blk1, OneSecond, ok );
IF NOT ok THEN AbortRcv( "timeout" ) END;
i := 0;
LOOP
GetCh( buff[i], OneSecond, ok );
IF ok THEN INC( i )
ELSE EXIT END;
IF i >= BlockSize THEN EXIT END;
END;
GetCh( c, OneSecond, ok );
IF UseCRC THEN (* wsa *)
crc1 := c; (* wsa *)
IF ok THEN (* wsa *)
GetCh( crc2, OneSecond, ok ); (* wsa *)
END; (* wsa *)
ELSE (* wsa *)
sumck := ORD( c );
END; (* wsa *)
INC( retries );
IF NOT ok OR (blk <> CHR(255-ORD(blk1))) OR (i < BlockSize) THEN
(* bad or incomplete block *)
FlushInput;
PutCom( NAK );
ELSIF blk = lastblk THEN
(* resent previous block *)
PutCom( ACK );
INC( errors, retries-1 ); retries := 0;
ELSIF blk = nextblk THEN
IF UseCRC THEN (* wsa *)
crc := 0; (* wsa *)
FOR i := 0 TO BlockHigh DO crc := ComputeCRC( crc, buff[i]); END; (* wsa *)
crc := ComputeCRC( crc, crc1); (* wsa *)
crc := ComputeCRC( crc, crc2); (* wsa *)
ELSE (* wsa *)
sumck1 := 0;
FOR i := 0 TO BlockHigh DO INC( sumck1, ORD(buff[i]) ) END;
END; (* wsa *)
IF (UseCRC AND (crc = 0)) OR (* wsa *)
(NOT UseCRC AND ((sumck1 MOD 100H) = sumck)) THEN (* wsa *)
WriteBuff( FALSE );
PutCom( ACK );
INC( errors, retries-1 ); retries := 0;
lastblk := nextblk;
INC( blockCount );
nextblk := CHR( (blockCount+1) MOD 100H );
ELSE
FlushInput;
PutCom( NAK );
END;
ELSE
FlushInput;
PutCom( NAK );
END;
IF retries >= 10 THEN AbortRcv( "too many retries" ) END;
END;
END Rcv;


PROCEDURE FlushInput;
VAR c :CHAR;
input :BOOLEAN;
BEGIN
REPEAT
GetCh( c, 2, input ); (* timeout 50-100ms *)
UNTIL NOT input;
END FlushInput;


(*
This COM input routine does not suspend on RS232Signal as we need to
timeout and the Kernel does not provide that facility.
*)

PROCEDURE GetCh( VAR c :CHAR; timeout :CARDINAL; VAR input :BOOLEAN );
VAR ticks :CARDINAL;
BEGIN
ticks := Ticks;
LOOP
GetCom( c, input );
IF input THEN RETURN END;
IF Ticks - ticks > timeout THEN RETURN END;
END;
END GetCh;


PROCEDURE error( msg :ARRAY OF CHAR );
BEGIN
Goto( errLine, errPos );
WriteString( "--- " ); WriteString( msg ); WriteString( " --- " );
END error;


PROCEDURE success( msg :ARRAY OF CHAR );
BEGIN
Goto( errLine, errPos );
WriteString( "+++ " ); WriteString( msg ); WriteString( " +++ " );
END success;


END XModem2.


  3 Responses to “Category : Modula II Source Code
Archive   : TALK3.ZIP
Filename : XMODEM2.MOD

  1. Very nice! Thank you for this wonderful archive. I wonder why I found it only now. Long live the BBS file archives!

  2. This is so awesome! 😀 I’d be cool if you could download an entire archive of this at once, though.

  3. But one thing that puzzles me is the “mtswslnkmcjklsdlsbdmMICROSOFT” string. There is an article about it here. It is definitely worth a read: http://www.os2museum.com/wp/mtswslnk/