{--------------------------------------------------------}
{
{     Protocolo com o programa parceiro da Rende
{
{     Autor: Jos‚ Antonio Borges
{
{     Em abril/95
{
{--------------------------------------------------------}

unit disprot;
interface

uses windos, dvcrt, dvwin, dvhora, dvLeNum,
    disvars, dismsg, disfala, discomm, uuenc, xmodem;

function executaConexao (numScript: integer; conta, senha: string): boolean;
function ativaProgRende: boolean;
procedure executaDesconexao;
function empacotaPedidos: boolean;
procedure mostraErroXModem (erro: integer);
function enviaPedidos: boolean;
function recebeRespostas: boolean;
procedure desempacotaResposta;

implementation

const 
    NAK = #21;

var
    contaCarac: integer;
    comunicXmodem, iniciado: boolean;
    progParceiro: string;
    quantasRec: integer;
    debugScript: boolean;

{--------------------------------------------------------}
{                   sai string no link
{--------------------------------------------------------}

procedure escFrase (s: string);
var i: integer;
    c: char;
label sai;
begin
    for i := 1 to length (s) do
        begin
            esclink (s[i]);
            delay (100);
        end;
    esclink (#$0d);
end;

{--------------------------------------------------------}
{                   le string do link
{--------------------------------------------------------}

procedure leFrase (var s: string);
var c, c2: char;
begin
    s := '';
    repeat
        if chegoulink then
            begin
                lelink (c);
                if (c <> #$0d) and (c <> #$0a) then
                      s := s + c;

                    contaCarac := contaCarac + 1;
                    if contaCarac >= 500 then
                        begin
                            contaCarac := 0;
                            begin sound (100); delay (50); nosound; end;
                        end;
            end;

        if keypressed then
            begin
               c2 := readkey;
               if (c2 = ^Z) or (c2 = ^D) then
                   begin
                       s := '*FIM';
                       iniciado := true;
                       exit;
                   end;
            end;

    until c = #$0d;
end;

{--------------------------------------------------------}
{
{   Executa linha do script de conexao com servidor
{
{   Palavras chaves:
{     espera cadeia a esperar
{     frase  frase a escrever
{            frases especiais: <CONTA> <SENHA>
{     carac  caractere a escrever (em notacao decimal)
{     tempo  valor    (tempo em milissegundos a esperar)
{     limpabuf        (para ignorar o que o parceiro escrever)
{     fim             (fim do script)
{     prompt          (espera um dos seguintes:  # $ > ]
{     debug           (escreve um debug na tela)
{
}
{--------------------------------------------------------}

const
    SCRIPTOK = 0;
    SCRIPTERROCOMP = 1;
    SCRIPTERROEXEC = 2;
    SCRIPTFIM = 3;


function executaScript (linha: string; conta, senha: string): integer;
var s, cmd: string;
    c: char;
    erro, i: integer;
    w: word;
    
    procedure tiraBrancos;
    begin
        while (linha <> '') and (linha[1] = ' ') do
            delete (linha, 1, 1);
    end;

begin
    if debugScript then
        begin
            textBackGround (MAGENTA);
            write (linha);
            textBackGround (BLACK);
            writeln;
        end;

    executaScript := SCRIPTOK;
    if (linha = '') or (linha[1] = '*') then
        exit;

    cmd := '';
    repeat
        c := upcase (linha [1]);
        delete (linha, 1, 1);
        if c <> ' ' then
            cmd := cmd + upcase (c);
    until (c = ' ') or (linha = '');

    if cmd = 'DEBUG' then
        debugScript := not debugScript
    else

    if cmd = 'ESPERA' then
        begin
            s := '';
            for i := 1 to 10*4 do   { no maximo em 10 segundos }
                begin
                    while chegouLink do
                        begin
                            leLink (c);
                            write (c);
                            if (c = #$0d) or (c = #$0a) then
                                begin
                                   s := '';
                                   sintClek;
                                end
                            else
                                s := s + c;

                            if length(s) > length (linha) then
                                 delete (s, 1, 1);
                            if s = linha then
                                exit;    {*** achou ***}
                        end;

                    delay (250);
                end;

            executaScript := SCRIPTERROEXEC;
        end

    else
    if cmd = 'PROMPT' then
        begin
            for i := 1 to 10*4 do   { no maximo em 10 segundos }
                begin
                    while chegouLink do
                        begin
                            leLink (c);
                            write (c);
                            if (c = #$0d) or (c = #$0a) then sintClek;

                            if c in ['#', '$', '>', ']'] then
                                exit;    {*** achou ***}
                        end;

                    delay (250);
                end;

            executaScript := SCRIPTERROEXEC;
        end

    else
    if cmd = 'FRASE' then
        begin
            if (linha = '<conta>') or (linha = '<CONTA>') then
               linha := conta
            else
            if (linha = '<senha>') or (linha = '<SENHA>') then
               linha := senha;

            for i := 1 to length (linha) do
                begin
                    escLink (linha[i]);
                    delay (200);
                    while chegouLink do
                        begin
                            leLink (c);
                            write (c);
                        end;
                end;

            escLink (#$0d);
        end

    else
    if cmd = 'LIMPABUF' then
        begin
            while chegouLink do
                begin
                    leLink (c);
                    write (c);
                end;
        end

    else
    if cmd = 'CARAC' then
        begin
            val (linha, i, erro);
            if erro = 0 then
                esclink (chr (i))
            else
                executaScript := SCRIPTERROCOMP;
        end

    else
    if cmd = 'TEMPO' then
        begin
            val (linha, w, erro);
            if erro = 0 then
                delay (w)
            else
                executaScript := SCRIPTERROCOMP;
        end

    else
    if cmd = 'FIM' then
        executaScript := SCRIPTFIM

    else
    if copy (cmd, 1, 6) <> 'SCRIPT' then
        executaScript := SCRIPTERROCOMP;
end;

{--------------------------------------------------------}
{              le script do disco e executa
{--------------------------------------------------------}

function executaConexao (numScript: integer; conta, senha: string): boolean;
var s: string;
    i, status: integer;
    c: char;
    arq: text;
    nomearq, linha: string;
    operando: boolean;

label proximaLinha, achou;


begin
    debugScript := false;

    executaConexao := false;

    assign (arq, ambDiscaVox);
    {$I-} reset (arq); {$I+}
    if ioresult <> 0 then
        begin
            mensagem ('DIAMBNAO', 1); {Arquivo DISCAVOX.AMB nao encontrado}
            exit;
        end;

    str (numScript, s);
    while not eof (arq) do
        begin
            readln (arq, linha);
            for i := 1 to length (linha) do
                 linha[i] := upcase (linha[i]);
            if pos ('SCRIPT' + s, linha) = 1 then
                 goto achou;
        end;

    mensagem ('DISCRNAO', 1); {Em DISCAVOX.AMB nao esta'' definido script para este ramal}
    close (arq);
    exit;

achou:

    operando := true;
    while operando do
        begin
            if eof (arq) then
                operando := false
            else
                begin
                    readln (arq, linha);

                    status := executaScript (linha, conta, senha);
                    operando := false;

                    case status of
                        SCRIPTERROCOMP:
                            begin
                                mensagem ('DIERRCMP', 1);  {Erro no script deste ramal !}
                                writeln (linha);
                                sintetiza (linha);
                            end;

                        SCRIPTERROEXEC:
                            begin
                                mensagem ('DIERRCON', 1); {Falha de conexao executando: }
                                writeln (linha);
                                sintetiza (linha);
                            end;

                        SCRIPTFIM:   executaConexao := true;

                        else
                            operando := true;
                    end;
                end;

proximaLinha:

        end;

    close (arq);
end;

{--------------------------------------------------------}
{                 ativa programa rende
{--------------------------------------------------------}

function ativaProgRende: boolean;
var i: integer;
    c: char;
label erro;

begin
     ativaProgRende := false;

     delay (1000);
     while chegoulink do
         begin
             while chegoulink do
                 begin
                     lelink (c);
                     write (c);
                 end;
             delay (2000);
         end;

{     progParceiro := pegaParam ('PGMRENDE');}
     if progParceiro = '' then 
         progParceiro := 'rende';
     escfrase (progParceiro);

     for i := 1 to 1000 do
         begin
             if keypressed then
                 begin
                     c := readkey;
                     if (c = #$1b) or (c = ^Z) or (c = ^D) then goto erro;
                 end;

             while chegoulink do
                 begin
                     lelink (c);
                     write (c);
                     if c = #$0d then
                         begin sound (100); delay (100); nosound; end;

                     if (c = '*') or (c = 'C') or (c = NAK) then
                         begin
                             ativaProgRende := true;
                             comunicXmodem := c <> '*';
                             exit;
                         end;
                 end;

             delay (100);
         end;

    {--- nao conectou com o programa parceiro ---}
erro:
end;

{--------------------------------------------------------}
{                    desconecta
{--------------------------------------------------------}

procedure executaDesconexao;
var c: char;
begin
    delay (2000);
    while chegouLink do
        begin
            lelink (c);
            write (c);
            if not chegoulink then delay (1000);
        end;

    escfrase (^m + 'logout');

    repeat
        delay (2000);
        while chegoulink do lelink (c);
    until not chegoulink;
end;

{--------------------------------------------------------}
{              empacota os pedidos a mandar
{--------------------------------------------------------}

function empacotaPedidos: boolean;
var
    arqsai, arqtxt: text;
    s: string;
    i: integer;

begin
    empacotaPedidos := true;

    assign (arqsai, 'c:\envia.$$$');
    {$I-} rewrite (arqsai); {$I+}
    if ioresult <> 0 then
        begin
            mensagem ('DIERESCD', 1);   {Erro de escrita no disco}
            empacotaPedidos := false;
            exit;
        end;

    { empacota as cartas a enviar }

    for i := 1 to ncartas do
        begin
            assign (arqtxt, arqcarta[i]);
            {$I-} reset (arqtxt); {$I+}

            if ioresult <> 0 then
                begin
                    mensagem ('DICARSUM', 0);  {Carta de repente sumiu: }
                    sintWriteln (arqCarta[i]);
                end
            else
                begin
                    writeln (arqsai, '*CARTA');
                    writeln (arqsai, destCarta[i]);
                    writeln (arqsai, assuntoCarta[i]);
                    while not eof (arqtxt) do
                        begin
                            readln (arqtxt, s);
                            writeln (arqsai, s);
                        end;
                    close (arqtxt);
                end;

            writeln (arqsai, '>*FIM*<');
        end;

    { empacota o pedido de cartas }

    if pediuCartas then
        writeln (arqsai, '*PEDCARTA');

    { empacota os pedidos de programas }

    for i := 1 to nProgs do
        begin
            writeln (arqsai, '*PEDPROG');
            writeln (arqsai, nomeProg[i]);
        end;

    { empacota os pedidos de textos }

    for i := 1 to ntextos do
        begin
            writeln (arqsai, '*PEDTEXTO');
            writeln (arqsai, texto[i]);
        end;

    writeln (arqsai, '*FIM');
    close (arqsai);
end;

{--------------------------------------------------------}
{               mostra qual erro do protocolo
{--------------------------------------------------------}

procedure mostraErroXModem (erro: integer);
begin
    case erro of
        1 : mensagem ('DIERXM1', 1); {Arquivo nao encontrado}
        2 : mensagem ('DIERXM2', 1); {Erro na leitura do arquivo}
        3 : mensagem ('DIERXM3', 1); {Tempo esgotado esperando parceiro falar}
        4 : mensagem ('DIERXM4', 1); {Limite de tentativas de transmissao esgotado}
        5 : mensagem ('DIERXM5', 1); {Faltou confirmacao do fechamento do arquivo}
        6 : mensagem ('DIERXM6', 1); {Erro na criacao do arquivo}
        7 : mensagem ('DIERXM7', 1); {Erro na escrita do arquivo}
        8 : mensagem ('DIERXM8', 1); {Erro de transmissao ou parceiro mudo}
        9 : mensagem ('DIERXM9', 1); {Erro de sequencia dos blocos}
    end;
end;

{--------------------------------------------------------}
{                envia o pacote de pedidos
{--------------------------------------------------------}

function enviaPedidosProtoc: boolean;
var arq: text;
    erro: integer;
begin
    enviaPedidosProtoc := false;

    erro := xmodemSend ('c:\envia.$$$');
    if erro <> 0 then
        begin
             mensagem ('DIERREND', 1); {Houve problemas na comunicação com a RENDE.}
             mensagem ('DITPROB',1); {Tipo de problema:}
             mostraErroXmodem (erro);
             mensagem ('DIFNOVO', 1); {Por garantia, sugiro que você faça tudo de novo.}
        end
    else
        begin
            mensagem ('DIFIMPED', 1); {Envio de pedidos foi completado.'}
            enviaPedidosProtoc := true;
        end;

    assign (arq, 'c:\envia.$$$');
    {$i-} erase (arq); {$i+}
    if ioresult <> 0 then ;
end;

{--------------------------------------------------------}
{                envia o pacote de pedidos
{--------------------------------------------------------}

function enviaPedidos: boolean;
var arq: text;
    erro: integer;
    s: string;
    c: char;
    vezes, nlin, i: integer;

label desistiu;

begin
    mensagem ('DIINIPED', 1); {'Iniciando envio de pedidos...'}
    if comunicXmodem then
        begin
            enviaPedidos := enviaPedidosProtoc;
            exit;
        end;

    assign (arq, 'c:\envia.$$$');
    reset (arq);
    nlin := 0;
    while not eof (arq) do
        begin
            readln (arq, s);
            for i := 1 to length (s) do
                begin
                    esclink (s[i]);
                    delay (20);
                end;

            esclink (#$0d);
            delay (1000);
            while chegouLink do lelink (c);

            sound (100); delay (100); nosound;

            if keypressed then
                begin
                    c := readkey;
                    if (c = ^Z) or (c = ^D) then
                        begin
                            enviaPedidos := false;
                            goto desistiu;
                        end;
                end;
        end;

    enviaPedidos := true;
    mensagem ('DIFIMPED', 1); {Envio de pedidos foi completado.'}

desistiu:
    close (arq);
    erase (arq);
end;

{--------------------------------------------------------}
{                recebe o pacote de respostas
{--------------------------------------------------------}

function recebeRespostasProtoc: boolean;
var erro: integer;
begin
    recebeRespostasProtoc := true;
    utilizaCRC (false);
    erro := xmodemReceive ('c:\recebe.$$$');
    if erro <> 0 then
        begin
             textBackground (RED);
             mensagem ('DIRECINC', 1); {Recepção de mensagens nao foi completa.}
             textBackground (BLACK);
             clreol;
             mensagem ('DITPROB', 0); {Tipo de problema: }
             mostraErroXmodem (erro);
             mensagem ('DIPEDNOV', 1); {Sugiro que vocˆ fa‡a seus pedidos de novo'}
             recebeRespostasProtoc := false;
        end;
end;

{--------------------------------------------------------}
{                recebe o pacote de respostas
{--------------------------------------------------------}

function recebeRespostas: boolean;
var
    arq: text;
    c: char;
    s: string;

begin
    if comunicXmodem then
        begin
            recebeRespostas := recebeRespostasProtoc;
            exit;
        end;

    recebeRespostas := true;
    assign (arq, 'c:\recebe.$$$');
    rewrite (arq);

    iniciado := false;
    contaCarac := 0;

    repeat
        leFrase(s);

        if keypressed then
            begin
                c := readkey;
                if (c = ^Z) or (c = ^D) then
                    begin
                        s := '*FIM';
                        iniciado := true;
                    end;
            end;

        if iniciado then writeln (arq, s);

        if s = '*RENDE' then
            iniciado := true;

    until (s = '*FIM') and iniciado;

    close (arq);
end;

{--------------------------------------------------------}
{                trata erros de disco
{--------------------------------------------------------}

procedure erroEscritaDisco (var arqsai: text);
begin
    mensagem ('DIERESCD', 1); {Erro de escrita no disco'}
    {$i-} close (arqsai); {$i-}
    if ioresult <> 0 then;
end;

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

procedure erroLeituraDisco (var arqsai: text);
begin
    mensagem ('DIERLEID', 1); {Erro de leitura no disco'}
    {$i-} close (arqsai); {$i-}
    if ioresult <> 0 then;
end;

{--------------------------------------------------------}
{            transfere de um arquivo para o outro
{--------------------------------------------------------}

procedure transfereArquivo (var arq, arqsai: text);
var
    acabou: boolean;
    s: string;

begin
    {$I-}  rewrite (arqsai);  {$I+}
    if ioresult <> 0 then
        begin
            erroEscritaDisco (arqsai);
            exit;
        end;

    acabou := false;
    while (not acabou) and (not eof(arq)) do
        begin
            {$i-} readln (arq, s); {$I+}
            if ioresult <> 0 then
                begin
                    erroLeituraDisco (arq);
                    exit;
                end;

            if s = '>*FIM*<' then
                acabou := true
            else
                begin
                    {$I-}  writeln (arqsai, s);  {$I+}
                    if ioresult <> 0 then
                        begin
                            erroEscritaDisco (arqsai);
                            exit;
                        end;
                end;
        end;

    {$i-} close (arqsai); {$i+}
    if ioresult <> 0 then
        erroEscritaDisco (arqsai);
end;

{--------------------------------------------------------}
{                desempacota Resposta
{--------------------------------------------------------}

procedure desempacotaResposta;
var arq, arqsai: text;

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

    procedure recebeCarta;
    var 
        result, i: integer;
        s: string;

    begin
        i := quantasRec;
        repeat
            i := i + 1;
            str (i, s);
            assign (arqsai, s+'.CAR');
            {$I-} reset (arqsai);  {$I+}
            result := ioresult;
            {$I-} close (arqsai);  {$I+}
            if ioresult <> 0 then ;
        until result <> 0;
        
        quantasRec := quantasRec + 1;
        transfereArquivo (arq, arqsai);
        sintClek;
    end;

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

    procedure recebeTexto;
    var s: string;
    begin
        {$i-} readln (arq, s);  {$I+}
        if ioresult <> 0 then
            begin
                erroLeituraDisco (arq);
                exit;
            end;

        assign (arqsai, s);
        transfereArquivo (arq, arqsai);

        textBackground (BLUE);
        mensagem ('DIRECARQ', 0); {Recebido arquivo: }
        textBackground (BLACK);  clreol;
        sintWriteln (s);
    end;

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

    procedure recebeProg;
    var s: string;
    begin
        {$i-} readln (arq, s);  {$I+}
        if ioresult <> 0 then
            begin
                erroLeituraDisco (arq);
                exit;
            end;

        assign (arqsai, 'c:\prog.$$$');
        transfereArquivo (arq, arqsai);
        if uudecode ('c:\prog.$$$') <> 0 then
            mensagem ('DIERDECO', 1); {Erro no decodificador. Chame o suporte DOSVOX.}

        assign (arqsai, 'c:\prog.$$$');
        {$i-}  erase (arqsai);  {$i+}
        if ioresult <> 0 then ;

        textBackground (BLUE);
        mensagem ('DIRECPED', 1); {Foi recebido o programa pedido.}
        textBackground (BLACK);  clreol;
    end;

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

var s: string;
label acabou;

begin
    assign (arq, 'c:\recebe.$$$');
    {$i-} reset (arq); {$i+}
    if ioresult <> 0 then
        begin
            mensagem ('DINPACD', 1); {Pacote de respostas não está no disco.}
            mensagem ('DIERCOMU', 1); {Houve algo estranho na comunicação'}
            exit;
        end;

    quantasRec := 0;
    while not eof (arq) do
        begin
            readln (arq, s);
            if s = '*RENDE' then  
                begin
                    sound(440);  delay (100);
                    sound(880);  delay (100);
                    nosound;
                end
            else
            if s = '*CARTA' then  recebeCarta
            else
            if s = '*TEXTO' then  recebeTexto
            else
            if s = '*PROG' then   recebeProg
            else
            if s[1] = ^Z then goto acabou
            else
            if s <> '*FIM' then
                begin
                    mensagem ('DICTLINV', 1); {Controle inválido no arquivo de comunicação:}
                    writeln (s);
                    sintSoletra (copy (s, 1, 6));
                end;
        end;

acabou:
    textBackground (BLUE);
    mensagem ('DIRECCAR', 0); {Cartas recebidas: }
    writeln (quantasRec);
    falaNumeroConv (numeroParaString (quantasRec), 1);
    textBackground (BLACK);  clreol;

    assign (arq, 'c:\recebe.$$$');
    {$i-} erase (arq); {$i+}
    if ioresult <> 0 then ;
end;

end.
