{--------------------------------------------------------}
{
{    Protocolo XMODEM-1024 CRC
{
{    Autor: Jose' Antonio Borges
{
{    Em abril/95
{
{--------------------------------------------------------}


Unit XModem;

interface

uses dvCrt, disComm, crc;


function xmodemSend (nomearq: string): integer;
function xmodemReceive (nomearq: string): integer;
procedure utilizaCrc (opcao: boolean);

{--------------------------------------------------------}
{                  retornos das rotinas
{--------------------------------------------------------}
{
        0 - Ok, bem transmitido
        1 - Arquivo nao encontrado
        2 - Erro na leitura do arquivo
        3 - Nao sincronizou com parceiro
        4 - Limite de tentativas de transmissao esgotado
        5 - Faltou confirmacao do fechamento do arquivo
        6 - Erro na criacao do arquivo
        7 - Erro na escrita do arquivo
        8 - Erro de transmissao ou parceiro mudo
        9 - Erro de sequencia dos blocos
}

{--------------------------------------------------------}
{                  constantes e variaveis
{--------------------------------------------------------}

implementation

{$r-}           { a aritmetica em word e' considerada sem overflow }

const
    NAK = #21;
    ACK = #6;
    SOH = #1;
    STX = #2;
    EOT = #4;
    CAN = #24;

    XM_OK      = 0;
    XM_ARQNENC = 1;
    XM_ERROARQ = 2;
    XM_NAOSINC = 3;
    XM_LIMTENT = 4;
    XM_ERRFIM  = 5;
    XM_ARQNCRI = 6;
    XM_ERRESC  = 7;
    XM_ERROREC = 8;
    XM_ERROSEQ = 9;

var block: array [0..1023] of char;
    arq: file;
    usaCrc: boolean;

{--------------------------------------------------------}
{                 imprime em hexa
{--------------------------------------------------------}

procedure hex(i: integer);
const codhex: array [0..15] of char = 
    ('0', '1', '2', '3', '4','5','6','7',
     '8','9','a','b','c','d','e','f');
begin
    write (codhex [i shr 12]);
    write (codhex [(i shr 8) and $f]);
    write (codhex [(i shr 4) and $f]);
    write (codhex [i and $f]);
end;

{--------------------------------------------------------}
{            recebe um caractere com timeout
{--------------------------------------------------------}

function recebeCarac (maxtempo: integer; var timeout: boolean): char;
var 
    c: char;
    i: integer;

begin
    for i := 0 to maxtempo div 50 do
        begin
            if chegouLink then
                begin
                    timeout := false;
                    lelink (c);
                    recebeCarac := c;
                    exit;
                end;

            delay (50);
        end;

    timeout := true;
    recebeCarac := #$ff;
end;

{--------------------------------------------------------}
{     envia arquivo segundo protocolo Xmodem 1024-CRC
{--------------------------------------------------------}

procedure sendXModemBlock (blockn: byte; tamBloco: word; comCrc: boolean);
var 
    i: integer;
    checksum: byte;
    crc: word;

begin
    checksum := 0;
    crc := 0;

    if tamBloco = 1024 then
        esclink (STX)
    else
        esclink (SOH);

    esclink (chr (blockn));
    esclink (chr(blockn xor $ff));

    for i := 0 to tambloco-1 do
        begin
            esclink (block[i]);
            if comCrc then
                atualizaCRC (crc, ord(block[i]))
            else
                checksum := (checksum + ord(block[i])) and $ff;
        end;

    if comCrc then
        begin
            esclink (chr (hi (crc)));
            esclink (chr (lo (crc)));
        end
    else
        esclink (chr(checksum));
end;

{--------------------------------------------------------}

function xmodemSend (nomearq: string): integer;
var
    numBloco: byte;
    n: integer;
    c: char;
    timeout, mandaBloco, comCrc: boolean;
    tamBloco, lidos, nrep: word;
    faltaTransm: longint;

label
    iniciaTransmissao, proximoBloco, fim, cancelou;

begin
    xmodemSend := 0;

    assign (arq, nomearq);
    {$I-} reset (arq, 1); {$I+}
    if ioresult <> 0 then
        begin
            xmodemSend := XM_ARQNENC;    { retorno 1: arquivo nao encontrado }
            goto fim;
        end;

    c := #$0;
    comCrc := false;
    for nrep := 1 to 60 do
        begin
            if nrep = 1 then
                while chegouLink do lelink (c)     { limpa o buffer }
            else
                c := recebeCarac (1000, timeout);
            comCRC := (c = 'C') and usaCrc;

            if (c = NAK) or comCrc then goto iniciaTransmissao;

            if keypressed then
                if readkey = #$1b then
                    begin
                        xmodemSend := XM_ERRFIM;
                        goto cancelou;
                    end;
        end;

    xmodemSend := XM_NAOSINC;     { retorno 3: nao recebeu NAK inicial }
    goto fim;

iniciaTransmissao:
    tamBloco := 1024;
    numBloco := 1;
    faltaTransm := filesize (arq);

    while not eof (arq) do
        begin
            if faltaTransm < 1024 then
                tamBloco := 128;
            faltaTransm := faltaTransm - tamBloco;

            {$I-} blockread (arq, block, tamBloco, lidos); {$I+}
            if ioresult <> 0 then
                begin
                    xmodemSend := XM_ERROARQ;   { erro no arquivo }
                    goto fim;
                end;

            for n := lidos to tamBloco-1 do
                block[n] := ^Z;

            nrep := 0;

            mandaBloco := true;
            for nrep := 1 to 20 do
                begin
                    if keypressed then
                        if readkey = #$1b then
                            begin
                                esclink (CAN);
                                xmodemSend := XM_ERRFIM;
                                goto cancelou;
                            end;

                    if mandaBloco then
                         begin
                             while chegouLink do lelink (c);
                             sendXmodemBlock (numBloco, tamBloco, comCrc);
                             mandaBloco := false;
                         end;

                    if nrep = 1 then
                        begin sound (100); delay (100); nosound; end
                    else
                        begin sound (200); delay (100); nosound; end;

                    c := recebeCarac (2000, timeout);

                    case c of
                        'C', NAK: mandaBloco := true;

                        ACK: begin
                                 numBloco := (numBloco + 1) and $ff;
                                 goto proximoBloco;
                             end;

                        CAN: begin
                                 esclink (ACK);
                                 goto fim;
                             end;
                    end;

                end;

            xModemsend := XM_LIMTENT;    { limite de tentativas esgotado }
cancelou:
            esclink (CAN);
            c := recebeCarac (1000, timeout);
            goto fim;

proximoBloco:
        end;

    for nrep := 1 to 7 do
        begin
            esclink (EOT);
            c := recebeCarac (2000, timeout);
            if c = ACK then goto fim;
        end;

    if c <> ACK then
        xmodemSend := XM_ERRFIM;    { faltou ACK de EOT }

fim:
    close (arq);
end;

{--------------------------------------------------------}
{        recebe arquivo segundo protocolo Xmodem
{--------------------------------------------------------}

function recXModemBlock (var blockn: byte;
                         tamBloco: word; comCrc: boolean): boolean;
var
    invblockn, rchecksum, checksum: byte;
    rcrchi, rcrclo: byte;
    i, rcrc: word;
    timeout: boolean;
    crc: word;

begin
    recXmodemBlock := false;
    checksum := 0;
    blockn := ord (recebeCarac (500, timeout));
    if timeout then exit;
    invblockn := ord (recebeCarac (500, timeout));
    if timeout then exit;

    crc := 0;
    for i := 0 to tamBloco-1 do
        begin
             block[i] := recebeCarac (500, timeout);
             if timeout then exit;
             if comCrc then
                 atualizaCRC (crc, ord(block[i]))
             else
                 checksum := (checksum + ord(block[i])) and $ff;
        end;

    if comCrc then
        begin
            rcrchi := ord (recebeCarac (500, timeout));
            if timeout then exit;
            rcrclo := ord (recebeCarac (500, timeout));
            if timeout then exit;
            rcrc := (rcrchi shl 8) or rcrclo;
        end
    else
        begin
            rchecksum := ord (recebeCarac (500, timeout));
            if timeout then exit;
        end;

    if (invblockn xor $ff) <> blockn then exit;
    if comCrc then
        begin
            if (crc <> rcrc) then exit;
        end
    else
        if (checksum <> rchecksum) then exit;

    recXmodemBlock := true;
end;

{--------------------------------------------------------}

function recebeBloco (var numBloco: byte;
                      tamBloco: word; comCrc: boolean): integer;
var
    recebeu: boolean;
    nbloco: byte;

begin
    recebeBloco := 0;      { ok }
    recebeu := recXmodemBlock (nbloco, tamBloco, comCrc);

    if not recebeu then
        begin
            esclink (NAK);
            recebeBloco := XM_ERROREC;      { timeout ou checksum errado }
        end
    else

    if ((nbloco+1) and $ff) = numBloco then    {repetiu}
        esclink (ACK)
    else

    if numBloco = nbloco then
        begin
            {$i-} blockwrite (arq, block, tambloco); {$I+}
            if ioresult <> 0 then
                begin
                    recebeBloco := XM_ERRESC;   { retorno 2: erro de disco }
                    exit;
                end;

            numBloco := (numBloco+1) and $ff;
            esclink (ACK);

            sound (100); delay (100); nosound;
        end
    else
        recebeBloco := XM_ERROSEQ;    { bloco com sequencia errada }
end;

{--------------------------------------------------------}

function xmodemReceive (nomearq: string): integer;
const
    MAXTENT = 20;

var
    i: integer;
    c: char;
    numBloco, status, nrep: byte;
    processando, timeout, comCrc: boolean;
    primeiroBloco: boolean;
    tamBloco: word;

label fim, cancelou;

begin
    assign (arq, nomearq);
    {$I-} rewrite (arq, 1); {$I+}
    if ioresult <> 0 then
        begin
            xmodemReceive := XM_ARQNCRI;    { retorno 1: arquivo nao pode ser criado }
            esclink (CAN);
            exit;
        end;

    xmodemReceive := XM_OK;

    while chegouLink do 
        lelink (c);     { limpa o buffer }

    numBloco := 1;
    nrep := 0;
    processando := true;

    primeiroBloco := true;
    if usaCrc then
        begin
            comCrc := true;
            esclink ('C');
        end
    else
        begin
            comCRC := false;
            esclink (NAK);
        end;

    while processando and (nrep <= MAXTENT) do
        begin
            if keypressed then
                if readkey = #$1b then
                    begin
                        xmodemReceive := XM_ERRFIM;
                        goto cancelou;
                    end;

            nrep := nrep + 1;
            c := recebeCarac (5000, timeout);
            if timeout then
                begin
                    if (not primeiroBloco) or (not comCrc) then
                        esclink (NAK)
                    else
                        if nrep < 8 then
                            esclink ('C')
                        else
                            begin
                                esclink (NAK);
                                comCrc := false;
                            end;
                end;

            case c of
                 STX, SOH:  begin
                           if c = STX then
                               tamBloco := 1024
                           else
                               tamBloco := 128;

                           status := recebeBloco (numBloco, tamBloco, comCrc);
                           xmodemReceive := status;
                           if status = 0 then
                               begin
                                   nrep := 0;
                                   primeiroBloco := false;
                               end
                           else
                               if status in
                                       [XM_ARQNCRI, XM_ERRESC, XM_ERROSEQ] then
                                   processando := false;
                       end;

                 EOT:  begin
                           esclink (ACK);
                           processando := false;
                       end;

                 CAN:  begin
                           for i := 1 to 12 do
                               esclink (CAN);
                           processando := false;
                       end;

                 #$ff: ;  { timeout }

                 else
                     repeat
                         c := recebeCarac (100, timeout);
                     until timeout;
            end;
        end;

    if nrep >= MAXTENT then
        begin
            xmodemReceive := XM_NAOSINC;
cancelou:
            for i := 1 to 5 do
                begin
                    while chegoulink do lelink (c);
                    esclink (CAN);             { cancela transmissao }
                    c := recebeCarac (1000, timeout);
                    if c = ACK then goto fim;
                end;
        end;

fim:
    primeiroBloco := false;
    close (arq);
end;

{--------------------------------------------------------}
{                    utiliza CRC
{--------------------------------------------------------}

procedure utilizaCrc (opcao: boolean);
begin
    usaCrc := opcao;
end;


begin
    usaCrc := false;
end.
