home *** CD-ROM | disk | FTP | other *** search
/ Boston 2 / boston-2.iso / DOS / PROGRAM / MODULA / FSTCOMPI / XMODEM.MOD < prev   
Text File  |  1993-12-01  |  8KB  |  294 lines
  1. IMPLEMENTATION MODULE XModem;
  2.  
  3. (* (C) Copyright 1987 Fitted Software Tools. All rights reserved.
  4.  
  5.     This module is part of the example multitasking communications program
  6.     provided with the Fitted Software Tools' Modula-2 development system.
  7.  
  8.     Registered users may use this program as is, or they may modify it to
  9.     suit their needs or as an exercise.
  10.  
  11.     If you develop interesting derivatives of this program and would like
  12.     to share it with others, we encourage you to upload a copy to our BBS.
  13. *)
  14.  
  15.  
  16. FROM SYSTEM     IMPORT ADR;
  17. FROM System     IMPORT Move;
  18. FROM InOut      IMPORT WriteString, WriteCard;
  19. FROM Keyboard   IMPORT KeyPressed, GetKeyCh;
  20. FROM ASCII      IMPORT SOH, ACK, NAK, EOT, CAN;
  21. FROM RS232      IMPORT Init, GetCom, PutCom;
  22. FROM Display    IMPORT Goto;
  23. FROM Windows    IMPORT Window, OpenWindow, CloseCurWindow;
  24. FROM LongJump   IMPORT JumpBuffer, SetJump, LongJump;
  25. FROM Files      IMPORT Read, Write;
  26. FROM Ticker     IMPORT Ticks, OneSecond, TenSeconds, OneMinute;
  27.  
  28. CONST
  29.     commentLine = 0;
  30.     commentPos  = 1;
  31.     statLine    = 1;
  32.     statPos     = 1;
  33.     errLine     = 2;
  34.     errPos      = 1;
  35.  
  36.     BlockSize   = 128;
  37.     BlockHigh   = BlockSize - 1;
  38.     BlockFactor = 64;
  39.  
  40. VAR jumpBuff    :JumpBuffer;
  41.     fileBuffer  :ARRAY [0..BlockSize*BlockFactor-1] OF CHAR;
  42.  
  43.  
  44. PROCEDURE SendFile( filename :ARRAY OF CHAR; fd :INTEGER; VAR ok :BOOLEAN );
  45. VAR c   :CHAR;
  46.     w   :Window;
  47. BEGIN
  48.     OpenWindow( w, 9,22, 13,75, TRUE, "XModem file transfer" );
  49.     Goto( commentLine, commentPos );
  50.     WriteString( "Sending file " ); WriteString( filename );
  51.     IF SetJump( jumpBuff ) = 0 THEN
  52.         Send( fd );
  53.         success( "File transfer terminated" );
  54.     END;
  55.     GetKeyCh( c );
  56.     CloseCurWindow;
  57. END SendFile;
  58.  
  59.  
  60. PROCEDURE ReceiveFile( filename :ARRAY OF CHAR; fd :INTEGER; VAR ok :BOOLEAN );
  61. VAR c   :CHAR;
  62.     w   :Window;
  63. BEGIN
  64.     OpenWindow( w, 9,22, 13,75, TRUE, "XModem file transfer" );
  65.     Goto( commentLine, commentPos );
  66.     WriteString( "Receiving file " ); WriteString( filename );
  67.     IF SetJump( jumpBuff ) = 0 THEN
  68.         Rcv( fd );
  69.         success( "File transfer terminated" );
  70.     END;
  71.     GetKeyCh(c);
  72.     CloseCurWindow;
  73. END ReceiveFile;
  74.  
  75.  
  76. PROCEDURE Send( fd :INTEGER );
  77. VAR i, n :CARDINAL;
  78.     blockCount, sumck :CARDINAL;
  79.     errors :CARDINAL;
  80.     c, blk :CHAR;
  81.     ok :BOOLEAN;
  82.     buff :ARRAY [0..BlockHigh] OF CHAR;
  83.  
  84.     PROCEDURE AbortXmit( msg :ARRAY OF CHAR );
  85.     BEGIN
  86.         error( msg );
  87.         LongJump( jumpBuff, 1 );
  88.     END AbortXmit;
  89.  
  90.     PROCEDURE UpdtStatus;
  91.     BEGIN
  92.         Goto( statLine, statPos );
  93.         WriteString( "Blocks sent: " );
  94.         WriteCard( blockCount, 1 );
  95.         WriteString( ", Errors: " );
  96.         WriteCard( errors, 1 );
  97.     END UpdtStatus;
  98.  
  99.  
  100. BEGIN
  101.     blockCount := 0; blk := 1C;
  102.     errors := 0;
  103.     LOOP
  104.         GetCh( c, OneMinute, ok );
  105.         IF NOT ok THEN AbortXmit( "no receiver" ) END;
  106.         IF c = CAN THEN AbortXmit( "cancelled by receiver" ) END;
  107.         IF c = NAK THEN EXIT END;
  108.     END;
  109.     LOOP
  110.         UpdtStatus;
  111.         Read( fd, ADR(buff), BlockSize, n );
  112.         IF n = 0 THEN EXIT END;
  113.         IF n < BlockSize THEN
  114.             WHILE n < BlockSize DO buff[n] := 0C; INC(n) END;
  115.         END;
  116.         LOOP
  117.             PutCom( SOH );
  118.             PutCom( blk ); PutCom( CHR(255 - ORD(blk)) );
  119.             sumck := 0;
  120.             FOR i := 0 TO BlockHigh DO
  121.                 PutCom( buff[i] );
  122.                 INC( sumck, ORD(buff[i]) );
  123.             END;
  124.             PutCom( CHR(sumck MOD 100H) );
  125.             GetCh( c, TenSeconds, ok );
  126.             IF NOT ok THEN AbortXmit( "timeout" ) END;
  127.             IF c = ACK THEN
  128.                 INC( blockCount );
  129.                 blk := CHR(blockCount+1);
  130.                 EXIT;
  131.             (*
  132.             ELSIF c = CAN THEN AbortXmit( "cancelled by receiver" )
  133.             *)
  134.             ELSE
  135.                 INC( errors );
  136.             END;
  137.         END;
  138.     END;
  139.     PutCom( EOT );
  140. END Send;
  141.  
  142.  
  143. PROCEDURE Rcv( fd :INTEGER );
  144. VAR i   :CARDINAL;
  145.     blk, blk1 :CHAR;
  146.     blockCount :CARDINAL;
  147.     lastblk, nextblk :CHAR;
  148.     sumck, sumck1 :CARDINAL;
  149.     timeouts, errors, retries :CARDINAL;
  150.     c :CHAR;
  151.     ok :BOOLEAN;
  152.     buff :ARRAY [0..BlockHigh] OF CHAR;
  153.     inBuffer :CARDINAL;
  154.  
  155.     PROCEDURE AbortRcv( msg :ARRAY OF CHAR );
  156.     BEGIN
  157.         error( msg );
  158.         LongJump( jumpBuff, 1 );
  159.     END AbortRcv;
  160.  
  161.     PROCEDURE WriteBuff( flush :BOOLEAN );
  162.     VAR n :CARDINAL;
  163.     BEGIN
  164.         Move( ADR(buff), ADR(fileBuffer[inBuffer*BlockSize]), BlockSize );
  165.         INC( inBuffer );
  166.         IF (inBuffer = BlockFactor) OR flush THEN
  167.             Write( fd, ADR(fileBuffer), inBuffer*BlockSize, n );
  168.             IF n <> inBuffer*BlockSize THEN
  169.                 AbortRcv( "error writing to file" );
  170.             END;
  171.             inBuffer := 0;
  172.         END;
  173.     END WriteBuff;
  174.  
  175.     PROCEDURE UpdtStatus;
  176.     BEGIN
  177.         Goto( statLine, statPos );
  178.         WriteString( "Blocks received: " );
  179.         WriteCard( blockCount, 1 );
  180.         WriteString( ", Errors: " );
  181.         WriteCard( errors+retries, 1 );
  182.     END UpdtStatus;
  183.  
  184. BEGIN
  185.     inBuffer := 0;
  186.     blockCount := 0; lastblk := 0C; nextblk := 1C;
  187.     errors := 0; retries := 0;
  188.     PutCom( NAK );
  189.     LOOP
  190.         UpdtStatus;
  191.         timeouts := 0;
  192.         LOOP
  193.             GetCh( c, TenSeconds, ok );
  194.             IF ok THEN
  195.                 IF c = SOH THEN EXIT END;
  196.                 IF c = EOT THEN
  197.                     WriteBuff( TRUE );
  198.                     PutCom( ACK );
  199.                     RETURN;
  200.                 END;
  201.             ELSE
  202.                 IF timeouts > 6 THEN AbortRcv( "timeout" ) END;
  203.                 FlushInput;
  204.                 PutCom( NAK );
  205.                 INC( timeouts );
  206.             END;
  207.         END;
  208.         GetCh( blk, OneSecond, ok );
  209.         IF NOT ok THEN AbortRcv( "timeout" ) END;
  210.         GetCh( blk1, OneSecond, ok );
  211.         IF NOT ok THEN AbortRcv( "timeout" ) END;
  212.         i := 0;
  213.         LOOP
  214.             GetCh( buff[i], OneSecond, ok );
  215.             IF ok THEN INC( i )
  216.             ELSE EXIT END;
  217.             IF i >= BlockSize THEN EXIT END;
  218.         END;
  219.         GetCh( c, OneSecond, ok );
  220.         sumck := ORD( c );
  221.         INC( retries );
  222.         IF NOT ok OR (blk <> CHR(255-ORD(blk1))) OR (i < BlockSize) THEN
  223.             (* bad or incomplete block *)
  224.             FlushInput;
  225.             PutCom( NAK );
  226.         ELSIF blk = lastblk THEN
  227.             (* resent previous block *)
  228.             PutCom( ACK );
  229.             INC( errors, retries-1 ); retries := 0;
  230.         ELSIF blk = nextblk THEN
  231.             sumck1 := 0;
  232.             FOR i := 0 TO BlockHigh DO INC( sumck1, ORD(buff[i]) ) END;
  233.             IF sumck1 MOD 100H = sumck THEN
  234.                 WriteBuff( FALSE );
  235.                 PutCom( ACK );
  236.                 INC( errors, retries-1 ); retries := 0;
  237.                 lastblk := nextblk;
  238.                 INC( blockCount );
  239.                 nextblk := CHR( (blockCount+1) MOD 100H );
  240.             ELSE
  241.                 FlushInput;
  242.                 PutCom( NAK );
  243.             END;
  244.         ELSE
  245.             FlushInput;
  246.             PutCom( NAK );
  247.         END;
  248.         IF retries >= 10 THEN AbortRcv( "too many retries" ) END;
  249.     END;
  250. END Rcv;
  251.  
  252.  
  253. PROCEDURE FlushInput;
  254. VAR c     :CHAR;
  255.     input :BOOLEAN;
  256. BEGIN
  257.     REPEAT
  258.         GetCh( c, 2, input );   (* timeout 50-100ms *)
  259.     UNTIL NOT input;
  260. END FlushInput;
  261.  
  262.  
  263. (*
  264.     This COM input routine does not suspend on RS232Signal as we need to
  265.     timeout and the Kernel does not provide that facility.
  266. *)
  267.  
  268. PROCEDURE GetCh( VAR c :CHAR; timeout :CARDINAL; VAR input :BOOLEAN );
  269. VAR ticks   :CARDINAL;
  270. BEGIN
  271.     ticks := Ticks;
  272.     LOOP
  273.         GetCom( c, input );
  274.         IF input THEN RETURN END;
  275.         IF Ticks - ticks > timeout THEN RETURN END;
  276.     END;
  277. END GetCh;
  278.  
  279.  
  280. PROCEDURE error( msg :ARRAY OF CHAR );
  281. BEGIN
  282.     Goto( errLine, errPos );
  283.     WriteString( "--- " ); WriteString( msg ); WriteString( " --- " );
  284. END error;
  285.  
  286.  
  287. PROCEDURE success( msg :ARRAY OF CHAR );
  288. BEGIN
  289.     Goto( errLine, errPos );
  290.     WriteString( "+++ " ); WriteString( msg ); WriteString( " +++ " );
  291. END success;
  292.  
  293.  
  294. END XModem.