old/PAS/CRYPT.PAS

type
        header=record
                title:array [1..22] of char;
                name:array [1..8] of char;
                pass:array [1..5] of char;
        end;
const
        hh='Закодированный файл'#13#10#26;
var
        f1,f2:file;
        t:header;
        buf:array [1..5000] of word;
        p1,p2:array [1..5] of char;
        m:word;
        s:string;
        w:word;

function readkeyword:word; inline($b4/0/$cd/$16);

procedure getpass(mess:string; var p);
var
        pp:array [1..5] of byte absolute p;
        i,n:byte;
        ww:array [1..2] of byte absolute w;
begin
        write(mess);
        s:='';
        write('░░░░░░░░░░░░░░░░░░░░'#8#8#8#8#8#8#8#8#8#8#8#8#8#8#8#8#8#8#8#8);
        repeat
                m:=readkeyword;
                if m=$0E08 then
                        if s<>'' then
                        begin
                                write(#8#176#8);
                                delete(s,length(s)-1,2);
                        end else
                else
                if (m<>$1C0D) and (length(s)<40) then
                begin
                        s:=s+chr(lo(m))+chr(hi(m));
                        write(#219);
                end;
        until m=$1C0D;
        fillchar(pp,5,0);
        w:=0;
        for i:=1 to length(s) do
        begin
                n:=ord(s[i]);
                pp[1]:=pp[1]+n;
                pp[2]:=pp[2]-n;
                pp[3]:=pp[3] xor n;
                pp[4]:=pp[4]+pp[1]+n;
                pp[5]:=pp[5]-pp[2]-n;
                ww[1]:=ww[1]+n;
                ww[2]:=ww[2] xor n;
        end;
        writeln;
end;

procedure help;
begin
        writeln(#13#10'Вызов : CF <вх_файл> <вых_файл>');
        halt;
end;

procedure code(mess:string);
var
        l,l1:longint;
        k,i:word;
begin
        l:=filepos(f1); l1:=filesize(f1);
        while not eof(f1) do
        begin
                blockread(f1,buf,10000,k);
                for i:=1 to k div 2 do buf[i]:=buf[i] xor w;
                blockwrite(f2,buf,k);
                inc(l,k);
                write(mess);
                write((l/l1)*100:6:1,'%'#13);
        end;
        writeln;
end;

procedure work;
begin
        reset(f1,1);
        rewrite(f2,1);
        blockread(f1,t,sizeof(t));
        if t.title<>hh then
        begin { Кодируем f1 в f2 }
                seek(f1,0);
                repeat
                        getpass('Введите пароль : ',p1);
                        getpass('И еще разок    : ',p2);
                        if p1<>p2 then writeln('Ошибочка !');
                until p1=p2;
                t.title:=hh;
                t.name:='????????';
                move(p1,t.pass,5);
                blockwrite(f2,t,sizeof(t));
                code('Кодирование : ');
        end else
        begin
                getpass('Введите пароль : ',p1);
                if p1<>t.pass then writeln('Ошибочка !') else
                begin
                        seek(f1,0);
                        blockread(f1,t,sizeof(t));
                        code('Раскодирование : ');
                end;
        end;
end;

begin
        writeln('File Coder V1.0 (C) SEEM Group, 1993'#13#10);
        if paramcount<>2 then help;
        assign(f1,paramstr(1));
        assign(f2,paramstr(2));
        work;
        close(f1);
        close(f2);
end.