{-------------------------------------------------------------}
{                  cartaVox - leitor Mime
{-------------------------------------------------------------}

unit carLeit;
interface
uses dvcrt, dvWin, carUtil, carVars, carMsg, carMime, uuenc;

procedure leituraMime (nomeArq: string);

implementation

var chaveMime: string;
    tipoAplic, nomeArq: string;
    tipoArq: char;

const
    LIXOMIME = '(&*@#%^$&*%^#$&%@#$^&%@#*$^%^%*()&)(*$%&*(#^(&*^#$&*^@#$';

{-------------------------------------------------------------}
{                  converte cadeia para maiuscula
{-------------------------------------------------------------}

function upstr (s: string): string;
var s2: string;
    i: integer;
begin
    s2 := s;
    for i := 1 to length (s2) do
        s2[i] := upcase (s2[i]);
    upstr := s2;
end;

{-------------------------------------------------------------}
{          busca registro da fronteira de arquivos
{-------------------------------------------------------------}

function buscaChave: string;
var s, ss, texto: string;
    i, n: integer;
label pula, erro, achou;
begin
    buscaChave := '';
    texto := 'Content-Type:';
    s := 'a';
    while (s <> '') and (not eof (arqOrig)) do
        begin
            readln (arqOrig, s);
            for i := 1 to length (texto) do
                if upcase (texto[i]) <> upcase (s[i]) then
                    goto pula;
            goto achou;
pula:;
        end;
    exit;

achou:
    ss := '';
    for i := 1 to length (s) do ss := ss + upcase (s[i]);
    n := pos ('BOUNDARY=', ss);
    if n = 0 then
         begin
             readln (arqOrig, s);
             ss := '';
             for i := 1 to length (s) do ss := ss + upcase (s[i]);
             n := pos ('BOUNDARY=', ss);
         end;
    if n = 0 then
        begin
erro:       buscaChave := '';
            exit;
        end;

    n := n + 9;

    s := copy (s, n, length(s)-n+1);
    if s[1] = '"' then delete (s, 1, 1);
    if s[length (s)] = '"' then delete (s, length(s), 1);
    buscaChave := s;
end;

{-------------------------------------------------------------}
{                   busca registro de separacao
{-------------------------------------------------------------}

function buscaRegSepar (chave: string): boolean;
var s: string;
begin
    buscaRegSepar := true;
    while not eof (arqOrig) do
        begin
            {$I-} readln (arqOrig, s); {$I+}
            if ioresult <> 0 then
                begin
                     mensagem ('CTERRLEI', 1);   {'Erro de leitura do arquivo'}
                     buscaRegSepar := false;
                     exit;
                end;
            if s = chave then exit;
        end;
    buscaRegSepar := false;
end;

{-------------------------------------------------------------}
{                    leitura normal
{-------------------------------------------------------------}

procedure leituraNormal (tipoAplic, chaveMime: string);
var c1, c2: char;
    nomeProg, nomeNovo, s: string;
    arqNovo, arqAntigo: text;
label erro;
begin
    { pergunta tambem se quer ler ou guardar em arquivo }

(*    if chaveMime = LIXOMIME then    { para ler sem perguntar, removido a pedidos }
        c1 := 'L'
    else
*)
        begin
            mensagem ('CTLERGRD', 0);  {'Escolha: ler ou guardar em arquivo ? '}
            sintLeTecla (c1, c2);
            writeln;
            if c1 = #$1b then exit;
        end;

    if upcase (c1) <> 'G' then
        begin
            if tipoAplic = 'text/html' then
                begin
                    nomeProg := sintAmbiente ('CARTAVOX', 'LEITORHTML');
                    if nomeProg = '' then nomeProg := 'c:\winvox\webvox.exe';
                end
            else
                begin
                    nomeProg := sintAmbiente ('CARTAVOX', 'LEITOR');
                    if nomeProg = '' then nomeProg := 'c:\winvox\levox.exe';
                end;
            if executaProg (nomeProg, dirRecebe, '$.$') then
                begin
                    esperaProgVoltar;
                    while keypressed do readkey;
                end;
        end
    else
        begin
            if nomeArq <> '' then
                begin
                    mensagem ('CTVOUGRV', 0);   {'Pretendo gravar '}
                    sintWriteln (nomeArq);
                end;
            mensagem ('CTEDINOM', 1);
                      {'Editore o nome, tecle ENTER para confirmar ou ESC para cancelar: '}
            if sintEdita (nomeArq, wherex, wherey, 80, true) = ESC then
                begin
                    write (#$0d);   { forca volta ao inicio da linha }
                    exit;
                end;

            writeln;
            if nomeArq = '' then exit;

            nomeNovo := nomeArq;
            assign (arqAntigo, '$.$');
            {$I-} reset (arqAntigo); {$I+}
            if ioresult <> 0 then;
            assign (arqNovo, nomeNovo);
            {$I-} rewrite (arqNovo); {$I+}
            if ioresult <> 0 then goto erro;

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

            mensagem ('CTOK', 1);    {'OK'}

            if false then
                begin
    erro:           mensagem ('CTERRDSK', 1)    {'Erro de escrita no disco'}
                end;

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

{-------------------------------------------------------------}
{                    leitura Uuencode
{-------------------------------------------------------------}

procedure leituraUuencode;
begin
    if uudecode ('$.$') <> 0 then
        mensagem ('CTERRDSK', 1)    {'Erro de escrita no disco'}
    else
        mensagem ('CTOK', 1);       {'OK'}
end;

{-------------------------------------------------------------}
{                     leitura Mime64
{-------------------------------------------------------------}

procedure leituraMime64;
var toca: boolean;
    c1, c2: char;
    nomeProg: string;
label erro;
begin
    toca := false;
    if (copy (nomeArq, length (nomeArq)-3, 4) = '.mid') or
       (copy (nomeArq, length (nomeArq)-3, 4) = '.MID') or
       (copy (nomeArq, length (nomeArq)-3, 4) = '.wav') or
       (copy (nomeArq, length (nomeArq)-3, 4) = '.WAV') then

        begin
            { se for wav ou mid, pergunta se quer tocar}
            mensagem ('CTTOCAR', 0);   {'Arquivo é sonoro, quer tocar (s/n) ? '}
            sintLeTecla (c1, c2);
            writeln;

            if upcase(c1) = 'S' then
                begin
                    toca := true;
                    nomeArq := '$' + copy (nomeArq, length (nomeArq)-3, 4);
                end;
        end;

    if not toca then
        begin
            mensagem ('CTVOUGRV', 0);   {'Pretendo gravar '}
            sintWriteln (nomeArq);
            mensagem ('CTEDINOM', 1);   {'Editore o nome, tecle ENTER para confirmar
                                                   ou ESC para cancelar: '}
            if sintEdita (nomeArq, wherex, wherey, 80, true) = ESC then
                exit;
        end;

    if nomeArq = '' then
        begin
            writeln;
            exit;
        end;

    mensagem ('CTMOMENT', 0);  {'Um momento...'}
    if not decodMime64 ('$.$', nomeArq) then
        goto erro;
    while sintFalando do;

    if toca then
        begin
            writeln;
            nomeProg := sintAmbiente ('CARTAVOX', 'TOCADOR');
            if nomeProg = '' then nomeProg := 'c:\winvox\midiavox.exe';
            while sintFalando do;
            if executaProg (nomeProg, dirRecebe, nomeArq) then
                esperaProgVoltar;
        end
    else
        mensagem ('CTOK', 1);    {'OK'}

    if false then
        begin
erro:       mensagem ('CTERRDSK', 1);    {'Erro de escrita no disco'}
            if ioresult <> 0 then;
        end;
end;

{-------------------------------------------------------------}
{                  pega informacoes do cabecalho
{-------------------------------------------------------------}

procedure pegaTipoENome (var tipoArq: char; var tipoAplic, nomeArq: string);
var s, s2, tipoCodif: string;
    i, p, p2: integer;
begin
    tipoArq := 'N';
    tipoAplic := 'text/plain';
    nomeArq := '';
    tipoCodif := '';

    repeat
        s := '';
        repeat
             s2 := '';
             if not eof (arqOrig) then
                 readln (arqOrig, s2);
             s := s + s2;
        until eof (arqOrig) or (s2 [length(s2)] <> ';');

        if upstr (copy (s, 1, 13)) = 'CONTENT-TYPE:' then
            begin
               p := pos (';', s);    { pega tipo da aplicacao }
               if p = 0 then p := length (s)+1;
               tipoAplic := copy (s, 14, p-14);
               while (tipoAplic <> '') and (tipoAplic[1] = ' ') do
                    delete (tipoAplic, 1, 1);

               p := pos ('name=', s);    { pega nome do arquivo }
               if p <> 0 then
                   begin
                       p := p + 5;
                       while s[p] = ' ' do p := p + 1;
                       if s[p] = '"' then p := p + 1;
                       p2 := p;
                       while (p2 <= length (s)) and (s [p2] <> '"') and (s [p2] <> ';') do
                           p2 := p2 + 1;
                       if (s[p2] = '"') or (s[p2] = ';') then p2 := p2 - 1;
                       nomeArq := copy (s, p, p2-p+1);
                   end;
            end
        else
        if upstr (copy (s, 1, 26)) = 'CONTENT-TRANSFER-ENCODING:' then
            begin
                tipoCodif := copy (s, 27, length (s)-27+1);
                while (tipoCodif <> '') and (tipoCodif[1] = ' ') do
                    delete (tipoCodif, 1, 1);
                tipoCodif := upstr (tipoCodif);

                if tipoCodif = 'QUOTED-PRINTABLE' then   tipoArq := 'I'
                else
                if tipoCodif = 'X-UUENCODE' then         tipoArq := 'U'
                else
                if tipoCodif = 'BASE64' then             tipoArq := 'M'
                else
                                                         tipoArq := 'N';
            end;

    until s = '';
    sintWriteln (tipoAplic);
end;

{-------------------------------------------------------------}
{              le uma parte do arquivo
{-------------------------------------------------------------}

procedure leParteMime (chaveMime: string);
var arqSai: text;
    s: string;
    chave: string;

begin
    assign (arqSai, '$.$');
    rewrite (arqSai);

    pegaTipoENome (tipoArq, tipoAplic, nomeArq);
    if chaveMime = '' then
        begin
            close (arqOrig);
            reset (arqOrig);
            chaveMime := LIXOMIME;

            s := 'a';
            while (ioresult = 0) and (not eof (arqOrig)) and (s <> '') do
                {$I-} readln (arqOrig, s);  {$I+}
        end;

    s := '';
    repeat
         if not eof (arqOrig) then
              readln (arqOrig, s);
         if (s <> chaveMime) and (s <> chaveMime+'--') then
             begin
                 if tipoArq = 'I' then
                     s := convIso (s);

                 {$I-} writeln (arqSai, s); {$I+}
                 if ioresult <> 0 then
                     begin
                         mensagem ('CTERRDSK', 1);   {'Erro de escrita no disco'}
                         exit;
                     end;
             end;
    until eof (arqOrig) or (s = chaveMime);
    close (arqSai);

    case tipoArq of
        'U':  leituraUuencode;
        'M':  leituraMime64;
    else
        leituraNormal (tipoAplic, chaveMime);
    end;

    erase (arqSai);
end;

{-------------------------------------------------------------}
{                    Leitura de cartas Mime
{-------------------------------------------------------------}

procedure leituraMime (nomeArq: string);
var nomeProg: string;
    parteDesejada, i: integer;
    s: string;

begin
    assign (arqOrig, nomeArq);
    {$I-}  reset (arqOrig);  {$I+}
    if ioresult <> 0 then
        begin
            mensagem ('CTCARSUM', 1);  {'Erro no disco: carta sumiu'}
            exit;
        end;

    narqMime := 0;       { busca quantos arquivos tem }
    chaveMime := buscaChave;
    if chaveMime <> '' then
        begin
            chaveMime := '--' + chaveMime;
            while buscaRegSepar (chaveMime) do
                narqMime := narqMime + 1;
            close (arqOrig);
            mensagem ('CTNARQM', 0);   {'Número de partes inclusas: '}
            sintWriteInt (narqMime);
            writeln;
        end;

    repeat
        if narqMime > 1 then
            begin
                textBackground (RED);
                mensagem ('CTQPARTE', 0);    {'Qual a parte desejada ? (depois enter) '}
                textBackground (BLACK);
                sintReadln (s);
                if s = '' then exit;
                parteDesejada := 0;
                val (s, parteDesejada, i);
            end
        else
             parteDesejada := narqMime;

        if parteDesejada <= narqMime then
            begin
                reset (arqOrig);
                if chaveMime <> '' then
                    for i := 1 to parteDesejada do
                         if not buscaRegSepar (chaveMime) then
                             reset (arqOrig);
                leParteMime (chaveMime);
                {$I-}  close (arqOrig);   {$I+}
                if ioresult <> 0 then;
            end;
    until narqMime <= 1;   { neste caso so faz uma vez }
end;

end.
