ProfitPress Mega CDROM2 …eeware (MSDOS)(1992)(Eng)/ProfitPress-MegaCDROM2.B6I/PROG/PASCAL/PCL4P30.ZIP/XYPACKET.PAS

Pascal/Delphi Source File | 1992-01-18 | 11.0 KB | 405 lines

(*********************************************)
(*                                           *)
(*  This program is donated to the Public    *)
(*  Domain by MarshallSoft Computing, Inc.   *)
(*  It is provided as an example of the use  *)
(*  of the Personal Communications Library.  *)
(*                                           *)
(*********************************************)


{ $DEFINE DEBUG}

unit xypacket;

interface

type BufferType = array[0..1023] of Byte;

Function TxPacket(Port:Integer;
                  PacketNbr:Word;
                  PacketSize:Word;
              Var Buffer:BufferType;
                  CRCflag:Boolean):Boolean;
Function RxPacket(Port:Integer;
                  PacketNbr:Word;
              Var PacketSize:Word;
              Var Buffer:BufferType;
                  CRCflag:Boolean;
              Var EOTflag:Boolean):Boolean;
Function RxStartup(Port:Integer;
              Var CRCflag:Boolean):Boolean;
Function TxStartup(Port:Integer;
              Var CRCflag:Boolean):Boolean;
Function TxEOT(Port:Integer):Boolean;


implementation

uses PCL4P,term_io,crc,hex_io,crt;


const ONESECOND = 18;
      MAXTRY = 3;
      LIMIT = 20;

const SOH = $01;
      STX = $02;
      EOT = $04;
      ACK = $06;
      NAK = $15;
      CAN = $18;

