unit dostec;
interface
uses windos, dvcrt, winprocs, winTypes, dvwin,
     dosgeral, dosmsg;

procedure testaTeclado;

implementation

{--------------------------------------------------------}
{                  opcao de teste de teclado
{--------------------------------------------------------}

procedure interControles (var status: word);
var dif, novostatus: word;

    function KbStatus: byte;
        var retorno: byte;
    begin
        retorno := 0;
        If (getKeyState (vk_numlock) and 1) <> 0  then
            retorno := retorno + $20;
        If (getkeystate (vk_capital) and 1) <> 0  then
            retorno := retorno + $40;
        If ((getkeystate (vk_shift) shr 15) and 1) <> 0  then
            retorno := retorno + $1;
        If ((getkeystate (vk_control) shr 15) and 1) <> 0  then
            retorno := retorno + $4;
        If ((getkeystate (vk_menu) shr 15) and 1) <> 0  then
            retorno := retorno + $8;

        kbStatus := retorno;
    end;

begin
    novostatus := kbStatus;

    dif := status xor novostatus;
    status := novostatus;
    if dif = 0 then exit;

    if (dif and 3) <> 0 then
        if (status and 3) <> 0 then
            mensagem (DVSHIFT, 0);

    if (dif and 4) <> 0 then
        if (status and 4) <> 0 then
            mensagem (DVCONTRL, 0);

    if (dif and $8) <> 0 then
        if (status and $8) <> 0 then
            mensagem (DVALT, 0);

    if (dif and $20) <> 0 then
        if (status and $20) <> 0 then
            mensagem (DVNUM, 0)
        else
            mensagem (DVNONUM, 0);

    if (dif and $40) <> 0 then
        if (status and $40) <> 0 then
            mensagem (DVCAPS, 0)
        else
            mensagem (DVNOCAPS, 0);

end;

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

procedure testaTeclado;
var
    terminou: boolean;
    status, novoStatus: word;
    c, c2: char;
    i: integer;

begin
    textBackground (RED);
    clreol;
    mensagem (DVTECLE, 1);
    mensagem (DVFIMTEC, 1);
    textBackground (BLACK);
    clreol;

    status := 0;

    terminou := false;
    while not terminou do
        begin
            interControles (status);

            if keypressed then
                begin
                    pegaTeclado (c, c2);
                    if c <> #0 then
                        begin
                            case c of
                                #$08: mensagem (DVTECBS, 0);
                                #$09: mensagem (DVTECTAB, 0);
                                ' ':  mensagem (DVTECBCO, 0);
                                #$0d: begin
                                          mensagem (DVTECENT, 0);
                                          writeln;
                                      end;
                                #$21..#255:
                                       soletra (c, 0);
                                #$1b: begin
                                          mensagem (DVTECESC, 0);
                                          terminou := true;
                                      end;
                            end;
                        end
                    else
                        begin
                            case c2 of
                                F1..F9: begin
                                          soletra ('f', 0);
                                          i := ord (c2) - ord (F1) + ord('1');
                                          soletra (chr (i), 0);
                                        end;

                                F10:    mensagem (DVTECF10, 0);

                                INS:    mensagem (DVTECINS, 0);
                                DEL:    mensagem (DVTECDEL, 0);
                                HOME:   mensagem (DVTECHOM, 0);
                                TEND:   mensagem (DVTECEND, 0);
                                PGUP:   mensagem (DVTECPGU, 0);
                                PGDN:   mensagem (DVTECPGD, 0);

                                CIMA:   mensagem (DVTECCIM, 0);
                                BAIX:   mensagem (DVTECBAI, 0);
                                ESQ:    mensagem (DVTECESQ, 0);
                                DIR:    mensagem (DVTECDIR, 0);
                            end;
                        end;

                    if c <> #$0d then write (' ');
                end;
        end;

    writeln;
    mensagem (DVFIMTST, 1);
end;

end.
