unit ugerahtml;

interface
uses dialogs, sysUtils, classes, uvars;

procedure geraHtml (nomeArq, nomeArqSai, nomeArqModelo: string);
var
   emPHP: boolean;
   emAnsi: boolean;

implementation
var
   titulo, cabecalho, logotipo, topico, email, autor: string;
   arq, arqSai, arqModelo: text;
   emTabela: boolean;
   colTab, numColTab: integer;
   erro_detectado: boolean;
   acts: TStringList;

{-------------------------------------------------------------}
{                     converte acentos
{-------------------------------------------------------------}

procedure criaActs;
begin
    acts := TStringList.Create;
    acts.Delimiter := '=';
    acts.add('á=á');
    acts.add('é=é');
    acts.add('í=í');
    acts.add('ó=ó');
    acts.add('ú=ú');
    acts.add('â=â');
    acts.add('ê=ê');
    acts.add('ô=ô');
    acts.add('ã=ã');
    acts.add('õ=õ');
    acts.add('à=à');
    acts.add('ò=ò');
    acts.add('ü=&utrema;');
    acts.add('ç=ç');
    acts.add('Á=Á');
    acts.add('É=É');
    acts.add('Í=Í');
    acts.add('Ó=Ó');
    acts.add('Ú=Ú');
    acts.add('Â=Â');
    acts.add('Ê=Ê');
    acts.add('Ô=Ô');
    acts.add('Ã=Ã');
    acts.add('Õ=Õ');
    acts.add('À=À');
    acts.add('Ü=&Utrema;');
    acts.add('Ç=Ç');
    acts.sorted := true;
    acts.CaseSensitive := true;
end;

function cact (s: string): string;
var i: integer;
    v, saida: string;
begin
    if emAnsi then
        result := s
    else
        begin
            saida := '';
            for i := 1 to length(s) do
                if s[i] < #127 then
                    saida := saida + s[i]
                else
                    begin
                        v := '';
                        {$R-} v := acts.Values[s[i]]; {$R+}
                        if v = '' then v := s[i];
                        saida := saida + v;
                    end;
            result := saida;
        end;
end;

{-------------------------------------------------------------}
{                     transcreve modelo
{-------------------------------------------------------------}

procedure transcreveModelo (parteModelo: string);
var
    s: string;
    p: integer;
label achou;
begin
   assignFile (arqModelo, nomeModeloLocal);
   {$I-}  reset (arqModelo);  {$I+}
   if ioresult <> 0 then
       begin
            if not erro_detectado then
                showMessage ('Arquivo de modelos ' + nomeModeloLocal + ' não está presente, transcrição incompleta');
            erro_detectado := true;
            exit;
       end;

{ busca uma das seguintes partes
     <<<CABEÇALHO>>>
     <<<TÓPICO>>>
     <<<ASSINATURA>>>
     <<<FIM>>>
}

   while not eof (arqModelo) do
       begin
           readln (arqModelo, s);
           if AnsiUpperCase(s) = AnsiUpperCase(parteModelo) then goto achou;
       end;

   showMessage ('Arquivo de modelo está danificado');
   close (arqModelo);
   exit;

achou:
   s := '';
   while (not eof (arqModelo)) and (AnsiUpperCase (s) <> '<<<FIM>>>') do
       begin
           readln (arqModelo, s);

           p := pos ('[TÍTULO]', s);
           if p <> 0 then
               begin
                   delete (s, p, 8);
                   insert (titulo, s, p);
               end;

           p := pos ('[CABEÇALHO]', s);
           if p <> 0 then
               begin
                   delete (s, p, 11);
                   insert (cabecalho, s, p);
               end;

           p := pos ('[TÓPICO]', s);
           if p <> 0 then
               begin
                   delete (s, p, 8);
                   insert (topico, s, p);
               end;

           p := pos ('[EMAIL]', s);
           if p <> 0 then
               begin
                   delete (s, p, 7);
                   insert (email, s, p);
               end;

           p := pos ('[AUTOR]', s);
           if p <> 0 then
               begin
                   delete (s, p, 7);
                   insert (autor, s, p);
               end;

           p := pos ('[LOGOTIPO]', s);
           if p <> 0 then
               begin
                   delete (s, p, 10);
                   insert (logotipo, s, p);
               end;

           if AnsiUpperCase (s) <> '<<<FIM>>>' then
               writeln (arqSai, cact(s));
       end;

   close (arqModelo);
end;

{-------------------------------------------------------------}
{                     cria o rótulo local
{-------------------------------------------------------------}

procedure criaRotuloLocal (lido: string);
begin
   delete (lido, 1, 1);
   writeln (arqSai, '<A NAME="', cact(lido), '">');
end;

{-------------------------------------------------------------}
{                     cria o rótulo local
{-------------------------------------------------------------}

procedure criaReferenciaExterna (lido: string);
var referencia, texto: string;
    p: integer;
    sobra: string;
    target: string;
begin
   referencia := '';
   sobra := '';

   trim(lido);
   p := lastDelimiter ('}', lido);
   if (p <> 0) and (p <> length(lido)) then
       begin
           sobra := copy (lido, p+1, 999);
           delete (lido, p+1, 999);
       end;

   p := 2;
   while (p <= length (lido)) and (lido[p] <> ' ') do
       p := p + 1;
   referencia := copy (lido, 2, p-2);
   if copy (referencia, 1, 1) = '*' then
       begin
           target := ' TARGET="blank"';
           delete (referencia, 1, 1);
       end
   else
       target := '';

   texto := copy (lido, p+1, 999);

   if emTabela then   // cuidado, sintaxe simplificada para uma só linha
       begin
            if colTab = 0 then
                {$I-}   writeln (arqSai, '<tr>');   {$I+}
            if ioresult <> 0 then exit;
            delete (texto, length(texto), 1);
            writeln (arqSai,
                '<td>' + '<A HREF="', referencia, '"' + target + '>' +
                cact(texto) + '</td>');
            colTab := (colTab+1) mod numColTab;
            if colTab = 0 then
                writeln (arqSai, '</tr>');

            exit;
       end;

   {$I-}  write (arqSai, '<A HREF="', referencia, '"' + target + '>');  {$I+}
   if ioresult <> 0 then exit;
   if texto <> '' then
        begin
            if texto [length (texto)] = '}' then
                delete (texto, length (texto), 1);
            {$I-}  write (arqSai, cact(texto));  {$I+}
            if ioresult <> 0 then exit;
            {$I-}  writeln (arqSai, '</A>'+cact(sobra));  {$I+}
            if ioresult <> 0 then exit;
        end;
end;

{-------------------------------------------------------------}
{                     cria imagem
{-------------------------------------------------------------}

procedure criaFoto (lido: string);
var referencia, texto: string;
    p: integer;
    centrando: boolean;
begin
   referencia := '';
   centrando := true;
   if copy (lido, 2, 1) = '*' then
       begin
           centrando := false;
           delete (lido, 2, 1);
       end;

   p := 2;
   while (p < length (lido)) and (lido[p] <> ' ') do
       p := p + 1;
   referencia := copy (lido, 2, p-2);

   texto := copy (lido, p+1, 999);
   if (texto = '') and (not eof (arq)) then
       readln (arq, texto) ;   { le proxima linha }

   if (texto <> '') and (texto [length (texto)] = '$') then
       delete (texto, length (texto), 1);

   if centrando then
        begin
           {$I-}  write (arqSai, '<CENTER>');  {$I+}
           if ioresult <> 0 then exit;
        end;

   {$I-}  write (arqSai, '<IMG SRC="', referencia, '"');  {$I+}
   if ioresult <> 0 then exit;
   if texto <> '' then
       begin
          {$I-}  write (arqSai, ' ALT="', cact(texto), '"' +
                              ' TITLE="', cact(texto), '"');  {$I+}
          if ioresult <> 0 then exit;
       end;

   if centrando then
       {$I-}  writeln (arqSai, '></CENTER>')  {$I+}
   else
       {$I-}  writeln (arqSai, '>');  {$I+}
   if ioresult <> 0 then exit;
end;

{-------------------------------------------------------------}
{                     gera cabeçalho
{-------------------------------------------------------------}

procedure geraCabecalho;
begin
    transcreveModelo ('<<<CABEÇALHO>>>');
end;

{-------------------------------------------------------------}
{                     cria subtítulos
{-------------------------------------------------------------}

procedure criaSubtitulo (lido: string);
begin
    topico := copy (lido, 2, length(lido)-1);
    transcreveModelo ('<<<TÓPICO>>>');
end;

{-------------------------------------------------------------}
{                     gera comandos finais
{-------------------------------------------------------------}

procedure geraComandosFinais;
begin
    transcreveModelo ('<<<ASSINATURA>>>');
end;

{-------------------------------------------------------------}
{                pega os parametros principais
{-------------------------------------------------------------}

procedure pegaCabecalho;
var s: string;
begin
    autor := nomeAutor;
    email := emailAutor;
    logotipo := 'logotipo.gif';
    titulo := '';
    cabecalho := '';
    nomeModeloLocal := nomeModeloDefault;
    emAnsi := not emPhp;

    if emPHP then
        begin
            repeat
                {$I-} readln (arq, s);  {$I+}
                if ioresult <> 0 then exit;
                writeln (arqSai, cact(s));
            until (pos ('?>', s) <> 0) or eof(arq);

        end;

    while not eof (arq) do
        begin
            {$I-} readln (arq, s);  {$I+}
            if ioresult <> 0 then exit;
            if s = '' then break;

            if pos (':', s) = 0 then
                begin
                    if titulo = '' then titulo := s;
                    if cabecalho = '' then cabecalho := s;
                    break;
                end;

            if (AnsiUpperCase(copy (s, 1, 7)) = 'TÍTULO:') or
               (AnsiUpperCase(copy (s, 1, 7)) = 'TITULO:') then
                titulo := trim(copy (s, 8, 999));

            if (AnsiUpperCase(copy (s, 1, 9)) = 'LOGOTIPO:') then
                logotipo := trim(copy (s, 10, 999));

            if (AnsiUpperCase(copy (s, 1, 10)) = 'CABEÇALHO:') or
               (AnsiUpperCase(copy (s, 1, 10)) = 'CABECALHO:') then
                cabecalho := trim(copy (s, 11, 999));

            if AnsiUpperCase(copy (s, 1, 6)) = 'AUTOR:' then
                autor := trim(copy (s, 7, 999));

            if (AnsiUpperCase(copy (s, 1, 6)) = 'EMAIL:') then
                email := trim(copy (s, 7, 999));

            if (AnsiUpperCase(copy (s, 1, 7)) = 'MODELO:') then
                nomeModeloLocal := trim(copy (s, 8, 999));
        end;

end;

{-------------------------------------------------------------}
{                     trata tabelas
{-------------------------------------------------------------}

procedure procTabela (lido: string);
var erro: integer;
begin
    delete (lido, 1, 1);
    if lido <> '' then
        begin
            emTabela := true;
            writeln (arqSai, '<table><style>');
            writeln (arqSai, 'table {border-collapse: collapse;}');
            writeln (arqSai, 'table, th, td {padding:2; border: 1px solid black;}');
            writeln (arqSai, '</style>');
            colTab := 0;
            val (trim(lido), numColTab, erro);
        end
    else
        begin
            emTabela := false;
            writeln (arqSai, '</table>');
        end;
end;

{-------------------------------------------------------------}
{        pega um parâmetro para gerar input de formulário
{-------------------------------------------------------------}

function pegaParamInput (var lido: string): string;
var p: integer;
begin
    result := '';
    lido := trim (lido);
    if lido = '' then exit;

    if lido[1] = '"' then
        begin
            delete (lido, 1, 1);
            p := pos ('"', lido);
            if p = 0 then p := 999;
            result := copy (lido, 1, p-1);
            delete (lido, 1, p);
        end
    else
        begin
            p := pos (' ', lido);
            if p = 0 then
                begin
                    result := lido;
                    lido := '';
                end
            else
                begin
                    result := copy (lido, 1, p-1);
                    delete (lido, 1, p);
                end
        end;

    lido := trim(lido);
end;

{-------------------------------------------------------------}
{                  gera inputs de formulário
{-------------------------------------------------------------}

procedure geraInput (lido: string; tipo: string);
var
    s: string;
    size, erro: integer;
    name, id, value, txt: string;
    checkVar, checkMark: string;
    comparacao: string;

    function phpValue (v: string): string;
    begin
        if copy (v, 1, 1) = '$' then
            result := '<?php echo ' + v + '; ?>'
        else
            result := v;
    end;

begin
    size := 0;
    name := '';
    id := '';
    value := '';

    if (lido <> '') and (lido[1] in ['1'..'9'])then
        val (pegaParamInput(lido), size, erro);

    if (lido <> '') and (lido[1] = '[') then
        begin
            s := pegaParamInput(lido);
            id := copy (s, 2, length(s)-1);
        end;

    name := pegaParamInput(lido);
    if tipo = 'checkbox' then
        value := 'x'
    else
        value := pegaParamInput(lido);
    txt := pegaParamInput(lido);
    checkVar := pegaParamInput(lido);

    if emPHP then
        begin
            if (tipo = 'text') or (tipo = 'hidden') or (tipo = 'password') then
                value := phpvalue(value)
        end;

    s := '<INPUT TYPE="' + tipo + '" NAME="' + name + '"';
    if id <> '' then
        s := s + ' ID="' + id + '"';
    if size <> 0 then
        s := s + ' SIZE="' +intToStr(size) + '"';
    if value <> '' then
        s := s + ' VALUE="' + value + '"';

    if checkVar <> '' then
        begin
            if (checkVar = '*') or (checkVar[1] <> '$') then
                checkMark := ' CHECKED'
             else
                begin
                    if (tipo = 'radio') or (tipo = 'checkbox') then
                        comparacao := value
                    else
                        comparacao := name;
                    checkMark := ' <?php echo ' + checkVar + '==' + '''' + comparacao + '''' +
                                 '? ''CHECKED'':''''; ?>';
                end;
        end;

    s := s + checkmark + '>';
    s := s + txt;
    s := s + '</input>';

    writeln (arqSai, cact(s));
end;

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

procedure geraTextarea (lido: string);
var
    s: string;
    rows, cols, erro: integer;
    name, id, value: string;
begin
    rows := 0;
    cols := 0;
    name := '';
    id := '';
    value := '';

    if lido = '*' then exit;   // evita uso equivocado de fechamento

    if (lido <> '') and (lido[1] in ['1'..'9'])then
        val (pegaParamInput(lido), rows, erro);
    if (lido <> '') and (lido[1] in ['1'..'9'])then
        val (pegaParamInput(lido), cols, erro);

    if (lido <> '') and (lido[1] = '[') then
        begin
            s := pegaParamInput(lido);
            id := copy (s, 2, length(s)-1);
        end;

    name := pegaParamInput(lido);
    value := pegaParamInput(lido);

    s := '<TEXTAREA NAME="' + name + '"';
    if id <> '' then
        s := s + '" ID="' + id + '"';

    if rows <> 0 then
        s := s + ' ROWS="' + intToStr(rows) + '"';
    if cols <> 0 then
        s := s + ' COLS="' + intToStr(cols) + '"';
    s := s + '>';
    writeln (arqSai, s);

    if value = '' then
        begin
            while not eof(arq) do
                begin
                    readln (arq, lido);
                    if lido = '&A*' then break;
                    writeln (arqSai, lido);
                end;
            writeln (arqSai, '</TEXTAREA>');
        end
    else
        begin
            if value[1] = '$' then
                writeln (arqsai, '<?php echo ' + value + '; ?>')
            else
                writeln (arqSai, value);
            writeln (arqSai, '</TEXTAREA>');
        end;

end;

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

procedure geraSelect (lido: string);
var
    s: string;
    size, erro: integer;
    name, id, value, txt: string;
    checkMark: string;
begin
    size := 0;
    name := '';
    id := '';

    name := pegaParamInput(lido);

    if (lido <> '') and (lido[1] in ['1'..'9'])then
        val (pegaParamInput(lido), size, erro);

    if (lido <> '') and (lido[1] = '[') then
        begin
            s := pegaParamInput(lido);
            id := copy (s, 2, length(s)-1);
        end;

    s := '<SELECT NAME="' + name + '"';
    if id <> '' then
        s := s + ' ID="' + id + '"';
    if size <> 0 then
        s := s + ' SIZE="' +intToStr(size) + '"';

    s := s + '>';
    writeln (arqSai, cact(s));

    while not eof(arq) do
        begin
            readln (arq, lido);
            if lido = '&S' then break;
            value := pegaParamInput(lido);
            txt := pegaParamInput(lido);

            checkMark := pegaParamInput(lido);
            if checkMark <> '' then
                begin
                    if (checkMark = '*') or (checkMark[1] <> '$') then
                        checkMark := ' SELECTED'
                    else
                        checkMark := ' <?php echo ' + checkMark + '==' +
                                     '''' + value + '''' + '? ''SELECTED'':''''; ?>';
                end;

            s := '<OPTION VALUE="' + value + '"' + checkMark + '>' +
                 cact(txt) + '</OPTION>';
            writeln (arqSai, s);
        end;

    writeln (arqSai, '</SELECT>');
end;

{-------------------------------------------------------------}
{                     trata formulários
{-------------------------------------------------------------}

procedure procForm (lido: string);
var funcao: char;
    m, dest, s: string;

begin
    delete (lido, 1, 1);
    if lido = '' then
        writeln (arqSai, '</form>')
    else
        begin
            funcao := lido[1];
            delete (lido, 1, 1);
            lido := trim (lido);

            case upcase(funcao) of
               'F':  {'Post ou Get (cabeçalho)'}
                   begin
                       if upperCase(pegaParamInput(lido)) = 'G' then m := 'GET'
                                                                else m := 'POST';
                       dest := pegaParamInput(lido);
                       if (dest <> '') and (dest[1] = '$') then
                           dest := '<?php echo ' + dest + ';?>';
                       s := '<FORM method="' + m + '" action="' + dest + '"' + ' enctype="multipart/form-data"';
                       if lido <> '' then
                           if lido = '*' then
                               s := s + ' TARGET=blank'
                           else
                               s := s + lido;
                       s := s + '>';
                       writeln (arqSai, cact(s));
                   end;

               'T': geraInput (lido, 'text');
               'D': geraInput (lido, 'date');
               'P': geraInput (lido, 'password');
               'H': geraInput (lido, 'hidden');
               'U': geraInput (lido, 'file');
               'R': geraInput (lido, 'radio');
               '*': geraInput (lido, 'submit');
               '/': geraInput (lido, 'reset');
               'C': geraInput (lido, 'checkbox');
               'S': geraSelect (lido);
               'A': geraTextarea (lido);
            end;
        end;
end;

{-------------------------------------------------------------}
{                     sai uma coluna da tabela
{-------------------------------------------------------------}

procedure saiColTabela (lido: string);
begin
    if numColTab <= 0 then numColTab := 1;  // evita erros
    if colTab = 0 then
        writeln (arqSai, '<tr>');
    writeln (arqSai, '<td>' + cact(lido) +'</td>');
    colTab := (colTab+1) mod numColTab;
    if colTab = 0 then
        writeln (arqSai, '</tr>');
end;

{-------------------------------------------------------------}
{                     processamento
{-------------------------------------------------------------}

procedure geraHtml (nomeArq, nomeArqSai, nomeArqModelo: string);
var lido: string;
    ultBranca: boolean;
    arqIncl: textFile;
label erro, erro2, proximaLinha;

begin
    assign (arq, nomeArq);
    reset (arq);
    assign (arqSai, nomeArqSai);
    rewrite (arqSai);
    erro_detectado := false;

    pegaCabecalho;
    geraCabecalho;

    emTabela:= false;
    ultBranca := true;
    while not eof (arq) do
        begin
            readln (arq, lido);
            if trim(lido) = '' then lido := '';

            if lido = '' then
                begin
                    if emTabela then
                        saiColTabela ('')
                    else
                    if ultBranca then
                        {$I-} writeln (arqSai, '<br>')
                    else
                        {$I-} writeln (arqSai, '<p>');
                    ultBranca := true;
                    goto proximaLinha;
                end
            else
                ultBranca := false;

            if lido[1] = ' ' then
                begin
                    {$I-} writeln (arqSai, '<br>'); {$I+}
                    if ioresult <> 0 then goto erro;
                    delete (lido, 1, 1);
                    while (lido <> '') and (lido[1] = ' ') do
                        begin
                            {$I-} write (arqSai, '&nbsp;'); {$I+}
                            if ioresult <> 0 then goto erro;
                            delete (lido, 1, 1);
                        end;
                end;

            if lido = '<?php' then
                 begin
                     writeln (arqSai, lido);
                     while (not eof(arq)) do
                         begin
                              readln (arq, lido);
                              writeln (arqSai, cact(lido));
                              if eof(arq) or (lido = '?>') then goto ProximaLinha;
                         end;
                 end;

            if lido[1] = '%' then
                begin
                    delete (lido, 1, 1);
                    if not FileExists(lido) then
                        showMessage ('Arquivo de inclusão não encontrado: ' + ^m + lido)
                    else
                        begin
                            assign (arqIncl, lido);
                            reset (arqIncl);
                            while not eof (arqIncl) do
                                begin
                                    readln (arqIncl, lido);
                                    writeln (arqSai, cact(lido));
                                end;
                            closeFile (arqIncl);
                        end;
                end
            else
            if lido[1] = '.' then
                begin
                    delete (lido, 1, 1);
                    writeln (arqSai, '<li>', cact(lido));
                end
            else
            if upperCase(lido) = '<PRE>' then
                begin
                    writeln (arqSai, '<pre>');
                    repeat
                         readln (arq, lido);
                         writeln (arqSai, cact(lido));
                    until upperCase(lido) = '</PRE>';
                end
            else
            if lido = '}' then
                writeln (arqSai, '</a>')
            else
            if lido = '>>' then
                writeln (arqSai, '<blockquote>')
            else
            if lido = '<<' then
                writeln (arqSai, '</blockquote>')
            else
            if lido[1] = '#' then
                criaRotuloLocal (lido)
            else
            if lido[1] = '@' then
                procTabela (lido)
            else
            if lido[1] = '&' then
                procForm (lido)
            else
            if lido[1] = '$' then
                criaFoto (lido)
            else
            if lido[1] = '{' then
                criaReferenciaExterna (lido)
            else
            if lido[1] = '*' then
                criaSubtitulo (lido)
            else
            if copy (lido, 1, 5) = '-----' then
                writeln (arqSai, '<hr>')
            else
                begin
                    if emTabela then
                        saiColTabela (lido)
                    else
                        {$I-} writeln (arqSai, cact(lido));  {$I+}
                end;

proximaLinha:
            if ioresult <> 0 then
                goto erro;
        end;

    geraComandosFinais;

    {$I-} close (arq);  {$I+}
    if ioresult <> 0 then goto erro;
    {$I-} close (arqSai); {$I+}
    if ioresult <> 0 then goto erro2;
    exit;

erro:
    showMessage ('IMERRDSK');  {'Erro de escrita em disco'}

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

begin
    criaActs;
end.