Function TxPacket(Port:Integer;         (* Port # [0..3] *)
                  PacketNbr:Word;       (* Packet # [0,1,2,...] *)
                  PacketSize:Word;      (* Packet size [128,1024] *)
              Var Buffer:BufferType;    (* 1K character buffer *)
                  CRCflag:Boolean)      (* use CRC flag *)
                : Boolean;              (* successfull *)
Label 999;
Var
  I         : Integer;
  Code      : Integer;
  CheckSum  : Word;
  Attempt   : Word;
  PacketType: Byte;
Begin
  (* better be 128 or 1024 packet length *)
  if PacketSize = 1024
      then PacketType := STX
      else PacketType := SOH;
  PacketNbr := PacketNbr and $00ff;
  (* make up to MAXTRY attempts to send this packet *)
  for Attempt := 1 to MAXTRY do
    begin
      (* send SOH/STX  *)
      PutChar(Port,PacketType);
      (* send packet # *)
      PutChar(Port,PacketNbr);
      (* send 1's complement of packet *)
      PutChar(Port,255-PacketNbr);
      (* send data *)
      CheckSum := 0;
      for i := 0 to PacketSize - 1 do
        begin
          PutChar(Port,Buffer[i]);
          (* update checksum *)
          if CRCflag then CheckSum := UpdateCRC(CheckSum, Buffer[i])
          else CheckSum := CheckSum + Buffer[i];
        end;
{$IFDEF DEBUG}
write('<Checksum=$');
WriteHexWord(CheckSum);
write('>');
{$ENDIF}
      (* send checksum *)
      if CRCflag then
        begin
          (* send 2 byte CRC *)
          PutChar(Port, (CheckSum shr 8) and $00ff );
          PutChar(Port, CheckSum and $00ff );
        end
      else (* not CRCflag *)
        begin
          (* send one byte checksum *)
          PutChar(Port,CheckSum );
        end;
      (* wait for receivers ACK *)
      Code := GetChar(Port,10*ONESECOND);
      if Code = CAN then
         begin
            WriteLn('Canceled by remote');
            TxPacket := FALSE;
            Goto 999;
          end;
      if Code = ACK then
          begin
            TxPacket := TRUE;
            Goto 999
          end;
      if Code <> NAK then
          begin
            WriteLn('Out of sync');
            TxPacket := FALSE;
            Goto 999;
          end;
    end; (* end for *)
  (* can't send packet ! *)
  Writeln('Packet timeout for port ',Port);
  TxPacket := FALSE;
 999: end; (* end -- TxPacket *)

Function RxPacket(Port:Integer;           (* Port # 0..3 *)
                  PacketNbr:Word;         (* Packet # [0,1,2,...] *)
              Var PacketSize:Word;        (* Packet size (128 or 1024) *)
              Var Buffer:BufferType;      (* 1K buffer *)
                  CRCflag:Boolean;        (* use CRC flag *)
              Var EOTflag:Boolean)        (* EOT was received *)
                  :Boolean;               (* success / failure *)
Label 999;
Var
  I            : Integer;
  Code         : Integer;
  Attempt      : Word;
  RxPacketNbr  : Word;
  RxPacketNbrC : Word;
  CheckSum     : Word;
  RxCheckSum   : Word;
  RxCheckSum1  : Word;
  RxCheckSum2  : Word;
  PacketType   : Byte;
begin
  PacketNbr := PacketNbr AND $00ff;
  for Attempt := 1 to MAXTRY do
    begin
      (* wait for SOH / STX *)
      Code := GetChar(Port,10*ONESECOND);
      if Code = -1 then
        begin
          WriteLn('Timed out waiting for sender');
          RxPacket := FALSE;
          Goto 999
        end;
      case Code of
        SOH: begin
               (* 128 byte buffer incoming *)
               PacketType := SOH;
               PacketSize := 128
             end;
        STX: begin
               (* 1024 byte buffer incoming *)
               PacketType := STX;
               PacketSize := 1024;
             end;
        EOT: begin
               (* all packets have been sent *)
               PutChar(Port,ACK);
               EOTflag := TRUE;
               RxPacket := TRUE;
               goto 999
             end;
        CAN: begin
               (* sender has canceled ! *)
               SayError(Port,'Canceled by remote');
               RxPacket := FALSE;
             end;
        else
            begin
              (* error ! *)
              Write('Expecting SOH/STX/EOT/CAN not $');
              WriteHexByte(Code);
              Writeln;
              RxPacket := FALSE;
            end;
      end;
      (* receive packet # *)
      Code := GetChar(Port,ONESECOND);
      if Code = -1 then
        begin
          WriteLn('timed out waiting for packet #');
          goto 999;
        end;
      RxPacketNbr := $00ff and Code;
      (* receive 1's complement *)
      Code := GetChar(Port,ONESECOND);
      if Code =-1 then
        begin
          WriteLn('timed out waiting for complement of packet #');
          RxPacket := FALSE;
          Goto 999
        end;
      RxPacketNbrC := $00ff and Code;
      (* receive data *)
      CheckSum := 0;
      for i := 0 to PacketSize - 1 do
        begin
          Code := GetChar(Port,ONESECOND);
          if Code = -1 then
            begin
              WriteLn('timed out waiting for data for packet #');
              RxPacket := FALSE;
              Goto 999
            end;
          Buffer[i] := Code;
          (* compute CRC or checksum *)
          if CRCflag
            then CheckSum := UpdateCRC(CheckSum,Code)
            else CheckSum := (CheckSum + Code) AND $00ff;
        end;
      (* receive CRC/checksum *)
      if CRCflag then
        begin
          (* receive 2 byte CRC *)
          Code := GetChar(Port,ONESECOND);
          if Code =-1 then
            begin
              WriteLn('timed out waiting for 1st CRC byte');
              RxPacket := FALSE;
              Goto 999
            end;
          RxCheckSum1 := Code AND $00ff;
          Code := GetChar(Port,ONESECOND);
          if Code =-1 then
            begin
              WriteLn('timed out waiting for 2nd CRC byte');
              RxPacket := FALSE;
              Goto 999
            end;
          RxCheckSum2 := Code AND $00ff;
          RxCheckSum := (RxCheckSum1 SHL 8) OR RxCheckSum2;
        end
      else
        begin
          (* receive one byte checksum *)
          Code := GetChar(Port,ONESECOND);
          if Code = -1 then
            begin
              WriteLn('timed out waiting for checksum');
              RxPacket := FALSE;
              Goto 999
             end;
          RxCheckSum := Code AND $00ff;
        end;
{$IFDEF DEBUG}
write('<Checksum: Received=$');
WriteHexWord(RxCheckSum);
write(', Computed=$');
WriteHexWord(CheckSum);
write('>');
{$ENDIF}
     (* packet # and checksum OK ? *)
     if (RxCheckSum=CheckSum) and (RxPacketNbr=PacketNbr) then
       begin
         (* ACK the packet *)
         PutChar(Port,ACK);
         RxPacket := TRUE;
         Goto 999
       end;
     (* bad packet *)
     WriteMsg('Bad Packet',1);
     PutChar(Port,NAK)
   end;
   (* can't receive packet *)
   SayError(Port,'RX packet timeout');
   RxPacket := FALSE;
999: end; (* end -- RxPacket *)

Function TxStartup(Port:Integer;
               Var CRCflag:Boolean):Boolean;
Label 999;
Var
  Code : Integer;
  I : Integer;
  Result : Boolean;
Begin
  (* clear Rx buffer *)
  Code := SioRxFlush(Port);
  (* wait for receivers start up NAK or 'C' *)
  for i := 1 to LIMIT do
    begin
      if KeyPressed then
        begin
          SayError(Port,'Aborted by user');
          Result := FALSE;
          Goto 999
        end;
      Code := GetChar(Port,3*ONESECOND);
      if Code <> -1  then
        begin
         (* received a byte *)
         if Code = NAK then
           begin
             CRCflag := FALSE;
             Result := TRUE;
             Goto 999
          end;
        if Code = Ord('C') then
          begin
            CRCflag := TRUE;
            Result := TRUE;
            Goto 999
          end
        end
      end;
  (* no response *)
  SayError(Port,'No response from receiver');
  TxStartup := FALSE;
999:
  TxStartup := Result;
{$IFDEF DEBUG}
  write('<TxStartup ');
  if Result then writeln('successfull>')
  else writeln('fails>');
{$ENDIF}
end; (* end -- TxStartup *)


Function RxStartup(Port:Integer;
               Var CRCflag:Boolean)
                 : Boolean;
Label 999;
Var
  I : Integer;
  Code : Integer;
  Result : Boolean;
Begin
  (* clear Rx buffer *)
  Code := SioRxFlush(Port);
  (* Send NAKs or 'C's *)
  for I := 1 to LIMIT do
    begin
      if KeyPressed then
        begin
          SayError(Port,'Canceled by user');
          Result := FALSE;
          Goto 999
        end;
      (* stop attempting CRC after 1st 4 tries *)
      if CRCflag and (i=5) then  CRCflag := FALSE;
      (* tell sender that I am ready to receive *)
      if CRCflag
         then PutChar(Port,Ord('C'))
         else PutChar(Port,NAK);
      Code := GetChar(Port,3*ONESECOND);
      if Code <> -1 then
        begin
          (* no error -- must be incoming byte -- push byte back onto queue ! *)
          Code := SioUnGetc(Port,Code);
          Result := TRUE;
          Goto 999
        end;
    end; (* for i *)
  (* no response *)
  SayError(Port,'No response from sender');
  Result := FALSE;
999:
  RxStartup := Result;
{$IFDEF DEBUG}
  write('<RxStartup ');
  if Result then writeln('successfull>')
  else writeln('fails>');
{$ENDIF}
end; (* end -- RxStartup *)

Function TxEOT(Port:Integer):Boolean;
Label 999;
Var
  I    : Integer;
  Code : Integer;
Begin
  for I := 0 to 10 do
    begin
      PutChar(Port,EOT);
      (* await response *)
      Code := GetChar(Port,3*ONESECOND);
      if Code = ACK then
        begin
          TxEOT := TRUE;
          Goto 999
        end
    end; (* end -- for I) *)
  TxEOT := FALSE;
999: end; (* end -- TxEOT *)

end.