Turbo Toolbox/Turbo_Toolbox.iso/1989/09/modula/xmodem.mod

Modula Implementation | 1987-10-17 | 8.2 KB | 294 lines

IMPLEMENTATION MODULE XModem;

(* (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.
*)


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;

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; 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 );
        success( "File transfer terminated" );
    END;
    GetKeyCh( c );
    CloseCurWindow;
END SendFile;


PROCEDURE ReceiveFile( filename :ARRAY OF CHAR; fd :INTEGER; 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 );
        success( "File transfer terminated" );
    END;
    GetKeyCh(c);
    CloseCurWindow;
END ReceiveFile;


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

    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 EXIT END;
    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;
            FOR i := 0 TO BlockHigh DO
                PutCom( buff[i] );
                INC( sumck, ORD(buff[i]) );
            END;
            PutCom( CHR(sumck MOD 100H) );
            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 );
VAR i   :CARDINAL;
    blk, blk1 :CHAR;
    blockCount :CARDINAL;
    lastblk, nextblk :CHAR;
    sumck, sumck1 :CARDINAL;
    timeouts, errors, retries :CARDINAL;
    c :CHAR;
    ok :BOOLEAN;
    buff :ARRAY [0..BlockHigh] OF CHAR;
    inBuffer :CARDINAL;

    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;
    PutCom( NAK );
    LOOP
        UpdtStatus;
        timeouts := 0;
        LOOP
            GetCh( c, TenSeconds, ok );
            IF ok THEN
                IF c = SOH THEN EXIT END;
                IF c = EOT THEN
                    WriteBuff( TRUE );
                    PutCom( ACK );
                    RETURN;
                END;
            ELSE
                IF timeouts > 6 THEN AbortRcv( "timeout" ) END;
                PutCom( NAK );
                FlushInput;
                INC( timeouts );
            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 );
        sumck := ORD( c );
        INC( retries );
        IF NOT ok OR (blk <> CHR(255-ORD(blk1))) OR (i < BlockSize) THEN
            (* bad or incomplete block *)
            PutCom( NAK );
            FlushInput;
        ELSIF blk = lastblk THEN
            (* resent previous block *)
            PutCom( ACK );
            INC( errors, retries-1 ); retries := 0;
        ELSIF blk = nextblk THEN
            sumck1 := 0;
            FOR i := 0 TO BlockHigh DO INC( sumck1, ORD(buff[i]) ) END;
            IF sumck1 MOD 100H = sumck THEN
                WriteBuff( FALSE );
                PutCom( ACK );
                INC( errors, retries-1 ); retries := 0;
                lastblk := nextblk;
                INC( blockCount );
                nextblk := CHR( (blockCount+1) MOD 100H );
            ELSE
                PutCom( NAK );
                FlushInput;
            END;
        ELSE
            PutCom( NAK );
            FlushInput;
        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 XModem.