{--------------------------------------------------------}
{            Telemark - arquivamento
{--------------------------------------------------------}

unit tmArquiv;
interface
uses dvcrt, dvwin, winprocs, strings,  windos, tmVars, tmMsg;

procedure extraiCampo (s: string; var nomeCampo, valorCampo: string);
function leCategorias: boolean;
procedure leCadastro;
procedure atribuiCampo (var estaFicha: TFicha; qualSecao, qualFolha: integer;
                        nomeCampo, valorCampo: string);
procedure criaFolha (var estaFicha: TFicha; nsecao: integer);
procedure destroiFolha (var estaFicha: TFicha; nsecao: integer; nf: integer);
function folhaEstaVazia (var estaFicha: TFicha; nsecao: integer; nf: integer): boolean;

procedure criaFicha (var estaFicha: TFicha);
procedure destroiFicha (var estaFicha: TFicha);
function leFicha (var estaFicha: TFicha; nomeArqFicha: string): boolean;
function gravaFicha (var estaFicha: TFicha): boolean;

implementation

{--------------------------------------------------------}
{             extrai campo e valor de uma cadeia
{--------------------------------------------------------}

procedure extraiCampo (s: string; var nomeCampo, valorCampo: string);
var i, n: integer;
begin
    while (s <> '') and (s[1] = ' ') do
        delete (s, 1, 1);

    nomeCampo := s;
    valorCampo := '';

    n := pos ('=', s);
    if n = 0 then exit;

    nomeCampo := copy (s, 1, n-1);

    {--- remove brancos do final e transforma em maiusculas ---}
    while (nomeCampo <> '') and (nomeCampo[length(nomeCampo)] = ' ') do
        delete (nomeCampo, length (nomeCampo), 1);
    nomeCampo := nomeCampo + #$0;
    ansiUpper (@nomeCampo[1]);
    delete (nomeCampo , length(nomeCampo), 1);

    valorCampo := copy (s, n+1, length (s)-n);
    while (valorCampo <> '') and (valorCampo[1] = ' ') do
        delete (valorCampo, 1, 1);
    while (valorCampo <> '') and (valorCampo[length(valorCampo)] = ' ') do
        delete (valorCampo, length (valorCampo), 1);
end;

{--------------------------------------------------------}
{                   le o cadastro
{--------------------------------------------------------}

procedure leCadastro;
var
    buscado: TSearchRec;
    i: integer;
    arq: text;
    s, nomeCampo, valorCampo: string;
label erroDisco;
begin
    if cadastrados <> 0 then
        begin
            for i := 1 to cadastrados do
                dispose (pessoas^[i]);
            cadastrados := 0;
        end;

    write ('Buscando...' + #$0d);

    FindFirst ('*.FIC', FaArchive, buscado);
    while DosError = 0 do
        begin
             cadastrados := cadastrados + 1;
             new (pessoas^[cadastrados]);
             with pessoas^[cadastrados]^ do
                 begin
                     nome := '';
                     telefone := '';
                     status := '';
                     nomeArq := strPas(buscado.name);
                     selecionado := false;
                 end;
            FindNext(buscado);
        end;

    clreol;

    for i := 1 to cadastrados do
        begin
            write (pessoas^[i]^.nomeArq, '       ', #$0d);

            assign (arq, pessoas^[i]^.nomeArq);
            {$I-} reset (arq); {$I+}
            if ioresult <> 0 then
                begin
                    mensagem ('TMARQMAL', 0);   {'Arquivo mal gravado'}
                    sintWriteln (pessoas^[i]^.nomeArq);
                end
            else
                with pessoas^[i]^ do
                begin
                    achados := 0;
                    while (not eof (arq)) and
                           ((nome='') or (telefone = '') or (status = '')) do
                        begin
                            {$I-}  readln (arq, s);  {$I+}
                            if ioresult <> 0 then goto erroDisco;

                            extraiCampo (s, nomeCampo, valorCampo);
                            if (nome = '') and (nomeCampo = 'NOME') then
                                 nome := valorCampo
                            else
                            if (telefone = '') and (nomeCampo = 'TELEFONE') then
                                telefone := valorCampo
                            else
                            if (status = '') and (nomeCampo = 'STATUS') then
                                status := valorCampo;
                        end;

                    if (nome = '') then
                        begin
                    erroDisco:
                            mensagem ('TMARQMAL', 0);
                            sintWriteln (pessoas^[i]^.nomeArq);
                        end;
                    close (arq);
                end;
        end;

    clreol;
end;

{--------------------------------------------------------}
{        le arquivo com as descricoes das opcoes
{--------------------------------------------------------}

function leCombos (nomeArqCombo: string): boolean;

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

    function criaCombo (s: string): boolean;
    begin
        criaCombo := false;
        if pos (']', s) <> length (s) then exit;

        delete (s, 1, 1);
        delete (s, length(s), 1);
        while (s <> '') and (s[1] = ' ') do delete (s, 1, 1);
        while (s <> '') and (s[length(s)] = ' ') do delete (s, length(s), 1);
        if s = '' then exit;

        if ncombos >= MAXCOMBO then
            begin
                mensagem ('TMMAXCMB', 1);  {'Excedido numero de opções'}
                exit;
            end;

        ncombos := ncombos + 1;
        new (combo [ncombos]);
        combo [ncombos]^.nOpcoes := 0;
        combo[ncombos]^.nomeCombo := s;
        criaCombo := true;
    end;

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

     function criaOpcao (s: string): boolean;
     var p: integer;
     begin
         criaOpcao:= false;
         if nCombos = 0 then exit;

         with combo [ncombos]^ do
             begin
                 nopcoes := nopcoes + 1;
                 if nopcoes > MAXCOMBO then
                      begin
                          mensagem ('TMMAXCMB', 1);  {'Excedido numero de opções'}
                          exit;
                      end;

                 p := pos ('=', s);
                 if p = 0 then
                     begin
                         valor[nopcoes] := s;
                         apresent[nopcoes] := s;
                     end
                 else
                     begin
                         valor[nopcoes] := copy (s, 1, p-1);
                         apresent[nopcoes] := copy (s, p+1, length (s)-p);
                     end;
             end;

         criaOpcao := true;
    end;

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

var arqCombo: text;
    s: string;
label erro;

begin
    leCombos := false;
    nCombos := 0;

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

    while not eof (arqCombo) do
        begin
            readln (arqCombo, s);
            if (s <> '') and (s[1] <> ';') then
                begin
                    if s[1] = '[' then
                        begin
                            if not criaCombo (s) then goto erro;
                        end
                    else
                        begin
                            if not criaOpcao (s) then goto erro;
                        end;
                end;
        end;

    leCombos := true;
    close (arqCombo);
    exit;

{-- tratamento de erro --}

erro:
    mensagem ('TMERRCMB', 1);   {'Erro no arquivo de opções'}
    sintWriteln (s);
end;

{--------------------------------------------------------}
{        le arquivo com as descricoes dos modelos
{--------------------------------------------------------}

function leModelo (nomeArqModelo: string): boolean;

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

    function criaParteFicha (s: string): boolean;
    begin
        criaParteFicha := false;
        if pos (']', s) <> length (s) then exit;

        delete (s, 1, 1);
        delete (s, length(s), 1);
        while (s <> '') and (s[1] = ' ') do delete (s, 1, 1);
        while (s <> '') and (s[length(s)] = ' ') do delete (s, length(s), 1);
        if s = '' then exit;

        if npartesModelo >= MAXSECOESFICHA then
            begin
                mensagem ('TMMAXMOD', 1);  {'Excedido numero de sub modelos'}
                exit;
            end;

        npartesModelo := npartesModelo + 1;
        new (fichaModelo [npartesModelo]);
        fichaModelo [npartesModelo]^.nomeParteFicha := s;
        fichaModelo [npartesModelo]^.nDadosParteFicha := 0;
        criaParteFicha := true;
    end;

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

    function buscaCombo (s: string): integer;
    var i: integer;
        s2: string;
    begin
        buscaCombo := 0;

        s := s + #$0;
        ansiUpper (@s[1]);
        delete (s, length (s), 1);

        for i := 1 to nCombos do
            begin
                s2 := combo[i]^.nomeCombo + #$0;
                ansiUpper (@s2[1]);
                delete (s2, length (s2), 1);

                if s = s2 then
                    begin
                        buscaCombo := i;
                        exit;
                    end;
            end;
    end;

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

     function criaAtributo (s: string): boolean;
     var p, erro: integer;
         resto: string;
     begin
         criaAtributo := false;
         if npartesModelo = 0 then exit;

         with fichaModelo [npartesModelo]^ do
             begin
                 nDadosParteFicha := nDadosParteFicha + 1;
                 if nDadosParteFicha > MAXDADOSPARTEFICHA then
                      begin
                          mensagem ('TMMAXMOD', 1);  {'Excedido numero de sub modelos'}
                          exit;
                      end;

                 with dadosParteFicha [nDadosParteFicha] do
                     begin
                         tipoCampo := 'A';
                         tamCampo := 58;
                         qualCombo := 0;

                         p := pos ('=', s);
                         if p = 0 then
                             nomeCampo := s
                         else
                             begin
                                 nomeCampo := copy (s, 1, p-1);
                                 delete (s, 1, p);
                                 qualCombo := buscaCombo (s);
                                 if qualCombo = 0 then
                                     begin
                                         mensagem ('TMREFINV', 1);   {'Referência inválida a opção'}
                                         exit;
                                     end;
                             end;

                         p := pos ('(', nomeCampo);
                         if p <> 0 then
                             begin
                                 resto := copy (nomeCampo, p+1, length (nomeCampo)-p);
                                 nomeCampo := copy (nomeCampo, 1, p-1);
                                 if resto [length(resto)] <> ')' then
                                     begin
                                         mensagem ('TMERRTAM', 1);   {'Tamanho do campo errado'}
                                         exit;
                                     end;
                                 if upcase (resto [1]) in ['A'..'Z'] then
                                     begin
                                         tipoCampo := upcase (resto [1]);
                                         delete (resto, 1, 1);
                                     end;
                                 delete (resto, length (resto), 1);
                                 while (resto <> '') and (resto [1] = ' ') do delete (resto, 1, 1);
                                 if resto <> '' then
                                     begin
                                         val (resto, tamCampo, erro);
                                         if erro <> 0 then
                                             begin
                                                 mensagem ('TMERRTAM', 1);   {'Tamanho do campo errado'}
                                                 exit;
                                             end;
                                     end;
                             end;

                         while (nomeCampo <> '') and (nomeCampo[1] = ' ') do
                             delete (nomeCampo, 1, 1);
                         while (nomeCampo <> '') and (nomeCampo[length(nomeCampo)] = ' ') do
                             delete (nomeCampo, length(nomeCampo), 1);
                         if nomeCampo = '' then exit;
                     end;

             end;

         criaAtributo := true;
    end;

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

var arqModelo: text;
    s: string;
label erro;

begin
    leModelo := false;
    npartesModelo := 0;

    assign (arqModelo, nomeArqModelo);
    {$I-} reset (arqModelo);  {$I+}
    if ioresult <> 0 then
        begin
            mensagem ('TMMODNAO', 1);    {'Arquivo de modelo não está presente'}
            exit;
        end;

    while not eof (arqModelo) do
        begin
            readln (arqModelo, s);
            if (s <> '') and (s[1] <> ';') then
                begin
                    if s[1] = '[' then
                        begin
                            if not criaParteFicha (s) then goto erro;
                        end
                    else
                        begin
                            if not criaAtributo (s) then goto erro;
                        end;
                end;
        end;

    leModelo := true;
    close (arqModelo);
    exit;

erro:
    npartesModelo := 0;
    mensagem ('TMERRMOD', 1);   {'Erro no arquivo de modelo'}
    sintWriteln (s);
end;

{--------------------------------------------------------}
{               le as categorias de dados
{--------------------------------------------------------}

function leCategorias: boolean;
begin
    leCombos (nomeArqCombo);
    leCategorias := leModelo (nomeArqModelo);
end;

{--------------------------------------------------------}
{          descobre o indice da parte da ficha
{--------------------------------------------------------}

function extraiParteFicha (s: string): integer;
var i: integer;
label parteInvalida;
begin
    extraiParteFicha := 0;
    if pos (']', s) <> length (s) then goto parteInvalida;

    delete (s, 1, 1);
    delete (s, length(s), 1);
    while (s <> '') and (s[1] = ' ') do delete (s, 1, 1);
    while (s <> '') and (s[length(s)] = ' ') do delete (s, length(s), 1);
    if s = '' then goto parteInvalida;

    for i := 1 to npartesModelo do
       if fichaModelo [i]^.nomeParteFicha = s then
           begin
               extraiParteFicha := i;
               exit;
           end;

parteInvalida:
    mensagem ('TMPARINV', 1);    {'Especificação de parte de ficha inválida'}
    sintWriteln (s);
end;

{--------------------------------------------------------}
{                 busca indice do campo
{--------------------------------------------------------}

function buscaIndCampo (nomeCampoBusc: string; pInfoSecao: PParteFicha): integer;
var i: integer;
    nome: string;
begin
    buscaIndCampo := 0;
    with pInfoSecao^ do
        for i := 1 to ndadosParteFicha do
            begin
                nome := dadosParteFicha[i].nomeCampo + #$0;
                ansiUpper (@nome[1]);
                delete (nome, length (nome), 1);

                if nomeCampoBusc = nome then
                    begin
                        buscaIndCampo := i;
                        exit;
                    end;
            end;
end;

{--------------------------------------------------------}
{            atribui um campo ao valor lido
{--------------------------------------------------------}

procedure atribuiCampo (var estaFicha: TFicha; qualSecao, qualFolha: integer;
                        nomeCampo, valorCampo: string);
var indCampo: integer;
begin
    with estaFicha.secao [qualSecao]^ do
        begin
            indCampo := buscaIndCampo (nomeCampo, pInfoSecao);
            if indCampo > 0 then
                with folha [qualFolha]^ do
                    dado [indCampo] := valorCampo
            else
                begin
                    mensagem ('TMINFERR', 1);    {'Informações errada na ficha'}
                    sintWriteln (nomeCampo + '=' + valorCampo);
                end;
        end;
end;

{--------------------------------------------------------}
{                   cria uma folha
{--------------------------------------------------------}

procedure criaFolha (var estaFicha: TFicha; nsecao: integer);
var i: integer;
begin
    with estaFicha.secao[nsecao]^ do
        begin
            nFolhas := nFolhas + 1;
            new (folha[nFolhas]);
            with folha[nFolhas]^ do
                 for i := 1 to pInfoSecao^.ndadosParteFicha do
                     dado[i] := '';
        end;
end;

{--------------------------------------------------------}
{                   destroi uma folha
{--------------------------------------------------------}

procedure destroiFolha (var estaFicha: TFicha; nsecao: integer; nf: integer);
var i: integer;
begin
    with estaFicha.secao[nsecao]^ do
        begin
            if nf > nFolhas then exit;   {programação defensiva}
            dispose (folha[nf]);
            for i := nf to nFolhas-1 do
                folha[nf] := folha[nf+1];
            nFolhas := nFolhas - 1;
        end;
end;

{--------------------------------------------------------}
{                  ve se folha esta vazia
{--------------------------------------------------------}

function folhaEstaVazia (var estaFicha: TFicha; nsecao: integer; nf: integer): boolean;
var i: integer;
    s: string;
begin
    folhaEstaVazia := true;
    with estaFicha.secao[nsecao]^ do
        begin
            if nf > nFolhas then exit;   {programação defensiva}
            for i := 1 to pInfoSecao^.ndadosParteFicha do
                begin
                    s := folha[nf]^.dado[i];
                    while (s <> '') and (s[1] = ' ') do
                         delete (s, 1, 1);
                    if s <> '' then
                        folhaEstaVazia := false;
                end;
        end;
end;

{--------------------------------------------------------}
{           aloca memoria dinamica para ficha
{--------------------------------------------------------}

procedure criaFicha (var estaFicha: TFicha);
var i: integer;
begin
    estaFicha.nomeArqFicha := '';
    for i := 1 to MAXSECOESFICHA do
        begin
            new (estaFicha.secao[i]);
            with estaFicha.secao[i]^ do
                begin
                    pInfoSecao := fichaModelo[i];
                    nFolhas := 0;
                end;
        end;
end;

{--------------------------------------------------------}
{           desaaloca memoria dinamica para ficha
{--------------------------------------------------------}

procedure destroiFicha (var estaFicha: TFicha);
var i, f: integer;
begin
    for i := 1 to MAXSECOESFICHA do
        if estaFicha.secao[i] <> NIL then
            begin
                with estaFicha.secao[i]^ do
                    for f := 1 to nFolhas do
                        dispose (folha [f]);
                dispose (estaFicha.secao[i]);
                estaFicha.secao[i] := NIL;
            end;
end;

{--------------------------------------------------------}
{                    le uma ficha
{--------------------------------------------------------}

function leFicha (var estaFicha: TFicha; nomeArqFicha: string): boolean;
var arqFicha: text;
    parteFichaSelec: integer;
    d: integer;
    nomeCampo, valorCampo, s: string;
label erro;

begin
clrscr;
    leFicha := false;
    assign (arqFicha, nomeArqFicha);
    {$I-} reset (arqFicha);  {$I+}
    if ioresult <> 0 then
        begin
            mensagem ('TMFICSUM', 1);    {'Arquivo de ficha sumiu !'}
            exit;
        end;

    parteFichaSelec := 0;
    with estaFicha do
      while not eof (arqFicha) do
        begin
            {$I-} readln (arqFicha, s);  {$I+}
            if ioresult <> 0 then goto erro;

            if (s <> '') and (s[1] <> ';') then
                begin
                    if s[1] = '[' then
                        begin
                            parteFichaSelec := extraiParteFicha (s);
                            if parteFichaSelec <= 0 then
                                goto erro;
                            criaFolha (estaFicha, parteFichaSelec);
                        end
                    else
                        if parteFichaSelec <> 0 then
                            with secao[parteFichaSelec]^ do
                                begin
                                    extraiCampo (s, nomeCampo, valorCampo);
                                    atribuiCampo (estaFicha, parteFichaSelec, nFolhas, nomeCampo, valorCampo);
                                end;
                end;
        end;

    estaFicha.nomeArqFicha := nomeArqFicha;

    leFicha := true;
    close (arqFicha);
    exit;

erro:
    mensagem ('TMERRFIC', 1);   {'Erro no arquivo de ficha'}
    sintWriteln (estaFicha.nomeArqFicha);
    sintWriteln (s);
    close (arqFicha);
end;

{--------------------------------------------------------}
{            remove acentos de uma cadeia
{--------------------------------------------------------}

function semAcentos (s: string): string;
const
    tabMaiuscPC: array [#$80..#$ff] of char = (

    'C','U','E','A','A','A','A','C','E','E','E','I','I','I','A','A',
    'E','þ','þ','O','O','O','U','U','Y','O','U','þ','þ','þ','þ','þ',
    'A','I','O','U','N','N','þ','þ','þ','þ','þ','þ','þ','þ','þ','þ',
    'þ','þ','þ','þ','þ','þ','þ','þ','þ','þ','þ','þ','þ','þ','þ','þ',
    'A','A','A','A','A','A','‘','C','E','E','E','E','I','I','I','I',
    'þ','N','O','O','O','O','O','X','þ','U','U','U','U','Y','þ','þ',
    'A','A','A','A','A','A','‘','C','E','E','E','E','I','I','I','I',
    'þ','N','O','O','O','O','O','X','þ','U','U','U','U','Y','þ','þ');

var
    s2: string;
    i: integer;

begin
    move (s, s2, length(s)+1);
    for i := 1 to length (s2) do
        if s2[i] in ['a'..'z'] then
            s2[i] := upcase (s2[i])
        else
        if s2[i] >= #$80 then
            s2[i] := tabMaiuscPC [s2[i]];

    for i := 1 to length (s2) do
         if not (s2[i] in ['A'..'Z', '0'..'9']) then
             s2[i] := '_';

    semAcentos := s2;
end;

{--------------------------------------------------------}
{                     acerta serial
{--------------------------------------------------------}

procedure acertaSerial;
var s: string;
    i, n, erro: integer;
begin
    if serial <> 0 then exit;

    for i := 1 to cadastrados do
        with pessoas^[i]^ do
            begin
                s := copy (nomeArq, 1, 5);
                val (s, n, erro);
                if n >= serial then serial := n + 1;
            end;

    if serial = 0 then serial := 1;

    writeln;
    textBackGround (RED);
    mensagem ('TMINFSER', 0);   {'Informe o número de série, sugiro '}
    sintWriteInt (serial);
    textBackGround (BLACK);
    writeln;
    n := 0;
    sintReadInt (n);
    if n > 0 then serial := n;
end;

{--------------------------------------------------------}
{                 gera nome do arquivo
{--------------------------------------------------------}

function geraNomeArqNovo (semente, extensao: string): string;
var nome, s: string;
    arq: file;
    p, i, valor: integer;
    achou: boolean;
begin
    repeat
        p := pos (' ', semente);
        if p <> 0 then delete (semente, p, 1);
    until p = 0;
    repeat
        p := pos ('''', semente);
        if p <> 0 then delete (semente, p, 1);
    until p = 0;
    repeat
        p := pos ('.', semente);
        if p <> 0 then delete (semente, p, 1);
    until p = 0;
    repeat
        p := pos (',', semente);
        if p <> 0 then delete (semente, p, 1);
    until p = 0;
    semente := semAcentos (copy (semente, 1, 3));

    achou := false;
    repeat
        valor := serial;
        serial := serial + 1;

        str (valor, s);
        while length (s) < 5 do
            s := '0' + s;

        nome := s+semente;
        assign (arq, nome + '.' + extensao);
        {$I-}  reset (arq);  {$I+}
        achou := ioresult = 0;
        if achou then close (arq);
    until not achou;

    geraNomeArqNovo := nome + '.' + extensao;
end;

{--------------------------------------------------------}
{                    grava uma ficha
{--------------------------------------------------------}

function gravaFicha (var estaFicha: TFicha): boolean;
var arqFicha: text;
    parteFichaSelec: integer;
    i, f, d: integer;
label inicio, erro;

begin
    gravaFicha := false;
inicio:
    with estaFicha do
        if nomeArqFicha = '' then
            begin
                acertaSerial;
                nomeArqFicha := geraNomeArqNovo (
                                   estaFicha.secao [1]^.folha [1]^.dado [1], 'FIC');

                assign (arqFicha, nomeArqFicha);
                {$I-} reset (arqFicha); {$I+}
                if ioresult = 0 then
                    begin
                        nomeArqFicha := '';
                        close (arqFicha);
                        goto inicio;
                    end;
            end;

    assign (arqFicha, estaFicha.nomeArqFicha);
    {$I-} rewrite (arqFicha);  {$I+}
    if ioresult <> 0 then goto erro;

    for i := 1 to MAXSECOESFICHA do
        with estaFicha.secao[i]^, pInfoSecao^ do
            if nFolhas <> 0 then
                for f := 1 to nFolhas do
                     begin
                         writeln (arqFicha, '[', nomeParteFicha, ']');
                         for d := 1 to nDadosParteFicha do
                              if folha[f]^.dado[d] <> '' then
                                  begin
                                      {$I-}  writeln (arqFicha,
                                           dadosParteFicha[d].nomeCampo, '=', folha[f]^.dado[d]);
                                      {$I+}
                                      if ioresult <> 0 then goto erro;
                                  end;
                         writeln (arqFicha);
                     end;

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

    gravaFicha := true;
    exit;

erro:
    gotoxy (1, 25);
    {$I-} close (arqFicha);  {$I+}
    if ioresult <> 0 then;
    mensagem ('TMERRGRV', 1);   {'Erro ao gravar a ficha, tecle enter'}
    readln;
end;

end.
