home *** CD-ROM | disk | FTP | other *** search
/ DP Tool Club 18 / CD_ASCQ_18_111294_W.iso / dos / prg / pas / pcl4p42 / xypacket.pas < prev   
Pascal/Delphi Source File  |  1994-08-23  |  12KB  |  423 lines
  1. (*********************************************)
  2. (*                                           *)
  3. (*  This program is donated to the Public    *)
  4. (*  Domain by MarshallSoft Computing, Inc.   *)
  5. (*  It is provided as an example of the use  *)
  6. (*  of the Personal Communications Library.  *)
  7. (*                                           *)
  8. (*********************************************)
  9.  
  10.  
  11. { $DEFINE DEBUG}
  12. {$I DEFINES.PAS}
  13.  
  14. unit xypacket;
  15.  
  16. interface
  17.  
  18. const xyBufferSize = 2048;
  19. type BufferType = array[0..xyBufferSize-1] of Byte;
  20.  
  21. Function TxPacket(Port:Integer;
  22.                   PacketNbr:Word;
  23.                   PacketSize:Word;
  24.               Var Buffer:BufferType;
  25.                   NCGbyte:Byte):Boolean;
  26. Function RxPacket(Port:Integer;
  27.                   PacketNbr:Word;
  28.               Var PacketSize:Word;
  29.               Var Buffer:BufferType;
  30.                   NCGbyte:Byte;
  31.               Var EOTflag:Boolean):Boolean;
  32. Function RxStartup(Port:Integer;
  33.               Var NCGbyte:Byte):Boolean;
  34. Function TxStartup(Port:Integer;
  35.               Var NCGbyte:Byte):Boolean;
  36. Function TxEOT(Port:Integer):Boolean;
  37.  
  38.  
  39. implementation
  40.  
  41. uses PCL4P,term_io,crc,hex_io,crt;
  42.  
  43.  
  44. const MAXTRY = 3;
  45.       LIMIT = 20;
  46.  
  47. const SOH = $01;
  48.       STX = $02;
  49.       EOT = $04;
  50.       ACK = $06;
  51.       NAK = $15;
  52.       CAN = $18;
  53.  
  54. Function TxPacket(Port:Integer;         (* Port # [0..3] *)
  55.                   PacketNbr:Word;       (* Packet # [0,1,2,...] *)
  56.                   PacketSize:Word;      (* Packet size [128,1024] *)
  57.               Var Buffer:BufferType;    (* 1K character buffer *)
  58.                   NCGbyte:Byte)         (* NAK, 'C', or 'G' *)
  59.                 : Boolean;              (* successfull *)
  60. Label 999;
  61. Var
  62.   I         : Integer;
  63.   Code      : Integer;
  64.   CheckSum  : Word;
  65.   Attempt   : Word;
  66.   PacketType: Byte;
  67. Begin
  68.   (* better be 128 or 1024 packet length *)
  69.   if PacketSize = 1024
  70.       then PacketType := STX
  71.       else PacketType := SOH;
  72.   PacketNbr := PacketNbr and $00ff;
  73.   (* make up to MAXTRY attempts to send this packet *)
  74.   for Attempt := 1 to MAXTRY do
  75.     begin
  76.       (* send SOH/STX  *)
  77.       PutChar(Port,PacketType);
  78.       (* send packet # *)
  79.       PutChar(Port,PacketNbr);
  80.       (* send 1's complement of packet *)
  81.       PutChar(Port,255-PacketNbr);
  82.       (* send data *)
  83.       CheckSum := 0;
  84.       for i := 0 to PacketSize - 1 do
  85.         begin
  86.           PutChar(Port,Buffer[i]);
  87.           (* update checksum *)
  88.           if NCGbyte<>NAK then CheckSum := UpdateCRC(CheckSum, Buffer[i])
  89.           else CheckSum := CheckSum + Buffer[i];
  90.         end;
  91. {$IFDEF DEBUG}
  92. write('<Checksum=$');
  93. WriteHexWord(CheckSum);
  94. write('>');
  95. {$ENDIF}
  96.       (* send checksum *)
  97.       if NCGbyte<>NAK then
  98.         begin
  99.           (* send 2 byte CRC *)
  100.           PutChar(Port, (CheckSum shr 8) and $00ff );
  101.           PutChar(Port, CheckSum and $00ff );
  102.         end
  103.       else (* NCGbyte = 'C' or 'G' *)
  104.         begin
  105.           (* send one byte checksum *)
  106.           PutChar(Port,CheckSum );
  107.         end;
  108.       (* don't wait for ACK if 'G' *)
  109.       if NCGbyte = Ord('G') then
  110.         begin
  111.            if PacketNbr = 0 then delay(SHORT_WAIT*ONE_SECOND div 2);
  112.            TxPacket := TRUE;
  113.            Goto 999
  114.         end;
  115.       (* wait for receivers ACK *)
  116.       Code := GetChar(Port,LONG_WAIT*ONE_SECOND);
  117.       if Code = CAN then
  118.          begin
  119.             WriteLn('Canceled by remote');
  120.             TxPacket := FALSE;
  121.             Goto 999;
  122.           end;
  123.       if Code = ACK then
  124.           begin
  125.             TxPacket := TRUE;
  126.             Goto 999
  127.           end;
  128.       if Code <> NAK then
  129.           begin
  130.             WriteLn('Out of sync');
  131.             TxPacket := FALSE;
  132.             Goto 999;
  133.           end;
  134.     end; (* end for *)
  135.   (* can't send packet ! *)
  136.   Writeln('Packet timeout for port ',Port);
  137.   TxPacket := FALSE;
  138.  999: end; (* end -- TxPacket *)
  139.  
  140. Function RxPacket(Port:Integer;           (* Port # 0..3 *)
  141.                   PacketNbr:Word;         (* Packet # [0,1,2,...] *)
  142.               Var PacketSize:Word;        (* Packet size (128 or 1024) *)
  143.               Var Buffer:BufferType;      (* 1K buffer *)
  144.                   NCGbyte:Byte;           (* NAK, 'C', or 'G' *)
  145.               Var EOTflag:Boolean)        (* EOT was received *)
  146.                   :Boolean;               (* success / failure *)
  147. Label 999;
  148. Var
  149.   I            : Integer;
  150.   Code         : Integer;
  151.   Attempt      : Word;
  152.   RxPacketNbr  : Word;
  153.   RxPacketNbrC : Word;
  154.   CheckSum     : Word;
  155.   RxCheckSum   : Word;
  156.   RxCheckSum1  : Word;
  157.   RxCheckSum2  : Word;
  158.   PacketType   : Byte;
  159. begin
  160.   PacketNbr := PacketNbr AND $00ff;
  161.   for Attempt := 1 to MAXTRY do
  162.     begin
  163.       (* wait for SOH / STX *)
  164.       Code := GetChar(Port,LONG_WAIT*ONE_SECOND);
  165.       if Code = -1 then
  166.         begin
  167.           WriteLn('Timed out waiting for sender');
  168.           RxPacket := FALSE;
  169.           Goto 999
  170.         end;
  171.       case Code of
  172.         SOH: begin
  173.                (* 128 byte buffer incoming *)
  174.                PacketType := SOH;
  175.                PacketSize := 128
  176.              end;
  177.         STX: begin
  178.                (* 1024 byte buffer incoming *)
  179.                PacketType := STX;
  180.                PacketSize := 1024;
  181.              end;
  182.         EOT: begin
  183.                (* all packets have been sent *)
  184.                PutChar(Port,ACK);
  185.                EOTflag := TRUE;
  186.                RxPacket := TRUE;
  187.                goto 999
  188.              end;
  189.         CAN: begin
  190.                (* sender has canceled ! *)
  191.                SayError(Port,'Canceled by remote');
  192.                RxPacket := FALSE;
  193.              end;
  194.         else
  195.             begin
  196.               (* error ! *)
  197.               Write('Expecting SOH/STX/EOT/CAN not $');
  198.               WriteHexByte(Code);
  199.               Writeln;
  200.               RxPacket := FALSE;
  201.             end;
  202.       end;
  203.       (* receive packet # *)
  204.       Code := GetChar(Port,ONE_SECOND);
  205.       if Code = -1 then
  206.         begin
  207.           WriteLn('timed out waiting for packet #');
  208.           goto 999;
  209.         end;
  210.       RxPacketNbr := $00ff and Code;
  211.       (* receive 1's complement *)
  212.       Code := GetChar(Port,ONE_SECOND);
  213.       if Code =-1 then
  214.         begin
  215.           WriteLn('timed out waiting for complement of packet #');
  216.           RxPacket := FALSE;
  217.           Goto 999
  218.         end;
  219.       RxPacketNbrC := $00ff and Code;
  220.       (* receive data *)
  221.       CheckSum := 0;
  222.       for i := 0 to PacketSize - 1 do
  223.         begin
  224.           Code := GetChar(Port,ONE_SECOND);
  225.           if Code = -1 then
  226.             begin
  227.               WriteLn('timed out waiting for data for packet #');
  228.               RxPacket := FALSE;
  229.               Goto 999
  230.             end;
  231.           Buffer[i] := Code;
  232.           (* compute CRC or checksum *)
  233.           if NCGbyte<>NAK
  234.             then CheckSum := UpdateCRC(CheckSum,Code)
  235.             else CheckSum := (CheckSum + Code) AND $00ff;
  236.         end;
  237.       (* receive CRC/checksum *)
  238.       if NCGbyte<>NAK then
  239.         begin
  240.           (* receive 2 byte CRC *)
  241.           Code := GetChar(Port,ONE_SECOND);
  242.           if Code =-1 then
  243.             begin
  244.               WriteLn('timed out waiting for 1st CRC byte');
  245.               RxPacket := FALSE;
  246.               Goto 999
  247.             end;
  248.           RxCheckSum1 := Code AND $00ff;
  249.           Code := GetChar(Port,ONE_SECOND);
  250.           if Code =-1 then
  251.             begin
  252.               WriteLn('timed out waiting for 2nd CRC byte');
  253.               RxPacket := FALSE;
  254.               Goto 999
  255.             end;
  256.           RxCheckSum2 := Code AND $00ff;
  257.           RxCheckSum := (RxCheckSum1 SHL 8) OR RxCheckSum2;
  258.         end
  259.       else
  260.         begin
  261.           (* receive one byte checksum *)
  262.           Code := GetChar(Port,ONE_SECOND);
  263.           if Code = -1 then
  264.             begin
  265.               WriteLn('timed out waiting for checksum');
  266.               RxPacket := FALSE;
  267.               Goto 999
  268.              end;
  269.           RxCheckSum := Code AND $00ff;
  270.         end;
  271. {$IFDEF DEBUG}
  272. write('<Checksum: Received=$');
  273. WriteHexWord(RxCheckSum);
  274. write(', Computed=$');
  275. WriteHexWord(CheckSum);
  276. write('>');
  277. {$ENDIF}
  278.      (* don't send ACK if 'G' *)
  279.       if NCGbyte = Ord('G') then
  280.         begin
  281.            RxPacket := TRUE;
  282.            Goto 999
  283.         end;
  284.      (* packet # and checksum OK ? *)
  285.      if (RxCheckSum=CheckSum) and (RxPacketNbr=PacketNbr) then
  286.        begin
  287.          (* ACK the packet *)
  288.          PutChar(Port,ACK);
  289.          RxPacket := TRUE;
  290.          Goto 999
  291.        end;
  292.      (* bad packet *)
  293.      WriteMsg('Bad Packet',1);
  294.      PutChar(Port,NAK)
  295.    end;
  296.    (* can't receive packet *)
  297.    SayError(Port,'RX packet timeout');
  298.    RxPacket := FALSE;
  299. 999: end; (* end -- RxPacket *)
  300.  
  301. Function TxStartup(Port:Integer;
  302.                Var NCGbyte:Byte):Boolean;
  303. Label 999;
  304. Var
  305.   Code : Integer;
  306.   I : Integer;
  307.   Result : Boolean;
  308. Begin
  309.   (* clear Rx buffer *)
  310.   Code := SioRxFlush(Port);
  311.   (* wait for receivers start up NAK or 'C' *)
  312.   for i := 1 to LIMIT do
  313.     begin
  314.       if KeyPressed then
  315.         begin
  316.           SayError(Port,'Aborted by user');
  317.           Result := FALSE;
  318.           Goto 999
  319.         end;
  320.       Code := GetChar(Port,SHORT_WAIT*ONE_SECOND);
  321.       if Code <> -1  then
  322.         begin
  323.          (* received a byte *)
  324.          if Code = NAK then
  325.            begin
  326.              NCGbyte := NAK;
  327.              Result := TRUE;
  328.              Goto 999
  329.           end;
  330.         if Code = Ord('C') then
  331.           begin
  332.             NCGbyte := Ord('C');
  333.             Result := TRUE;
  334.             Goto 999
  335.           end;
  336.         if Code = Ord('G') then
  337.           begin
  338.             NCGbyte := Ord('G');
  339.             Result := TRUE;
  340.             Goto 999
  341.           end
  342.         end
  343.       end;
  344.   (* no response *)
  345.   SayError(Port,'No response from receiver');
  346.   TxStartup := FALSE;
  347. 999:
  348.   TxStartup := Result;
  349. {$IFDEF DEBUG}
  350.   write('<TxStartup ');
  351.   if Result then writeln('successfull>')
  352.   else writeln('fails>');
  353. {$ENDIF}
  354. end; (* end -- TxStartup *)
  355.  
  356.  
  357. Function RxStartup(Port:Integer;
  358.                Var NCGbyte:Byte)
  359.                  : Boolean;
  360. Label 999;
  361. Var
  362.   I : Integer;
  363.   Code : Integer;
  364.   Result : Boolean;
  365. Begin
  366.   (* clear Rx buffer *)
  367.   Code := SioRxFlush(Port);
  368.   (* Send NAKs or 'C's *)
  369.   for I := 1 to LIMIT do
  370.     begin
  371.       if KeyPressed then
  372.         begin
  373.           SayError(Port,'Canceled by user');
  374.           Result := FALSE;
  375.           Goto 999
  376.         end;
  377.       (* stop attempting CRC after 1st 4 tries *)
  378.       if (NCGbyte<>NAK) and (i=5) then  NCGbyte := NAK;
  379.       (* tell sender that I am ready to receive *)
  380.       PutChar(Port,NCGbyte);
  381.       Code := GetChar(Port,SHORT_WAIT*ONE_SECOND);
  382.       if Code <> -1 then
  383.         begin
  384.           (* no error -- must be incoming byte -- push byte back onto queue ! *)
  385.           Code := SioUnGetc(Port,Code);
  386.           Result := TRUE;
  387.           Goto 999
  388.         end;
  389.     end; (* for i *)
  390.   (* no response *)
  391.   SayError(Port,'No response from sender');
  392.   Result := FALSE;
  393. 999:
  394.   RxStartup := Result;
  395. {$IFDEF DEBUG}
  396.   write('<RxStartup ');
  397.   if Result then writeln('successfull>')
  398.   else writeln('fails>');
  399. {$ENDIF}
  400. end; (* end -- RxStartup *)
  401.  
  402. Function TxEOT(Port:Integer):Boolean;
  403. Label 999;
  404. Var
  405.   I    : Integer;
  406.   Code : Integer;
  407. Begin
  408.   for I := 0 to 10 do
  409.     begin
  410.       PutChar(Port,EOT);
  411.       (* await response *)
  412.       Code := GetChar(Port,SHORT_WAIT*ONE_SECOND);
  413.       if Code = ACK then
  414.         begin
  415.           TxEOT := TRUE;
  416.           Goto 999
  417.         end
  418.     end; (* end -- for I) *)
  419.   TxEOT := FALSE;
  420. 999: end; (* end -- TxEOT *)
  421.  
  422. end.
  423.