awzmodem.pas

Async Professional 4.04

          end;

          {Note frame type for status}
          zLastFrame := zRcvFrame;

          {...and leave}
          Exit;
        end;

        {Also leave if we got any errors or we got a cancel request}
        if (aProtocolError <> ecOK) or
           (aProtocolStatus = psCancelRequested) then
          Exit;
      end;
    end;
  end;

  function zpBlockError(P : PProtocolData;
                        OkState, ErrorState : TZmodemState;
                        MaxErrors : Cardinal) : Boolean;
    {-Handle routine block/timeout errors, return True if error}
  begin
    with P^ do begin
      Inc(aBlockErrors);
      Inc(aTotalErrors);
      if aBlockErrors > MaxErrors then begin
        zpBlockError := True;
        zpCancel(P);
        apProtocolError(P, ecTooManyErrors);
        zZmodemState := ErrorState;
      end else begin
        zpBlockError := False;
        zZmodemState := OkState;
      end;
    end;
  end;

  function zpReceiveBlock(P : PProtocolData;
                          var Block : TDataBlock) : Bool;
    {-Get a binary data subpacket, return True when block complete (or error)}
  var
    C : Char;
  begin
    with P^ do begin
      {Assume the block isn't ready}
      zpReceiveBlock := False;

      while aHC.CharReady do begin
        {Handle first pass}
        if (zDataBlockLen = 0) and (zRcvBlockState = rbData) then
          aBlockCheck := CheckInit[zUseCrc32];

        {Get the waiting character}
        aProtocolStatus := psOK;
        zpGetCharEscaped(P, C);
        if zEscapePending or (aProtocolStatus = psCancelRequested) then
          Exit;
        if zControlCharSkip then
          Exit;

        {Always update the block check}
        zpUpdateBlockCheck(P, Ord(C));

        case zRcvBlockState of
          rbData :
            case aProtocolStatus of
              psOK :     {Normal character}
                begin
                  {Check for a long block}
                  Inc(zDataBlockLen);
                  if zDataBlockLen > aBlockLen then begin
                    aProtocolStatus := psLongPacket;
                    Inc(aTotalErrors);
                    Inc(aBlockErrors);
                    zpReceiveBlock := True;
                    Exit;
                  end;

                  {Store the character}
                  Block[zDataBlockLen] := C;
                end;

              psGotCrcE,
              psGotCrcG,
              psGotCrcQ,
              psGotCrcW : {End of DataSubpacket - get/check CRC}
                begin
                  zRcvBlockState := rbCrc;
                  zCrcCnt := 0;
                  aSaveStatus := aProtocolStatus;
                end;
            end;

          rbCrc :
            begin
              Inc(zCrcCnt);
              if (zUseCrc32 and (zCrcCnt = 4)) or
                 (not zUseCrc32 and (zCrcCnt = 2)) then begin
                if not zpVerifyBlockCheck(P) then begin
                  Inc(aBlockErrors);
                  Inc(aTotalErrors);
                  aProtocolStatus := psBlockCheckError;
                end else
                  {Show proper status}
                  aProtocolStatus := aSaveStatus;

                {Say block is ready for processing}
                zpReceiveBlock := True;
                Exit;
              end;
            end;
        end;
      end;
    end;
  end;


  procedure zpExtractFileInfo(P : PProtocolData);
    {-Extracts file information into fields}
  var
    BlockPos  : Cardinal;
    I         : Integer;
    Code      : Integer;
    S         : String;
    {$IFDEF HugeStr}
    SLen      : Byte;
    {$ELSE}
    SLen      : Byte absolute S;
    {$ENDIF}
    S1        : ShortString;
    S1Len     : Byte absolute S1;
    Name      : ShortString;
    NameExt   : array[0..255] of Char;
  begin
    with P^ do begin
      {Extract the file name from the data block}
      BlockPos := 1;
      {$IFDEF HugeStr}
      SetLength(S, 1024);
      {$ENDIF}
      while (aDataBlock^[BlockPos] <> #0) and (BlockPos < 255) do begin
        S[BlockPos] := aDataBlock^[BlockPos];
        if S[BlockPos] = '/' then
          S[BlockPos] := '\';
        Inc(BlockPos);
      end;
      SLen := BlockPos - 1;
      {$IFDEF HugeStr}
      SetLength(S, SLen);
      {$ENDIF}                                                      
      if (SLen > 0) and (aUpcaseFileNames) then begin
        {$IFDEF HugeStr}
        AnsiUpperBuff(PChar(S), SLen);
        {$ELSE}
        AnsiUpperBuff(@S[1], SLen);
        {$ENDIF}
      end;

      {Set Pathname}
      {$IFDEF Win32}
      if Length(S) > 255 then
        SetLength(S, 255);
      {$ENDIF}
      StrPCopy(aPathname, S);

      {Should we use its directory or ours?}
      if not FlagIsSet(aFlags, apHonorDirectory) then begin
        Name := ExtractFileName(S);
        StrPCopy(NameExt, Name);
        AddBackSlashZ(aPathName, aDestDir);
        StrLCat(aPathName, NameExt, SizeOf(aPathName));
      end;

      {Extract the file size}
      I := 1;
      Inc(BlockPos);
      while (aDataBlock^[BlockPos] <> #0) and
            (aDataBlock^[BlockPos] <> ' ') and
            (I <= 255) do begin
        S1[I] := aDataBlock^[BlockPos];
        Inc(I); Inc(BlockPos);
      end;
      Dec(I);
      S1Len := I;
      if S1Len = 0 then
        aSrcFileLen := 0
      else begin
        Val(S1, aSrcFileLen, Code);
        if Code <> 0 then
          {Invalid date format, just ignore}
          aSrcFileLen := 0;
      end;
      aBytesRemaining := aSrcFileLen;
      aBytesTransferred := 0;

      {Extract the file date/time stamp}
      I := 1;
      Inc(BlockPos);
      while (aDataBlock^[BlockPos] <> #0) and
            (aDataBlock^[BlockPos] <> ' ') and
            (I <= 255) do begin
        S1[I] := aDataBlock^[BlockPos];
        Inc(I);
        Inc(BlockPos);
      end;
      Dec(I);
      S1Len := I;
      S1 := apTrimZeros(S1);
      if S1 = '' then
        aSrcFileDate := apYMTimeStampToPack(apCurrentTimeStamp)
      else
        aSrcFileDate := apYMTimeStampToPack(apOctalStr2Long(S1));   
    end;
  end;

  procedure zpWriteDataBlock(P : PProtocolData);
    {-Call WriteProtocolBlock for the last received DataBlock}
  var
    Failed : Bool;
  begin
    with P^ do begin
      {Write this block}
      Failed := apWriteProtocolBlock(P, aDataBlock^, zDataBlockLen);

      {Process result}
      if Failed then
        zpCancel(P)
      else begin
        Inc(aFileOfs, zDataBlockLen);
        Dec(aBytesRemaining, zDataBlockLen);
        Inc(aBytesTransferred, zDataBlockLen);
      end;
    end;
  end;

  procedure zpPrepareReceive(P : PProtocolData);
    {-Prepare to receive Zmodem parts}
  begin
    with P^ do begin
      {Init the status stuff}
      apResetStatus(P);
      apShowFirstStatus(P);
      NewTimer(aStatusTimer, aStatusInterval);
      aTimerStarted := False;

      {Flush input buffer}
      aHC.FlushInBuffer;

      {Init state variables}
      zHeaderType := ZrInit;
      zZmodemState := rzRqstFile;
      zHeaderState := hsNone;
      aProtocolError := ecOK;
    end;
  end;

  procedure zpReceive(Msg, wParam : Cardinal;
                     lParam : LongInt);
    {-Performs one increment of a Zmodem receive}
  label
    ExitPoint;
  var
    TriggerID   : Cardinal absolute wParam;
    P           : PProtocolData;
    Finished    : Bool;
    C           : Char;
    StatusTicks : LongInt;            
    Dispatcher      : TApdBaseDispatcher;
  begin
    Finished := False;                                                   {!!.01}
    {Get the protocol pointer from data pointer 1}
    Dispatcher := TApdBaseDispatcher(PortList[LH(lParam).H]);
    with Dispatcher do begin
      try                                                                {!!.01}
        {with ComPorts[LH(lParam).H] do}
        GetDataPointer(Pointer(P), 1);
      except                                                             {!!.01}
        on EAccessViolation do                                           {!!.01}
          { No access to P^, just exit }                                 {!!.01}
          Exit;
      end;                                                               {!!.01}

    with P^ do begin
      {$IFDEF Win32}
      EnterCriticalSection(aProtSection);

      {Exit if protocol was cancelled while waiting for crit section}
      if zZmodemState = rzDone then begin
        LeaveCriticalSection(aProtSection);
        Exit;
      end;
      {$ENDIF}
        {Set Trigger_ID directly for TriggerAvail messages}
        if Msg = apw_TriggerAvail then
          TriggerID := aDataTrigger;

        repeat
          try                                                            {!!.01}
            if Dispatcher.Logging then                                  
              {$IFDEF Win32}
              Dispatcher.AddDispatchEntry(
                dtZModem,LogZModemState[zZmodemState],GetCurrentThreadID,nil,0);
              {$ELSE}
              Dispatcher.AddDispatchEntry(
                dtZModem,LogZModemState[zZmodemState],0,nil,0);
              {$ENDIF}

            {Check for user abort}
            if aProtocolStatus <> psCancelRequested then begin
              if (Integer(TriggerID) = aNoCarrierTrigger) then begin
                zZmodemState := rzError;
                aProtocolStatus := psAbortNoCarrier;
              end;
              if Msg = apw_ProtocolCancel then begin
                zpCancel(P);
                zZmodemState := rzError;
              end;
            end;

            {Show status at requested intervals and after significant events}
            if aForceStatus or (Integer(TriggerID) = aStatusTrigger) then begin
              if aTimerStarted then
                aElapsedTicks := ElapsedTime(aTimer);
              if TimerTicksRemaining(aStatusTrigger,
                                      StatusTicks) <> 0 then
                StatusTicks := 0;
              if StatusTicks <= 0 then begin
                apShowStatus(P, 0);
                SetTimerTrigger(aStatusTrigger, aStatusInterval, True);
                aForceStatus := False;
              end;
              if Integer(TriggerID) = aStatusTrigger then begin         
                {$IFDEF Win32}
                LeaveCriticalSection(aProtSection);
                {$ENDIF}
                Exit;
              end;
            end;

            {Preprocess header requirements}
            case zZmodemState of
              rzWaitFile,
              rzStartData,
              rzWaitEof :
                if TriggerID = aDataTrigger then begin
                  {Header might be present, try to get one}
                  zpCheckForHeader(P);
                  if aProtocolStatus = psCancelRequested then
                    zZmodemState := rzError;
                end else if Integer(TriggerID) = aTimeoutTrigger then     
                  {Timed out waiting for something, let state machine handle it}
                  aProtocolStatus := psTimeout
                else
                  {Indicate that we don't have a header}
                  aProtocolStatus := psNoHeader;
            end;

            {Main state processor}
            case zZmodemState of
              rzRqstFile :
                begin
                  zCanCount := 0;

                  {Init pos/flag bytes to zero}
                  LongInt(zTransHeader) := 0;

                  {Set our receive options}
                  zTransHeader[ZF0] := CanFdx or     {Full duplex}
                                       CanOvIO or    {Overlap I/O}
                                       CanFc32 or    {Use Crc32 on frames}
                                       CanBrk;       {Can send break}

                  {Testing shows that Telix needs a delay here}
                  SetTimerTrigger(aTimeoutTrigger, TelixDelay, True);
                  zZmodemState := rzDelay;
                end;

              rzDelay :
                begin
                  {Send the header}
                  zpPutHexHeader(P, zHeaderType);