{-------------------------------------------------------------}
{                  cartaVox - cliente SMTP
{-------------------------------------------------------------}

unit carSMTP;
interface

uses winTypes, winProcs, winDos, shellApi, strings, winSock,
     dvcrt, dvWin,
     carVars, carRede, carApeli, carUtil, carMsg, carMime, uuenc, carCC;

procedure geraTextoSMTP (nomeArq, nomeDest, assunto: string; pCC, pBCC: pListaCC);
procedure anexaAssinatura (var nomeArq: string);
procedure enviarCarta;
procedure transmitirCartas;

implementation

var mudo: boolean;

{-------------------------------------------------------------}
{                prepara arquivo em formato original
{-------------------------------------------------------------}

function enviaOriginal (codificando: boolean): boolean;
const tabhexa: array [0..15] of char =
           ('0','1','2','3','4','5','6','7','8','9',
            'A','B','C','D','E','F');
var i: integer;
    c: char;
    s: string;
begin
    enviaOriginal := true;
    while not eof (arqOrig) do
        begin
            readln (arqOrig, s);
            if (s = '.') then s := ' .';

            if codificando then
                begin
                    i := 1;
                    while i <= length (s) do
                        begin
                             if (s[i] = '=') or (s[i] > #$7e) or (s[i] < #$20) then
                                 begin
                                     c := s[i];
                                     s [i] := '=';
                                     insert (tabhexa [ord (c) shr 4], s, i+1);
                                     insert (tabhexa [ord (c) and $f], s, i+2);
                                     i := i + 2;
                                 end;

                             i := i + 1;
                        end;

                end;

            {$I-}  writeln (arqEnv, s);  {$I+}
            if ioresult <> 0 then
                begin
                    enviaOriginal := false;
                    close (arqOrig);
                    exit;
                end;
        end;

    close (arqOrig);
end;

{-------------------------------------------------------------}
{                prepara os arquivos atachados
{-------------------------------------------------------------}

procedure enviaAttachments (chaveMime: string);
var i: integer;
    nome, tipoAplic: string;
label proximo;

      function simplifica (nomeOrig: string): string;
      var nome: string;
      begin
          nome := nomeOrig;
          while pos (':', nome) > 0 do
              delete (nome, 1, pos (':', nome) );
          while pos ('\', nome) > 0 do
              delete (nome, 1, pos ('\', nome) );
          if nome = '' then nome := 'x.dat';
          simplifica := nome;
      end;

      function geraTipoAplic (nome: string): string;
      var ext: string [4];
          i: integer;
      label achou;
      begin
          ext := '';
          for i := length (nome) downto length (nome)-3 do
              if nome[i] = '.' then goto achou
              else ext := upcase(nome[i]) + ext;
achou:
          if      ext = 'ZIP'  then  geraTipoAplic := 'application/zip'
          else if ext = 'WAV'  then  geraTipoAplic := 'audio/x-wav'
          else if ext = 'MID'  then  geraTipoAplic := 'audio/midi'
          else if ext = 'GIF'  then  geraTipoAplic := 'image/gif'
          else if ext = 'JPG'  then  geraTipoAplic := 'image/jpeg'
          else if ext = 'HTM'  then  geraTipoAplic := 'text/html'
          else if ext = 'HTML' then  geraTipoAplic := 'text/html'
          else if ext = 'TXT'  then  geraTipoAplic := 'text/plain'
          else
              geratipoAplic := 'application/octet-stream';
      end;

begin
    writeln (arqEnv, '--', chaveMime);
    writeln (arqEnv, 'Content-Type: text/plain; charset="us-ascii"');
    writeln (arqEnv);
    enviaOriginal (false);

    for i := 1 to narqMime do
         begin
             writeln (arqEnv, '--', chaveMime);

             case tipoConvMime [i] of       { tenta abrir o arquivo }
                 'N', 'I':
                       begin
                           assign (arqOrig, tabArqMime [i]^);
                           {$I-} reset (arqOrig); {$I+}
                       end;

                 'U', 'M':
                       begin
                           assign (arqBin, tabArqMime [i]^);
                           {$I-} reset (arqBin, 1); {$I+}
                       end;
             end;

             if ioresult <> 0 then
                 begin
                     mensagem ('CTERRLEI', 1);  {'Erro de leitura do arquivo'}
                     sintWriteln (tabArqMime [i]^);
                     goto proximo;
                 end;

             case tipoConvMime [i] of   { gera cabecalho e manda }
                 'N': begin
                         writeln (arqEnv, 'Content-Type: text/plain; charset="us-ascii"');
                         writeln (arqEnv);
                         if not enviaOriginal (false) then
                             goto proximo;
                      end;

                 'I': begin
                         writeln (arqEnv, 'Content-Type: text/plain; charset=iso-8859-1');
                         writeln (arqEnv, 'Content-Transfer-Encoding: quoted-printable');
                         write   (arqEnv, 'X-MIME-Autoconverted: from 8bit to quoted-printable ');
                         writeln (arqEnv, 'by caec.nce.ufrj.br id dosvox');
                         writeln (arqEnv);
                         if not enviaOriginal (true) then
                             goto proximo;
                      end;

                 'U': begin
                         nome := simplifica (tabArqMime [i]^);
                         tipoAplic := geraTipoAplic (nome);
                         write   (arqEnv, 'Content-Type: ' + tipoAplic + '; ');
                         writeln (arqEnv, 'name="', nome, '"');
                         writeln (arqEnv, 'Content-Transfer-Encoding: x-uuencode');
                         write   (arqEnv, 'Content-Disposition: attachment; ');
                         writeln (arqEnv, 'filename="', nome, '"');
                         writeln (arqEnv);

                         uuencode (tabArqMime [i]^, 'c:\$.$');

                         assign (arqOrig, 'c:\$.$');
                         {$I-} reset (arqOrig); {$I+}
                         if ioresult <> 0 then
                             goto proximo;
                         if not enviaOriginal (false) then
                             goto proximo;
                         erase (arqOrig);
                     end;

                 'M': begin
                         nome := simplifica (tabArqMime [i]^);
                         tipoAplic := geraTipoAplic (nome);
                         write   (arqEnv, 'Content-Type: ' + tipoAplic + '; ');
                         writeln (arqEnv, 'name="', nome, '"');
                         writeln (arqEnv, 'Content-Transfer-Encoding: base64');
                         write   (arqEnv, 'Content-Disposition: attachment; ');
                         writeln (arqEnv, 'filename="', nome, '"');
                         writeln (arqEnv);

                         mensagem ('CTMOMENT', 0);  {'Um momento...'}
                         codifMime64;
                         close (arqBin);
                         while sintFalando do;
                     end;
             end;

proximo:
         end;

    writeln (arqEnv, '--', chaveMime, '--');
end;

{-------------------------------------------------------------}
{                prepara formato SMTP para envio
{-------------------------------------------------------------}

procedure geraTextoSMTP (nomeArq, nomeDest, assunto: string; pCC, pBCC: pListaCC);
var
    nomeArqEnviar, s: string;
    Year, Month, Day, DayOfWeek: Word;
    Hour, Minute, Second, Sec100: Word;
    i1, i2: integer;
const
    tabMes: array [1..12] of string [3] = (
       'Jan', 'Feb', 'Mar', 'Apr', 'May', 'Jun', 'Jul', 'Aug', 'Sep', 'Oct', 'Nov', 'Dec');
label erro;

begin
    nomeArqEnviar := novoNomeCarta (nbaseEnvia, dirEnvia, 'CPR');
    if nomeArqEnviar = '' then
        begin
            textBackground (RED);
            mensagem ('CTERRCNF', 1);  {'Este programa está configurado com erro !'}
erro:
            mensagem ('CTERRGER', 1);  {'Não consegui gerar carta para envio'}
            mensagem ('CTNAOMAN', 1);  {'Carta não será mandada'}
            textBackground (BLACK);
            exit;
        end;

    assign (arqOrig, nomeArq);
    {$I-}  reset (arqOrig);  {$I+}
    if ioresult <> 0 then
        begin
            textBackground (RED);
            mensagem ('CTARQSUM', 1);  {'Arquivo a enviar sumiu !'}
            mensagem ('CTNAOMAN', 0);  {'Carta não será mandada'}
            textBackground (BLACK);
            writeln;
            exit;
        end;

    assign (arqEnv, nomeArqEnviar);
    {$I-}  rewrite (arqEnv);  {$I+}
    if ioresult <> 0 then goto erro;

    i1 := pos ('<', enderUsuario);
    if i1 <> 0 then
        begin
            i2 := pos ('>', enderUsuario);
            enderUsuario := copy (enderUsuario, i1, i2-i1+1);
            writeln (arqEnv, 'MAIL FROM:', enderUsuario)
        end
    else
        writeln (arqEnv, 'MAIL FROM:<', enderUsuario, '>');

    i1 := pos ('<', nomeDest);
    if i1 <> 0 then
        begin
            i2 := pos ('>', nomeDest);
            nomeDest := copy (nomeDest, i1, i2-i1+1);
            writeln (arqEnv, 'RCPT TO:', nomeDest)
        end
    else
        writeln (arqEnv, 'RCPT TO:<', nomeDest, '>');

    geraRCPTCC;

    writeln (arqEnv, 'DATA');
    getDate(Year, Month, Day, DayOfWeek);
    write (arqEnv, 'Date: ', Day, ' ', tabMes [Month], ' ', Year);
    getTime (Hour, Minute, Second, Sec100);
    writeln (arqEnv,  ' ', Hour, ':', Minute, ':', Second);
    if nomeUsuario <> '' then
        writeln (arqEnv, 'From: "', nomeUsuario, '" <', enderUsuario, '>')
    else
        writeln (arqEnv, 'From: <', enderUsuario, '>');
    writeln (arqEnv, 'To: ', nomeDest);
    writeln (arqEnv, 'Subject: ', assunto);

    if (pCC <> NIL) or (pBCC <> NIL) then
        gravaCC;

    if chaveMime <> '' then
        begin
            writeln (arqEnv, 'Mime-Version: 1.0');
            write   (arqEnv, 'Content-Type: multipart/mixed; boundary=');
            writeln (arqEnv, '"', chaveMime, '"');
        end;

    writeln (arqEnv);

    if chaveMime <> '' then
         enviaAttachments (chaveMime)
    else
        if not enviaOriginal (false) then
            begin
                close (arqEnv);
                goto erro;
            end;

    {$I-}  writeln (arqEnv, '.');  {$I+}
    if ioresult <> 0 then
        begin
            {$I-} close (arqOrig);  {$I+}
            if ioresult <> 0 then;
            close (arqEnv);
            goto erro;
        end;

    close (arqEnv);
    while keypressed do readkey;
    mensagem ('CTCARPRP', 1);  {'Carta preparada para envio'}
end;

{-------------------------------------------------------------}
{                  gera chave de acesso Mime
{-------------------------------------------------------------}

procedure geraChaveMime;
var i, n: integer;
    s: string;
begin
    chaveMime := '=================';             { gera chave Mime randomica }
    for i := 1 to 10 do
         begin
             n := random (255);
             str (n, s);
             chaveMime := chaveMime + s;
         end;
end;

{-------------------------------------------------------------}
{                  atacha arquivos a carta
{-------------------------------------------------------------}

procedure atachaArquivos;
var
    c1, c2: char;
    nomeArqAttach: string;
    ext: string [4];
    arq: file;
begin
    geraChaveMime;

    narqMime := 0;
    repeat
        mensagem ('CTNOMATA', 1);     {'Nome do arquivo a enviar: '}
        sintReadln (nomeArqAttach);
        if nomeArqAttach <> '' then
             begin
                  assign (arq, nomeArqAttach);
                  {$I-} reset (arq);  {$I+}
                  if ioresult <> 0 then
                      mensagem ('CTATAINV', 1)   {'Nome de arquivo inválido'}
                  else
                      begin
                          close (arq);
                          narqMime := narqMime + 1;
                          new (tabArqMime [narqMime]);
                          tabArqMime [narqMime]^ := nomeArqAttach;

                          mensagem ('CTCNVPAD', 0);  {'Posso usar a conversão padrao (s/n) ? '}
                          sintLeTecla (c1, c2);
                          writeln;
                          if upcase (c1) = 'N' then
                              begin
                                  mensagem ('CTTIPMIM', 0);  {'Tipo de conversao:}
                                           {Mime, Nenhuma, Iso-latin ou Uuencode ? '}
                                  sintLeTecla (c1, c2);
                                  writeln;
                              end
                          else
                              begin
                                  ext := copy (nomeArqAttach, length (nomeArqAttach)-3, 4);
                                  if (ext = '.TXT') or (ext = '.txt') then
                                      c1 := 'I'
                                  else
                                      c1 := 'M';   {Mime64}
                              end;

                          case upcase(c1) of
                              'N':  tipoConvMime [narqMime] := 'N';  { nenhuma }
                              'I':  tipoConvMime [narqMime] := 'I';  { conversão ISO }
                              'U':  tipoConvMime [narqMime] := 'U';  { uuencode }
                          else
                                    tipoConvMime [narqMime] := 'M';  { mime64 }
                          end;
                      end;
             end;

        mensagem ('CTMAISAR', 0);     {'Mais arquivos (s/n) ?'}
        sintLeTecla (c1, c2);
        writeln;
    until upcase (c1) <> 'S';

end;

{-------------------------------------------------------------}
{                gera carta padrao Mime
{-------------------------------------------------------------}

procedure geraCartaPadrao;
var arq: text;
begin
    assign (arq, '$.$');
    {$I-} rewrite (arq); {$I+}
    if ioresult <> 0 then
         exit;
    writeln (arq, 'Este arquivo foi gerado em formato MIME multiplo, atraves do sistema DOSVOX.');
    writeln (arq, 'Ele pode ser automaticamente decodificado usando um leitor compativel com');
    writeln (arq, 'o formato MIME, como Cartavox, Eldora, Pegasus ou Internet Mail.');
    writeln (arq);
    writeln (arq, 'This is a multi-part MIME file generated by the DOSVOX system.');
    writeln (arq, 'It can be automatically decoded using a MIME-compliant reader like');
    writeln (arq, 'Cartavox, Eldora, Pegasus or Internet Mail.');
    close (arq);
end;

{-------------------------------------------------------------}
{               anexa assinatura a texto criado
{-------------------------------------------------------------}

procedure anexaAssinatura (var nomeArq: string);
var arq, arqAssina, arqNovo: text;
    s: string;
    resp: char;
label erro, fim;
begin
    if nomeAssinatura = '' then exit;

    textBackGround (MAGENTA);
    mensagem ('CTADIASS', 0);   {'Adiciona sua assinatura ? '}
    textBackGround (BLACK);
    resp := sintReadkey;
    writeln (resp);
    if upcase (resp) = 'N' then exit;

    assign (arq, nomeArq);
    {$I-} reset (arq); {$I+}
    if ioresult <> 0 then exit;

    assign (arqNovo, '$.$');
    {$I-} rewrite (arqNovo); {$I+}
    if ioresult <> 0 then exit;

    while not eof (arq) do
        begin
            {$I-}  readln (arq, s);  {$I+}
            if ioresult = 0 then
                begin
                    {$I-}  writeln (arqNovo, s);   {$I+}
                    if ioresult <> 0 then goto erro;
                end;
        end;

    assign (arqAssina, nomeAssinatura);
    {$I-}  reset (arqAssina);  {$I+}
    if ioresult <> 0 then exit;

    while not eof (arqAssina) do
        begin
            {$I-}  readln (arqAssina, s);  {$I+}
            if ioresult = 0 then
                begin
                    {$I-}  writeln (arqNovo, s);   {$I+}
                    if ioresult <> 0 then goto erro;
                end;
        end;
fim:
    close (arq);
    close (arqNovo);
    close (arqAssina);
    nomeArq := '$.$';
    exit;

erro:
    textBackground (RED);
    mensagem ('CTERRDSK', 0);   {'Erro de escrita no disco'}
    textBackground (BLACK);
    writeln;
    goto fim;
end;

{-------------------------------------------------------------}
{                prepara nova carta para envio
{-------------------------------------------------------------}

procedure enviarCarta;
var
    nomeDest, nomeArq, assunto, nomeEditor: string;
    c1, c2: char;
    resp: char;
    arq: file;
label atacha, edita;
begin
    chaveMime := '';

    repeat
        mensagem ('CTENDDST', 1);  {'Qual o endereço eletrônico do destinatário ? '}
        mensagem ('CTAPELID', 1);  {'Começar por * indica apelido'}
        sintReadln (nomeDest);
        if pos (',', nomeDest) <> 0 then
            mensagem ('CTSOUMDS', 1);   {'Erro: informe apenas um destinatário principal'}
    until pos (',', nomeDest) = 0;

    if nomeDest = '' then exit;

    if nomeDest = '*' then
         begin
             editarApelidos;
             nomeDest := '';
         end
    else if nomeDest [1] = '*' then
        begin
            delete (nomeDest, 1, 1);
            nomeDest := buscaApelido (nomeDest);
            if nomeDest = '' then
                 mensagem ('CTAPEINV', 1)   {'Apelido inválido'}
            else
                begin
                    textBackground (MAGENTA);
                    mensagem ('CTENVPAR', 0);   {'Enviando para: '}
                    textBackground (BLACK);   clreol;
                    sintWriteln (nomeDest);
                    mensagem ('CTCNFDST', 0);  {'Confirma destino {s/n) ? '}
                    sintLeTecla (c1, c2);
                    writeln;
                    if (upcase (c1) = 'N') or (c1 = ESC) then exit;
                end;
        end;

    if nomeDest = '' then exit;

    mensagem ('CTASSCAR', 1);  {'Qual o assunto da carta ? '}
    sintReadln (assunto);

    mensagem ('CTNOMMAN', 1);  {'Qual o nome do arquivo de texto a mandar ? '}
    sintReadln (nomeArq);
    if nomeArq = '' then
        goto atacha;

    if (pos (':', nomearq) = 0) and (pos ('\', nomearq) = 0) then
        nomeArq := dirEnvia + '\' + nomeArq;

    if not existeArq (nomeArq) then
        begin
            mensagem ('CTQUERTC', 0);  {'Esse arquivo não existe, quer teclar agora ? '}
            sintLeTecla (c1, c2);
            writeln;

            if upcase (c1) = 'N' then
                begin
                    mensagem ('CTDESIST', 1);
                    exit;
                end;
            goto edita;
        end
    else
        begin
            mensagem ('CTEDIANT', 0);   {'Quer edita-lo antes de mandar ? '}
            sintLeTecla (c1, c2);
            writeln;
            if upcase (c1) <> 'S' then goto atacha;
        end;

edita:
    mensagem ('CTABREDI', 1);  {'Abrindo editor'}
    while sintFalando do;
    nomeEditor := sintAmbiente ('CARTAVOX', 'EDITOR');
    while sintFalando do;
    if executaProg (nomeEditor, dirEnvia, nomeArq) then
        begin
            esperaProgVoltar;
            delay (1500);
            while sintFalando do;
            while keypressed do readkey;
            sintBip;
        end;

atacha:
    anexaAssinatura (nomeArq);

    textBackGround (MAGENTA);
    mensagem ('CTATACHA', 0);  {'Quer mandar arquivos junto com esta carta ? '}
    textBackGround (BLACK);
    sintLeTecla (c1, c2);
    writeln;
    if upcase (c1) = 'S' then
        atachaArquivos;

    if (c1 = #$1b) or ((nomeArq = '') and (upcase(c1) <> 'S')) then
        begin
            mensagem ('CTDESIST', 1);    {'Desistiu...'}
            exit;
        end;

    if nomeArq = '' then
         begin
             nomeArq := '$.$';
             geraCartaPadrao;
         end;

    limpaListaCarbono;

    textBackground (MAGENTA);
    mensagem ('CTENVCC', 0);   {'Deseja enviar cópias carbono desta carta ? '}
    textBackground (BLACK);
    resp := sintReadkey;
    writeln (resp);
    if upcase (resp) = 'S' then
        geraListaCarbono;

    mensagem ('CTCNFENV', 0);    {'Confirma envio (s/n) ?'}
    sintLeTecla (c1, c2);
    writeln;
    if upcase (c1) <> 'N' then
        geraTextoSMTP (nomeArq, nomeDest, assunto, pCc, pBcc)
    else
        mensagem ('CTDESIST', 1);   {'Desistiu...'}

    assign (arq, '$.$');
    {$I-} erase (arq); {$I+}
    if ioresult <> 0 then;
end;

{-------------------------------------------------------------}
{                   transmitir uma carta
{-------------------------------------------------------------}

const
    SMTP_OK   = 1;
    SMTP_ERRO = -1;
    SMTP_CAIU = -2;

function enviaUmaCartaSMTP (nomeArq: string): integer;
var arq: text;
    i, ncb, lidos: integer;
    s: string;
    dandoErros, ok: boolean;

label caiu;


    function descarrega: boolean;
    var i, n: integer;
        c: char;
    begin
        write ('*');

        if keypressed then     { cancelamento }
            begin
                c := readkey;
                if c = #$1b then
                    begin
                        descarrega := false;
                        exit;
                    end;
                if c = ' ' then mudo := not mudo;
            end;

        if not mudo then
            if bipaNoSpeaker then bipSpeaker (22)
                             else sintClek;

        i := 0;
        repeat
        n := send (sockSMTP, @bufEnvia [i], ncb, 0);
        if n <= 0 then
            begin
                close (arq);
                descarrega := false;
                exit;
            end
        else
            begin
                i := i + n;
                ncb := ncb - n;
            end;
        until ncb = 0;
        descarrega := true;
    end;

begin
    enviaUmaCartaSMTP := SMTP_OK;

    assign (arq, nomeArq);
    {$I-}  reset (arq);  {$I+}
    if ioresult <> 0 then
        begin
            mensagem ('CTPROENV', 0);  {'Problema de arquivo ao enviar a carta '}
            sintWriteln (nomeArq);
            enviaUmaCartaSMTP := SMTP_ERRO;
            exit;
        end;

    s := '';
    i := 0;
    while s <> 'DATA' do
        begin
            readln (arq, s);
            StrPCopy (bufEnvia, s + CRLF);
            send (sockSMTP, bufEnvia, strlen (bufEnvia), 0);
            netDebug (bufEnvia, strlen (bufEnvia));

            i := i + 1;

            lidos := recv (sockSMTP, bufRecebe, BUFSIZE, 0);
            if lidos <= 0 then
                goto caiu;
            bufRecebe [lidos] := #$0;
            netDebug (bufRecebe, strlen (bufRecebe));

            ok := (strlcomp (bufRecebe, '250', 3) = 0) or
                  (strlcomp (bufRecebe, '251', 3) = 0) or
                  (strlcomp (bufRecebe, '354', 3) = 0) or
                  (strlcomp (bufRecebe, '503', 3) = 0);

            if not ok then
                begin
                    textBackGround (RED);
                    mensagem ('CTERENVC', 0);  {'Erro ao enviar a carta.  Servidor reclamou de '}
                    textBackGround (BLACK);
                    writeln;
                    if copy (s, 1, 10) = 'MAIL FROM:' then delete (s, 1, 10);
                    if copy (s, 1, 10) = 'RCPT TO:' then delete (s, 1, 8);
                    sintWriteln (s);

                    mensagem ('CTVEJMEN', 0);  {'Veja mensagem do servidor:'}
                    textBackGround (BLACK);
                    clreol;
                    writeln;

                    dandoErros := true;
                    repeat
                         sintWrite (strPas (bufRecebe));
                         delay (1000);
                         dandoErros := temDadoSock (sockSMTP);
                         if dandoErros then
                             begin
                                  lidos := recv (sockSMTP, bufRecebe, BUFSIZE, 0);
                                  bufRecebe [lidos] := #$0;
                             end;
                    until not dandoErros;

                    if i < 3 then   { MAIL FROM e RCPT TO do principal }
                        begin
                            enviaUmaCartaSMTP := SMTP_ERRO;
                            {$I-} close (arq); {$I+}
                            if ioresult <> 0 then ;
                            exit;
                        end;
                end;
        end;

    ncb := 0;
    while not eof (arq) do
        begin
            readln (arq, s);
            s := s + crlf;
            for i := 1 to length (s) do
                begin
                    bufEnvia [ncb] := s[i];
                    ncb := ncb + 1;
                end;

            if ncb > (BUFSIZE - 255) then
               if not descarrega then goto caiu;
        end;

    if ncb > 0 then
        if not descarrega then goto caiu;

    {$I-} close (arq); {$I+}
    if ioresult <> 0 then ;

    lidos := recv (sockSMTP, bufRecebe, BUFSIZE, 0);
    if lidos <= 0 then goto caiu;
    bufRecebe [lidos] := #$0;
    netDebug (bufRecebe, strlen (bufRecebe));

    ok := (strlcomp (bufRecebe, '2', 1) = 0);
    if not ok then
        enviaUmaCartaSMTP := SMTP_ERRO;

    exit;

caiu:
     {$I-} close (arq); {$I+}
     if ioresult <> 0 then ;
     enviaUmaCartaSMTP := SMTP_CAIU;
     mensagem ('CTCONCAI', 1);  {'Conexão de dados caiu'}
end;

{-------------------------------------------------------------}
{                tira copia do arquivo enviado
{-------------------------------------------------------------}

procedure tiraCopia (nomeOrig: string);
const
    BUFSIZE = 1024;

var nomearq: string;
    arqin, arqout: file;
    buf: array [0..BUFSIZE-1] of byte;
    erro, nbytes: integer;
    tam: longint;

label fim;

begin
    nomeArq := novoNomeCarta (nbaseCopia, dirEnvia, 'ENV');

    assign (arqin, nomeOrig);
    assign (arqout, nomearq);

    {$I-} reset (arqin, 1); {$I+}
    if ioresult <> 0 then exit;
    {$I-} rewrite (arqout, 1); {$I+}
    if ioresult <> 0 then exit;

    tam := filesize (arqin);
    while tam > 0 do
        begin
            nbytes := BUFSIZE;
            if tam < BUFSIZE then nbytes := tam;

            {$I-} blockread  (arqin,  buf, nbytes); {$I+}
            if ioresult <> 0 then
                begin
                    mensagem ('CTERRLEI', 1);  {'Erro de leitura do arquivo'}
                    goto fim;
                end;

            {$I-} blockwrite (arqout, buf, nbytes); {$I+}
            erro := ioresult;
            if erro = 101 then
                begin
                    mensagem ('CTERRDSK', 1);  {'Erro de escrita no disco'}
                    goto fim;
                end;

            tam := tam - BUFSIZE;
        end;

fim:

    {$I-} close (arqin);  {$I+}
    if ioresult <> 0 then;
    {$I-} close (arqout); {$I+}
    if ioresult <> 0 then;
end;

{-------------------------------------------------------------}
{            conecta para transmitir cartas via SMTP
{-------------------------------------------------------------}

procedure transmitirCartas;
var texto: array [0..255] of byte;
    lidos: integer;
    dirAtual: string;
    dirInfo: TSearchRec;
    arqApaga: file;
    tipoErro: integer;
    c, c2: char;

label fim, erro;
begin
    mudo := false;

    getDir (0, dirAtual);
    {$I-}  chdir (dirEnvia);  {$I+}
    if ioresult <> 0 then
        begin
            mensagem ('CTDIRSUM', 1);  {'O diretorio de cartas sumiu !'}
            goto erro;
        end;

    fillChar (dirInfo, 0, sizeof (dirInfo));
    findFirst ('*.CPR', faArchive, dirInfo);
    if dosError <> 0 then
        begin
            mensagem ('CTTODENV', 1);  {'Todas as cartas já foram enviadas'}
            chDir (dirAtual);
            exit;
        end;

    textBackground (MAGENTA);
    mensagem ('CTCONTSV', 0);  {'Contactando servidor para transmitir cartas'}
    textBackGround (BLACK);
    writeln;

    sockSMTP := abreConexao (hostSMTP, portaSMTP);
    if sockSMTP = -1 then
        goto erro;

    lidos := recv (sockSMTP, bufRecebe, BUFSIZE, 0);
    if (lidos <= 0) then
        goto erro;
    bufRecebe [lidos] := #$0;
    netDebug (bufRecebe, lidos);

    if strlcomp (bufRecebe, '220', 3) <> 0 then
        begin
            textBackGround (RED);
            mensagem ('CTSRVNAO', 1);  {'Servidor não quer conversa, ele mandou esta mensagem'}
            textBackGround (BLACK);
            sintWriteln (strPas (bufRecebe));
            goto erro;
        end
    else
        netDebug (bufRecebe, lidos);

    mensagem ('CTENVCAR', 1);  {'Enviando as cartas'}

    StrPCopy (bufEnvia, 'HELO '+ computLocal + CRLF);
    send (sockSMTP, bufEnvia, strlen (bufEnvia), 0);
    netDebug (bufEnvia, strlen (bufEnvia));

    lidos := recv (sockSMTP, bufRecebe, BUFSIZE, 0);
    if (lidos <= 0) then goto erro;
    bufRecebe [lidos] := #$0;
    if strlcomp (bufRecebe, '250', 3) <> 0 then
        begin
            textBackGround (RED);
            mensagem ('CTSRVNGO', 1);  {'Servidor não gostou dessa conexão, ele mandou esta mensagem'}
            textBackGround (BLACK);
            sintWriteln (strPas (bufRecebe));
            goto erro;
        end
    else
        netDebug (bufRecebe, lidos);

    fillChar (dirInfo, 0, sizeof (dirInfo));
    findFirst ('*.CPR', faArchive, dirInfo);
    while dosError = 0 do
        begin
            write (dirInfo.name, ' ');
            tipoErro := enviaUmaCartaSMTP (strPas(dirInfo.name));
            if tipoErro = SMTP_CAIU then
                goto erro
            else
            if tipoErro = SMTP_OK then
                begin
                    if guardaEnviadas then
                        tiraCopia (strPas (dirInfo.name));
                    assign (arqApaga, strPas (dirInfo.name));
                    {$I-}  erase (arqApaga);  {$I+}
                end
            else
                begin
                    mensagem ('CTCNFAPC', 0);    {'Posso apagar esta carta com erro ? '}
                    sintLeTecla (c, c2);
                    writeln;
                    if upcase (c) = 'S' then
                        begin
                            assign (arqApaga, strPas (dirInfo.name));
                            {$I-}  erase (arqApaga);  {$I+}
                        end;
                end;

            findNext (dirInfo);
            writeln;
        end;

    {$I-}  chDir (dirAtual);   {$I+}
    if ioresult <> 0 then ;

    StrPCopy (bufEnvia, 'QUIT '+ computLocal + CRLF);
    send (sockSMTP, bufEnvia, strlen (bufEnvia), 0);
    netDebug (bufEnvia, strlen (bufEnvia));

    lidos := recv (sockSMTP, bufRecebe, BUFSIZE, 0);
    if (lidos <= 0) then goto erro;
    bufRecebe [lidos] := #$0;
    netDebug (bufRecebe, lidos);

    closeSocket (sockSMTP);
    wsaCleanup;

    mensagem ('CTFIMENV', 1);  {'Fim de envio'}
    chDir (dirAtual);
    exit;

erro:
    closeSocket (sockSMTP);
    wsaCleanup;
    writeln;
    mensagem ('CTCONCAN', 1);  {'Conexao com servidor foi cancelada'}
    mensagem ('CTCARTAP', 1);  {'Cartas permanecem prontas para ser enviadas'}
    chDir (dirAtual);
end;

end.
