unit doscopia;
interface
uses windos, dvcrt, dvwin, strings,
     dosgeral, dosmsg, wow16;

type
    nomearq = string[12];
    arqlist = array [1..5000] of nomearq;
var
    masc: string;
    listarq: ^arqlist;
    numarqs: integer;
    numArqAtual: integer;

procedure fazCopias (nomearq: string);
function montaDirList (atributo: word): boolean;
procedure problemaDisco;
procedure falaNomeExtenso (nome: string);
procedure alocaDosvox32;
procedure desalocaDosvox32;

implementation
var
    arqin, arqout: file;
    hDosvox32: THandle32;

{--------------------------------------------------------}
{       rotinas auxiliares para manuseio de arquivos
{--------------------------------------------------------}

    function montaDirList (atributo: word): boolean;
    var
        buscado: TSearchRec;
        temp: string;
        i, j: integer;
        nomeAchado: string;
    begin
        numArqs := 0;
        masc [length (masc)+1] := #$0;
        FindFirst (@masc[1], atributo, buscado);
        while DosError = 0 do
            begin
                 nomeAchado := strPas(buscado.name);
                 if (atributo = FaArchive) or
                    (  ((buscado.attr and atributo) <> 0) and
                        (nomeAchado <> '.')
                    ) then
                    begin
                        numArqs := numArqs + 1;
                        listarq^[numArqs] := nomeAchado;
                    end;
                FindNext(buscado);
            end;

        montaDirList := numArqs <> 0;
        numArqAtual := 0;

        for i := 1 to numArqs-1 do
            for j := i to numArqs do
                 if listarq^[i] > listarq^[j] then
                     begin
                         temp := listarq^[i];
                         listarq^[i] := listarq^[j];
                         listarq^[j] := temp;
                     end;

    end;

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

    procedure problemaDisco;
    begin
        limpaBufTec;
        mensagem (DVPROBLE, 1);
        if not montaDirList (FaArchive) then;
    end;

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

    procedure ajudaCopia;
    var i: integer;
        c: char;
    begin
        writeln;
        for i := AJUDACOP_1 to AJUDACOP_99 do
            begin
                mensagem (i, 1);
                if keypressed then
                    begin
                        while keypressed do c := readkey;
                        sintBip;
                        exit;
                    end;
            end;
    end;

{--------------------------------------------------------}
{                  copias de arquivos
{--------------------------------------------------------}

    { esta rotina recebe os nomes dos arquivos ja' assinalados }
    {  aos arquivos arqin e arqout }

    function copiaUm: boolean;
    const
        BUFSIZE = 8192;
    type
        BUFFER = array [0..BUFSIZE-1] of byte;

    var i, tam: longint;
        nbytes: word;
        buf: ^BUFFER;
        erro: word;
    label fim;

    begin
        copiaUm:= false;

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

        new (buf);

        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
                        limpaBufTec;
                        mensagem (DVERRLEI, 1);
                        goto fim;
                    end;

                {$I-} blockwrite (arqout, buf^, nbytes); {$I+}
                erro := ioresult;
                if erro = 101 then
                    begin
                        limpaBufTec;
                        mensagem (DVFALESP, 1);
                        goto fim;
                    end;

                tam := tam - BUFSIZE;
            end;

        copiaUm := true;

fim:
        dispose (buf);

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

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

    function selecDirDest (var diret: string): boolean;
    var c: char;
        diratual: string;
    begin
        selecDirDest := false;

        mensagem (DVINFDST, 1);
        sintReadln (diret);
        if diret = '' then
            begin
                mensagem (DVCANCG, 1);
                exit;
            end;

        getdir (0, diratual);

        {$I-} chdir (diret);  {$I+}
        if ioresult <> 0 then
            begin
                limpaBufTec;
                mensagem (DVERRDIR, 1);
                {$I-} chdir (diratual);  {$I+}
                if ioresult <> 0 then;
                exit;
            end;

        getdir (0, diret);
        {$I-}  chdir (diratual);  {$i+}
        if ioresult <> 0 then;

        if diret = diratual then
            begin
                mensagem (DVNAOPOD, 1);
                exit;
            end;

        if diret [length(diret)] <> '\' then
           diret := diret + '\';

        selecDirDest := true;
    end;

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

    procedure copiaEste (nomearq: string);
    var c, c2: char;
         diret: string;
    begin
        if nomearq = '' then
            begin
                 mensagem (DVNAOSEL, 1);
                 exit;
            end;

        if not selecDirDest (diret) then
            exit;

        assign (arqin, nomearq);
        assign (arqout, diret+nomearq);

        if not copiaUm then
             mensagem (DVERRCOP, 1)
        else
             begin
                  write (nomearq);
                  sintetiza (nomearq);
                  mensagem (DVFOICOP, 1);
             end;
    end;

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

    procedure copiaTodos (apagando: boolean);
    var
        diret: string;
        i: integer;
        nomearq: string;
    begin
        if not selecDirDest (diret) then
            exit;

        for i := 1 to numArqs do
            begin
                nomearq := listarq^[i];
                assign (arqin, nomearq);
                assign (arqout, diret+nomearq);

                if not copiaUm then
                    begin
                         mensagem (DVERRCOP, 1);
                         exit;
                    end
                else
                    begin
                       write (nomearq);
                       sintetiza (nomearq);
                       mensagem (DVFOICOP, 1);
                       if apagando then
                           erase (arqin);
                    end;
            end;

        if apagando then
	    if montaDirList (FaArchive) then;
    end;

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

    procedure replicaArquivo (nomearq: string);
    var c, c2: char;
        novoNome: string;
        salva: integer;
    begin
        if nomearq = '' then
            begin
                 mensagem (DVNAOSEL, 1);
                 exit;
            end;

        mensagem (DVNOMCOP, 0);
        sintReadln (novoNome);
        if novoNome = '' then
            exit;

        if novoNome = compacta (nomearq) then
            begin
                limpaBufTec;
                mensagem (DVNOMERR, 1);
                exit;
            end;

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

        if not copiaUm then
            begin
                mensagem (DVERRCOP, 1);
                {$I-} erase (arqout); {$i+}
                if ioresult <> 0 then;
            end
        else
            begin
                soletra (novoNome, 0);
                mensagem (DVFOIREP, 1);
            end;

        salva := numArqAtual;
	if montaDirList (FaArchive) then;
        numArqAtual := salva;
    end;

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

procedure fazCopias (nomearq: string);
var
    tratandoArquivos: boolean;
    c, c2: char;
label inicio;

begin
inicio:
    textBackground (MAGENTA);
    mensagem (DVTIPCOP, 0);
    textBackground (BLACK);

    limpabuf;
    pegaTeclado (c, c2);

    if (c = #$1b) or ((c = #0) and (c2 <> F1)) then
        begin
            writeln;
            mensagem (DVOK, 1);
            exit;
        end;

    if (c = #0) and (c2 = F1) then
        begin
            ajudaCopia;
            goto inicio;
        end;

    mensagem (DVOPCAO, 0);
    soletra (c, 1);

    case upcase(c) of
        'D': copiaEste (nomearq);
        'T': copiaTodos (false);
        'R': replicaArquivo (nomearq);
        'M': copiaTodos (true);
    else
        begin
             mensagem (DVOPINV, 1);
             mensagem (DVSEF1, 1);
        end;
    end;
end;

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

procedure alocaDosvox32;
begin
    Hdosvox32 := LoadLibraryEx32W('DOSVOX32', 0, 0);
end;

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

procedure desalocaDosvox32;
begin
    if Hdosvox32 > 0 then
        FreeLibrary32W(Hdosvox32);
end;

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

procedure falaNomeExtenso (nome: string);
var
    nomeExtenso: array [0..255] of char;
    P: Longint;
    LongVect: array [0..1] of longint;
    dir: string;

begin
    if hDosvox32 > 0 then
        begin
            getdir (0, dir);
            if dir [length(dir)] <> '\' then dir := dir + '\';
            strPCopy (nomeExtenso, dir + nome);

            pointer(P) := GetProcAddress32W(hDosvox32, 'filename32');
            LongVect[0] := Longint(@nomeExtenso);
            LongVect[1] := Longint(@nomeExtenso);
            Call32BitProc(P, longVect, $3);
      end
    else
        strPCopy (nomeExtenso, nome);

    sintWrite (strPas (nomeExtenso));
end;

end.
