unit UnitDES;
... {$ifndef LITTLE_ENDIAN}
     ... {$define LITTLE_ENDIAN 1}
... {$endif}
interface
const
( *   32 - bit permutation function P used on the output of the S - boxes  * )
p32i: array[ 0 .. 31 ] of Byte  =  (
     16 ,  7 ,  20 ,  21 ,
     29 ,  12 ,  28 ,  17 ,
     1 ,  15 ,  23 ,  26 ,
     5 ,  18 ,  31 ,  10 ,
     2 ,  8 ,  24 ,  14 ,
     32 ,  27 ,  3 ,  9 ,
     19 ,  13 ,  30 ,  6 ,
     22 ,  11 ,  4 ,  25
);

( *  The ( in )famous S - boxes  * )
     si: array[ 0 .. 7 , 0 .. 63 ] of Byte  =
(
    ( *  S1  * )
    ( 14 ,  4 ,  13 ,  1 ,  2 ,  15 ,  11 ,  8 ,  3 ,  10 ,  6 ,  12 ,  5 ,  9 ,  0 ,  7 ,
     0 ,  15 ,  7 ,  4 ,  14 ,  2 ,  13 ,  1 ,  10 ,  6 ,  12 ,  11 ,  9 ,  5 ,  3 ,  8 ,
     4 ,  1 ,  14 ,  8 ,  13 ,  6 ,  2 ,  11 ,  15 ,  12 ,  9 ,  7 ,  3 ,  10 ,  5 ,  0 ,
     15 ,  12 ,  8 ,  2 ,  4 ,  9 ,  1 ,  7 ,  5 ,  11 ,  3 ,  14 ,  10 ,  0 ,  6 ,  13 ),

    ( *  S2  * )
    ( 15 ,  1 ,  8 ,  14 ,  6 ,  11 ,  3 ,  4 ,  9 ,  7 ,  2 ,  13 ,  12 ,  0 ,  5 ,  10 ,
     3 ,  13 ,  4 ,  7 ,  15 ,  2 ,  8 ,  14 ,  12 ,  0 ,  1 ,  10 ,  6 ,  9 ,  11 ,  5 ,
     0 ,  14 ,  7 ,  11 ,  10 ,  4 ,  13 ,  1 ,  5 ,  8 ,  12 ,  6 ,  9 ,  3 ,  2 ,  15 ,
     13 ,  8 ,  10 ,  1 ,  3 ,  15 ,  4 ,  2 ,  11 ,  6 ,  7 ,  12 ,  0 ,  5 ,  14 ,  9 ),

    ( *  S3  * )
    ( 10 ,  0 ,  9 ,  14 ,  6 ,  3 ,  15 ,  5 ,  1 ,  13 ,  12 ,  7 ,  11 ,  4 ,  2 ,  8 ,
     13 ,  7 ,  0 ,  9 ,  3 ,  4 ,  6 ,  10 ,  2 ,  8 ,  5 ,  14 ,  12 ,  11 ,  15 ,  1 ,
     13 ,  6 ,  4 ,  9 ,  8 ,  15 ,  3 ,  0 ,  11 ,  1 ,  2 ,  12 ,  5 ,  10 ,  14 ,  7 ,
     1 ,  10 ,  13 ,  0 ,  6 ,  9 ,  8 ,  7 ,  4 ,  15 ,  14 ,  3 ,  11 ,  5 ,  2 ,  12 ),
    
    ( *  S4  * )
    ( 7 ,  13 ,  14 ,  3 ,  0 ,  6 ,  9 ,  10 ,  1 ,  2 ,  8 ,  5 ,  11 ,  12 ,  4 ,  15 ,
     13 ,  8 ,  11 ,  5 ,  6 ,  15 ,  0 ,  3 ,  4 ,  7 ,  2 ,  12 ,  1 ,  10 ,  14 ,  9 ,
     10 ,  6 ,  9 ,  0 ,  12 ,  11 ,  7 ,  13 ,  15 ,  1 ,  3 ,  14 ,  5 ,  2 ,  8 ,  4 ,
     3 ,  15 ,  0 ,  6 ,  10 ,  1 ,  13 ,  8 ,  9 ,  4 ,  5 ,  11 ,  12 ,  7 ,  2 ,  14 ),

    ( *  S5  * )
    ( 2 ,  12 ,  4 ,  1 ,  7 ,  10 ,  11 ,  6 ,  8 ,  5 ,  3 ,  15 ,  13 ,  0 ,  14 ,  9 ,
     14 ,  11 ,  2 ,  12 ,  4 ,  7 ,  13 ,  1 ,  5 ,  0 ,  15 ,  10 ,  3 ,  9 ,  8 ,  6 ,
     4 ,  2 ,  1 ,  11 ,  10 ,  13 ,  7 ,  8 ,  15 ,  9 ,  12 ,  5 ,  6 ,  3 ,  0 ,  14 ,
     11 ,  8 ,  12 ,  7 ,  1 ,  14 ,  2 ,  13 ,  6 ,  15 ,  0 ,  9 ,  10 ,  4 ,  5 ,  3 ),
    
    ( *  S6  * )
    ( 12 ,  1 ,  10 ,  15 ,  9 ,  2 ,  6 ,  8 ,  0 ,  13 ,  3 ,  4 ,  14 ,  7 ,  5 ,  11 ,
     10 ,  15 ,  4 ,  2 ,  7 ,  12 ,  9 ,  5 ,  6 ,  1 ,  13 ,  14 ,  0 ,  11 ,  3 ,  8 ,
     9 ,  14 ,  15 ,  5 ,  2 ,  8 ,  12 ,  3 ,  7 ,  0 ,  4 ,  10 ,  1 ,  13 ,  11 ,  6 ,
     4 ,  3 ,  2 ,  12 ,  9 ,  5 ,  15 ,  10 ,  11 ,  14 ,  1 ,  7 ,  6 ,  0 ,  8 ,  13 ),
    
    ( *  S7  * )
    ( 4 ,  11 ,  2 ,  14 ,  15 ,  0 ,  8 ,  13 ,  3 ,  12 ,  9 ,  7 ,  5 ,  10 ,  6 ,  1 ,
     13 ,  0 ,  11 ,  7 ,  4 ,  9 ,  1 ,  10 ,  14 ,  3 ,  5 ,  12 ,  2 ,  15 ,  8 ,  6 ,
     1 ,  4 ,  11 ,  13 ,  12 ,  3 ,  7 ,  14 ,  10 ,  15 ,  6 ,  8 ,  0 ,  5 ,  9 ,  2 ,
     6 ,  11 ,  13 ,  8 ,  1 ,  4 ,  10 ,  7 ,  9 ,  5 ,  0 ,  15 ,  14 ,  2 ,  3 ,  12 ),
    
    ( *  S8  * )
    ( 13 ,  2 ,  8 ,  4 ,  6 ,  15 ,  11 ,  1 ,  10 ,  9 ,  3 ,  14 ,  5 ,  0 ,  12 ,  7 ,
     1 ,  15 ,  13 ,  8 ,  10 ,  3 ,  7 ,  4 ,  12 ,  5 ,  6 ,  11 ,  0 ,  14 ,  9 ,  2 ,
     7 ,  11 ,  4 ,  1 ,  9 ,  12 ,  14 ,  2 ,  0 ,  6 ,  10 ,  13 ,  15 ,  3 ,  5 ,  8 ,
     2 ,  1 ,  14 ,  7 ,  4 ,  10 ,  8 ,  13 ,  15 ,  12 ,  9 ,  0 ,  3 ,  5 ,  6 ,  11 )
);

( *  bit  0   is  left - most  in   byte   * )
bytebit: array [ 0 .. 7 ] of Integer  =
(
     0200 ,  0100 ,  040 ,  020 ,  010 ,  04 ,  02 ,  01
);

nibblebit : array [ 0 .. 3 ] of Integer  =
(
     010 ,  04 ,  02 ,  01
);

( *  initial permutation IP  * )
ip :array[ 0 .. 63 ] of Byte  =
(
     58 ,  50 ,  42 ,  34 ,  26 ,  18 ,  10 ,  2 ,
     60 ,  52 ,  44 ,  36 ,  28 ,  20 ,  12 ,  4 ,
     62 ,  54 ,  46 ,  38 ,  30 ,  22 ,  14 ,  6 ,
     64 ,  56 ,  48 ,  40 ,  32 ,  24 ,  16 ,  8 ,
     57 ,  49 ,  41 ,  33 ,  25 ,  17 ,  9 ,  1 ,
     59 ,  51 ,  43 ,  35 ,  27 ,  19 ,  11 ,  3 ,
     61 ,  53 ,  45 ,  37 ,  29 ,  21 ,  13 ,  5 ,
     63 ,  55 ,  47 ,  39 ,  31 ,  23 ,  15 ,  7
);

( *  final permutation IP ^- 1   * )
fp: array[ 0 .. 63 ] of Byte  =
(
     40 ,  8 ,  48 ,  16 ,  56 ,  24 ,  64 ,  32 ,
     39 ,  7 ,  47 ,  15 ,  55 ,  23 ,  63 ,  31 ,
     38 ,  6 ,  46 ,  14 ,  54 ,  22 ,  62 ,  30 ,
     37 ,  5 ,  45 ,  13 ,  53 ,  21 ,  61 ,  29 ,
     36 ,  4 ,  44 ,  12 ,  52 ,  20 ,  60 ,  28 ,
     35 ,  3 ,  43 ,  11 ,  51 ,  19 ,  59 ,  27 ,
     34 ,  2 ,  42 ,  10 ,  50 ,  18 ,  58 ,  26 ,
     33 ,  1 ,  41 ,  9 ,  49 ,  17 ,  57 ,  25
);

( *  permuted choice table (key)  * )
pc1: array[ 0 .. 55 ]of Byte  =
(
     57 ,  49 ,  41 ,  33 ,  25 ,  17 ,  9 ,
     1 ,  58 ,  50 ,  42 ,  34 ,  26 ,  18 ,
     10 ,  2 ,  59 ,  51 ,  43 ,  35 ,  27 ,
     19 ,  11 ,  3 ,  60 ,  52 ,  44 ,  36 ,

     63 ,  55 ,  47 ,  39 ,  31 ,  23 ,  15 ,
     7 ,  62 ,  54 ,  46 ,  38 ,  30 ,  22 ,
     14 ,  6 ,  61 ,  53 ,  45 ,  37 ,  29 ,
     21 ,  13 ,  5 ,  28 ,  20 ,  12 ,  4
);

( *  number left rotations of pc1  * )
totrot: array [ 0 .. 15 ] of Byte  =
(
     1 ,  2 ,  4 ,  6 ,  8 ,  10 ,  12 ,  14 ,  15 ,  17 ,  19 ,  21 ,  23 ,  25 ,  27 ,  28
);


( *  permuted choice key (table)  * )
 pc2:array[ 0 .. 47 ] of Byte  =
(
     14 ,  17 ,  11 ,  24 ,  1 ,  5 ,
     3 ,  28 ,  15 ,  6 ,  21 ,  10 ,
     23 ,  19 ,  12 ,  4 ,  26 ,  8 ,
     16 ,  7 ,  27 ,  20 ,  13 ,  2 ,
     41 ,  52 ,  31 ,  37 ,  47 ,  55 ,
     30 ,  40 ,  51 ,  45 ,  33 ,  48 ,
     44 ,  49 ,  39 ,  56 ,  34 ,  53 ,
     46 ,  42 ,  50 ,  36 ,  29 ,  32
);
// var
threadvar
( *  Lookup tables initialized once only at startup by desinit()  * )
  sp: array [ 0 .. 7 , 0 .. 63 ]  of LongWord; ( *  Combined S and P boxes  * )
  iperm: array [ 0 .. 15 , 0 .. 15 , 0 .. 7 ]  of Byte;( *  Initial and final permutations  * )
  fperm: array[ 0 .. 15 , 0 .. 15 , 0 .. 7 ]  of Byte;
  ( *   8   6 - bit subkeys  for  each of  16  rounds, initialized by dessetkey()  * )
  kn: array [ 0 .. 15 , 0 .. 7 ]  of Byte;
  desmode: Integer;
function desinit(mode: Integer):Integer;
function dessetkey( const  key:PByte): Integer;
procedure endes(block:PByte);
procedure dedes(block:PByte);
function spinit: Integer;( * static * )
procedure DES_round(num:Integer; block:PLongWord);( * static * )

implementation
... {$ifdef    LITTLE_ENDIAN}
( *  Byte swap a  long   * )
// function byteswap(x:LongWord):LongWord;
// var
//     cp,CP1:PChar;
//   tmp:Char;(*register*)
// begin
//     cp := PChar( @x);
//   Inc(cp,3);
//     tmp := cp^;
//   cp1 := cp;
//   Dec(cp,3);
//     cp1^ := cp^;
//     cp^ := tmp;
//
//   Dec(cp1);
//   Inc(cp);
//     tmp := cp1^;
//     cp1^ := cp^;
//     cp^ := tmp;
//
//     Result := x;
// end;
// {$else}
function byteswap(x:LongWord):LongWord;assembler;
asm
  bswap eax
end;
... {$endif}                 ( *  LITTLE_ENDIAN  * )

( *  Initialize the lookup table  for  the combined S and P boxes  * )
function spinit: Integer;
var
    pbox: array [ 0 .. 31 ] of Byte;
    p, i, s, j, rowcol: Integer;
    val: longInt;
begin
    ( *
     *  Compute pbox, the inverse of p32i. This  is  easier to work with
     * )
     for  p : =   0  to   32 - 1   do
    begin
         for  i : =   0  to  32 - 1   do
        begin
             if  (p32i[i]  -   1   =  p) then
            begin
                pbox[p] : =  i;
                 break ;
            end;
        end;
    end;
     for  s : =   0  to  8   -   1   do
    begin    ( *  For each S - box  * )
         for  i : =   0  to  64   -   1   do
        begin    ( *  For each possible input  * )
            val : =   0 ;
            ( *
             *  The row number  is  formed from the first and last bits; the
             *  column number  is  from the middle  4
             * )

             // rowcol := (i and 32) or ((i and 1) ? 16 : 0) or ((i shr 1) and $f);
       if  (i and  1 )  <>   0  then
        rowcol : =  (i and  32 ) or (  16  ) or ((i shr  1 ) and $f)
       else
        rowcol : =  (i and  32 ) or (  0 ) or ((i shr  1 ) and $f);

             for  j : =   0  to  4 - 1   do
            begin    ( *  For each output bit  * )
                 if  (si[s][rowcol] and ( 8  shr j))  <>   0  then
                begin
                    val : =  val or ( 1  shl ( 31   -  pbox[ 4   *  s  +  j]));
                end;
            end;
            sp[s][i] : =  val;
        end;
    end;
    Result : =   0 ;
end;

( *  The nonlinear function f(r,k), the heart of DES  * )
//     unsigned long    r;        /* 32 bits */
//     unsigned char    subkey[8];    /* 48-bit key for this round */
function f( r:LongWord; subkey:PByte):LongWord;( * static * )
var
     rval, rt:LongWord;( * register  * )
begin
    ( *
     *  Run E(R)  ^  K through the combined S  &  P boxes This code takes
     *  advantage of a convenient regularity  in  E, namely that each group of  6
     *  bits  in  E(R) feeding a single S - box  is  a contiguous segment of R.
     * )
     // rt := (r shr 1) or ((r and 1) ? $80000000 : 0);
   if  (r and  1 )  <>   0  then
    rt : =  (r shr  1 ) or $ 80000000
   else
    rt : =  (r shr  1 ) or  0 ;

    rval : =   0 ;
    rval : = rval or ( sp[ 0 ][((rt shr  26 ) xor subkey ^ ) and $3f]);
  Inc(subkey);
    rval : = rval or ( sp[ 1 ][((rt shr  22 ) xor subkey ^ ) and $3f]);
  Inc(subkey);
    rval : = rval or ( sp[ 2 ][((rt shr  18 ) xor subkey ^ ) and $3f]);
  Inc(subkey);
    rval : = rval or ( sp[ 3 ][((rt shr  14 ) xor subkey ^ ) and $3f]);
  Inc(subkey);
    rval : = rval or ( sp[ 4 ][((rt shr  10 ) xor subkey ^ ) and $3f]);
  Inc(subkey);
    rval : = rval or ( sp[ 5 ][((rt shr  6 ) xor subkey ^ ) and $3f]);
  Inc(subkey);
    rval : = rval or ( sp[ 6 ][((rt shr  2 ) xor subkey ^ ) and $3f]);
  Inc(subkey);
     // rt := (r shl 1) or ((r and $80000000) ? 1 : 0);
   if  (r and $ 80000000 ) <> 0  then
    rt : =  (r shl  1 ) or (  1  )
   else
    rt : =  (r shl  1 ) or ( 0 );
  
    rval : = rval or sp[ 7 ][(rt xor subkey ^ ) and $3f];
    
    result : =  rval;
end;

( *  Do one DES cipher round  * )
//     int             num;    /* i.e. the num-th one     */
//     unsigned long  *block;
procedure DES_round(num:Integer; block:PLongWord);( * static * )
var
  block1:PLongWord;
begin
     //     long            f();

    ( *
     *  The rounds are numbered from  0  to  15 . On even rounds the right half  is
     *  fed to f() and the result exclusive - ORs the left half; on odd rounds
     *  the reverse  is  done.
     * )
  block1 : =  block;
  Inc(block1);
     if  (num and  1 ) <>   0  then
    begin
        block1 ^  : = block1 ^  xor f(block ^ , @kn[num]);
    end
     else
    begin
        block ^  : = block ^  xor f(block1 ^ , @kn[num]);
    end;
end;

( *  Allocate space and initialize DES lookup arrays
*  mode  ==   0 : standard Data Encryption Algorithm
*  mode  ==   1 : DEA without initial and final permutations  for  speed
*  mode  ==   2 : DEA without permutations and with  128 - byte  key (completely
*               independent subkeys  for  each round)
* )
function desinit(mode: Integer):Integer;
procedure iperminit;

var
  l, j, k: Integer;( * register * )
    i, m: Integer;
begin
    ( *  Clear the permutation array  * )
     for  i : =   0  to  16   -   1   do
    begin
         for  j : =   0  to  16 - 1   do
        begin
             for  k : =   0  to  8 - 1   do
            begin
                iperm[i][j][k] : =   0 ;
            end;
        end;
    end;
    
     for  i : =   0  to  16 - 1   do     ( *  each input nibble position  * )
    begin
         for  j : =   0  to  16 - 1   do ( *  each possible input nibble  * )
        begin
             for  k : =   0  to  64 - 1   do
            begin    ( *  each output bit position  * )
                l : =  ip[k]  -   1 ;    ( *   where  does  this  bit come from  * )
                 if  ((l shr  2 )  <>  i)    then ( *  does it come from input posn ?   * )
                     continue ;    ( *   if  not, bit k  is   0       * )
                 if  ( 0   =  (j and nibblebit[l and  3 ])) then
                     continue ;    ( *  any such bit  in  input ?   * )
                m : =  k and  07 ; ( *  which bit  is   this   in  the  byte   * )
                iperm[i][j][k shr  3 ] : =  iperm[i][j][k shr  3 ] or bytebit[m];
            end;
    end;
    end;
end;

procedure fperminit;

var
  l, j, k: Integer;( * register * )
    i, m: Integer;
begin
    ( *  Clear the permutation array  * )
     for  i : =   0  to  16   -   1   do
    begin
         for  j : =   0  to  16 - 1   do
        begin
             for  k : =   0  to  8 - 1   do
            begin
                fperm[i][j][k] : =   0 ;
            end;
        end;
    end;
    
     for  i : =   0  to  16 - 1   do     ( *  each input nibble position  * )
    begin
         for  j : =   0  to  16 - 1   do ( *  each possible input nibble  * )
        begin
             for  k : =   0  to  64 - 1   do
            begin    ( *  each output bit position  * )
                l : =  fp[k]  -   1 ;    ( *   where  does  this  bit come from  * )
                 if  ((l shr  2 )  <>  i)    then ( *  does it come from input posn ?   * )
                     continue ;    ( *   if  not, bit k  is   0       * )
                 if  ( 0   =  (j and nibblebit[l and  3 ])) then
                     continue ;    ( *  any such bit  in  input ?   * )
                m : =  k and  07 ; ( *  which bit  is   this   in  the  byte   * )
                fperm[i][j][k shr  3 ] : =  fperm[i][j][k shr  3 ] or bytebit[m];
            end;
    end;
    end;
end;
begin
  Result : =   0 ;
    desmode : =  mode;
    spinit();
     if  (mode  =   1 ) or (mode  =   2 ) then( *  No permutations  * )
    Exit;
  iperminit;
  fperminit;
end;


( *  Set key (initialize key schedule array)  * )
//     char           *key;    /* 64 bits (will use only 56) */
function dessetkey( const  key:PByte): Integer;
var
    pc1m:array [ 0 .. 55 ] of Byte;    ( *  place to modify pc1 into  * )
    pcr: array [ 0 .. 55 ] of Byte;    ( *  place to rotate pc1 into  * )
    i, j, l:Integer;( * register * )
    M:integer;
  Key1:PByte;
begin
    ( *
     *  In mode  2 , the  128  bytes of subkey are  set  directly from the user ' s
     *  key, allowing him to use completely independent subkeys  for  each
     *  round. Note that the user MUST specify a full  128  bytes.
     *
     *  I would like to think that  this  technique gives the NSA a real headache,
     *  but I ' m not THAT naive.
     * )
  Result : =   - 1 ;
     if  (desmode  =   2 ) then
    begin
    Key1 : =  Key;
         for  i : =   0  to  16 - 1   do
        begin
             for  j : =   0  to  8 - 1   do
            begin
                kn[i][j] : =  key1 ^ ;
        Inc(Key1);
            end;
        end;
        Exit;
    end;
    ( *  Clear key schedule  * )
     for  i : =   0  to  16 - 1   do
    begin
         for  j : =   0  to  8 - 1   do
        begin
            kn[i][j] : =   0 ;
        end;
    end;
     for  j : =   0  to  56 - 1   do
    begin    ( *  convert pc1 to bits of key  * )
        l : =  pc1[j]  -   1 ;     ( *  integer bit location   * )
        m : =  l and  07 ;     ( *  find bit       * )
         // pc1m[j] := (key[l shr 3]  and (* find which key byte l is in *)
         //     bytebit[m])    (* and which bit of that byte *)
         //     ? 1 : 0;        (* and store 1-bit result *)
     if  (PByte(Integer(key) + (l shr  3 )) ^   and bytebit[m])  <>   0  then
      pc1m[j] : =   1
     else
      pc1m[j] : =   0 ;
    end;
     for  i : =   0  to  16 - 1   do
    begin    ( *  key chunk  for  each iteration  * )
         for  j : =   0  to  56 - 1   do ( *  rotate pc1 the right amount  * )
    begin
             // pcr[j] := pc1m[(l = j + totrot[i]) < (j < 28 ? 28 : 56) ? l : l - 28];
      l : =  j  +  totrot[I];
       if  J  <   28  then
        begin
           if  l  <   28  then
            begin
              pcr[j] : =  pc1m[l];
            end
           else
            begin
              pcr[j] : =  pc1m[l - 28 ];
            end;
        end
       else
        begin
           if  l  <   56  then
            begin
              pcr[j] : =  pc1m[l];
            end
           else
            begin
              pcr[j] : =  pc1m[l - 28 ];
            end;
        end;
    end;
        ( *  rotate left and right halves independently  * )
         for  j : =   0  to  48 - 1   do
        begin    ( *  select bits individually  * )
            ( *  check bit that goes to kn[j]  * )
             if  (pcr[pc2[j]  -   1 ]  <>   0 ) then
            begin
                ( *  mask it  in   if  it ' s there *)
                l : =  j mod  6 ;
                kn[i][j div  6 ] : = kn[i][j div  6 ] or (bytebit[l] shr  2 );
            end;
        end;
    end;
    Result : =   0 ;
end;

( *  In - place encryption of  64 - bit block  * )
procedure endes(block:PByte);
var
    i:Integer;( * register * )
    work:array [ 0 .. 1 ] of LongWord;    ( *  Working data storage  * )
    tmp:LongInt;
function Ipermute:Integer;( * static * )
var
    i, j:Integer;( * register * )
    ib,ob:PByte;( * register * )    ( *  ptr to input or output block  * )
  p, q:PByte;( * register * )
begin
  Result : =   0 ;
     if  (iperm[ 0 ][ 0 ][ 0 ]  =   0 ) then
    begin
        ( *  No permutation, just copy  * )
    ib : =  block;
    ob : =  PByte(@work[ 0 ]);
         for  i : =   8  downto  1   do
      begin
              ob ^ : =  ib ^ ;
        Inc(ib);
        Inc(ob);
      end;
        Exit;
    end;

    ( *  Clear output block      * )
  ob : =  PByte(@work[ 0 ]);
     for  i : =   8  downto  1   do
    begin
          ob ^  : =   0 ;
      Inc(ob);
    end;

    ib : =  block;
  J : =   0 ;
     while  j  <   16   do
    begin ( *   for  each input nibble  * )
        ob : =  PByte(@work[ 0 ]);
        p : =  @iperm[j][(ib ^  shr  4 ) and  017 ];
        q : =  @iperm[j  +   1 ][ib ^  and  017 ];
         for  i : =   8  downto  1   do
        begin    ( *  and each output  byte   * )
            ob ^  : = ob ^  or (p ^  or q ^ );    ( *  OR the masks together  * )
      inc(q);
      inc(p);
      Inc(ob);
        end;
    Inc(ib);
    Inc(J, 2 );
  end;
end;
function fpermute:Integer;( * static * )
var
    i, j:Integer;( * register * )
    ib,ob:PByte;( * register * )    ( *  ptr to input or output block  * )
  p, q:PByte;( * register * )
begin
  Result : =   0 ;
     if  (fperm[ 0 ][ 0 ][ 0 ]  =   0 ) then
    begin
        ( *  No permutation, just copy  * )
    ib : =  PByte(@work[ 0 ]);
    ob : =  block;
         for  i : =   8  downto  1   do
      begin
              ob ^ : =  ib ^ ;
        Inc(ib);
        Inc(ob);
      end;
        Exit;
    end;

    ( *  Clear output block      * )
  ob : =  block;
     for  i : =   8  downto  1   do
    begin
          ob ^  : =   0 ;
      Inc(ob);
    end;

    ib : =  PByte(@work[ 0 ]);
  j : =   0 ;
     while  j  <   16   do
    begin ( *   for  each input nibble  * )
        ob : =  block;
        p : =  @fperm[j][(ib ^  shr  4 ) and  017 ];
        q : =  @fperm[j  +   1 ][ib ^  and  017 ];
         for  i : =   8  downto  1   do
        begin    ( *  and each output  byte   * )
            ob ^  : = ob ^  or (p ^  or q ^ );    ( *  OR the masks together  * )
      inc(q);
      inc(p);
      Inc(ob);
        end;
    Inc(ib);
    Inc(J, 2 );
  end;
end;
begin
  Ipermute; ( *  Initial Permutation  * )

... {$ifdef LITTLE_ENDIAN}
    work[ 0 ] : =  byteswap(work[ 0 ]);
    work[ 1 ] : =  byteswap(work[ 1 ]);
... {$endif}                 ( *  LITTLE_ENDIAN  * )

    ( *  Do the  16  rounds  * )
     for  i : =   0  to  16 - 1   do
        DES_round(i, @work[ 0 ]);

    ( *  Left / right half swap  * )
    tmp : =  work[ 0 ];
    work[ 0 ] : =  work[ 1 ];
    work[ 1 ] : =  tmp;

... {$ifdef LITTLE_ENDIAN}
    work[ 0 ] : =  byteswap(work[ 0 ]);
    work[ 1 ] : =  byteswap(work[ 1 ]);
... {$endif}                 ( *  LITTLE_ENDIAN  * )

  fpermute;  ( *  Inverse initial  *  permutation  * )
end;

( *  In - place decryption of  64 - bit block  * )
procedure dedes(block:PByte);
var
    I: Integer;( * register * )
    work: array [ 0 .. 1 ] of LongWord;    ( *  Working data storage  * )
    tmp:LongInt;
function Ipermute:Integer;( * static * )
var
    i, j:Integer;( * register * )
    ib,ob:PByte;( * register * )    ( *  ptr to input or output block  * )
  p, q:PByte;( * register * )
begin
  Result : =   0 ;
     if  (iperm[ 0 ][ 0 ][ 0 ]  =   0 ) then
    begin
        ( *  No permutation, just copy  * )
    ib : =  block;
    ob : =  PByte(@work[ 0 ]);
         for  i : =   8  downto  1   do
      begin
              ob ^ : =  ib ^ ;
        Inc(ib);
        Inc(ob);
      end;
        Exit;
    end;

    ( *  Clear output block      * )
  ob : =  PByte(@work[ 0 ]);
     for  i : =   8  downto  1   do
    begin
          ob ^  : =   0 ;
      Inc(ob);
    end;

    ib : =  block;
  J : =   0 ;
     while  j  <   16   do
    begin ( *   for  each input nibble  * )
        ob : =  PByte(@work[ 0 ]);
        p : =  @iperm[j][(ib ^  shr  4 ) and  017 ];
        q : =  @iperm[j  +   1 ][ib ^  and  017 ];
         for  i : =   8  downto  1   do
        begin    ( *  and each output  byte   * )
            ob ^  : = ob ^  or (p ^  or q ^ );    ( *  OR the masks together  * )
      inc(q);
      inc(p);
      Inc(ob);
        end;
    Inc(ib);
    Inc(J, 2 );
  end;
end;
function Fpermute:Integer;( * static * )
var
    i, j:Integer;( * register * )
    ib,ob:PByte;( * register * )    ( *  ptr to input or output block  * )
  p, q:PByte;( * register * )
begin
  Result : =   0 ;
     if  (fperm[ 0 ][ 0 ][ 0 ]  =   0 ) then
    begin
        ( *  No permutation, just copy  * )
    ib : =  PByte(@work[ 0 ]);
    ob : =  block;
         for  i : =   8  downto  1   do
      begin
              ob ^ : =  ib ^ ;
        Inc(ib);
        Inc(ob);
      end;
        Exit;
    end;

    ( *  Clear output block      * )
  ob : =  block;
     for  i : =   8  downto  1   do
    begin
          ob ^  : =   0 ;
      Inc(ob);
    end;

    ib : =  PByte(@work[ 0 ]);
  J : =   0 ;
     while  j  <   16   do
    begin ( *   for  each input nibble  * )
        ob : =  block;
        p : =  @fperm[j][(ib ^  shr  4 ) and  017 ];
        q : =  @fperm[j  +   1 ][ib ^  and  017 ];
         for  i : =   8  downto  1   do
        begin    ( *  and each output  byte   * )
            ob ^  : = ob ^  or (p ^  or q ^ );    ( *  OR the masks together  * )
      inc(q);
      inc(p);
      Inc(ob);
        end;
    Inc(ib);
    Inc(J, 2 );
  end;
end;
begin
  Ipermute;  ( *  Initial permutation  * )

... {$ifdef LITTLE_ENDIAN}
    work[ 0 ] : =  byteswap(work[ 0 ]);
    work[ 1 ] : =  byteswap(work[ 1 ]);
... {$endif}                 ( *  LITTLE_ENDIAN  * )

    ( *  Left / right half swap  * )
    tmp : =  work[ 0 ];
    work[ 0 ] : =  work[ 1 ];
    work[ 1 ] : =  tmp;

    ( *  Do the  16  rounds  in  reverse order  * )
     for  i : =   15  downto  0   do
        DES_round(i, @work[ 0 ]);

... {$ifdef LITTLE_ENDIAN}
    work[ 0 ] : =  byteswap(work[ 0 ]);
    work[ 1 ] : =  byteswap(work[ 1 ]);
... {$endif}                 ( *  LITTLE_ENDIAN  * )

  Fpermute;  ( *  Inverse initial  *  permutation  * )
end;

end.

uses
  UnitDES;
procedure TForm1.btnTestClick(Sender: TObject);
var
  sIn,sOutHex,sKey:String;
  NewLen,I: Integer;
  block :PByte;
  P,P1:PChar;
  B,B1:Byte;
begin
  sIn : =   ' 测试字符串 ' ;
  sKey : =   ' 这是密钥 ' ;

  desinit( 0 );

  I : =  Length(sKey);
  SetLength(sKey, 8 );  // 调整密钥为8位
   if  I  <   8  then
     // 填充密钥
    FillChar(PChar(Integer(PChar(sKey)) + I) ^ , 8 - I, 100 );

  I : =  Length(sIn);
   if  (I mod  8  ) <> 0  then
    begin
       // 调整串长为8的倍数
      NewLen : =  ((I div  8 )  +   1 )  *   8 ;
      SetLength(sIn,NewLen);
       // 置串结束符(这里是串加密
      PChar(Integer(PChar(sIn)) + I) ^  : =  # 0 ;
    end;

   // 初始化密钥
  dessetkey(PByte(PChar(sKey)));

  block : =  Pointer(sIn);
  NewLen : =  Length(sIn);
   while ( NewLen  >   0  )  do
    begin
       // 加密
      endes( PByte(block));
      Dec(NewLen, 8 );
      Inc(block, 8 );
    end;

   // 十六进制转换
  SetString(sOutHex,Nil,Length(sIn)  *   2 );
  P : =  PChar(sIn);
  P1 : =  PChar(sOutHex);
   for  I : =   0  to Length(sIn)  -   1   do
    begin
      B : =  Byte(P ^ );
      B1 : =  ((B shr  4 ) and $f);
       case  B1 of
         0 .. 9 :
          P1 ^  : =  Chr(B1  +   48 )
         else
          P1 ^  : =  Chr(B1  +   65   -   10 );
      end;

      Inc(P1);
      B1 : =  (B  and $f);

       case  B1 of
         0 .. 9 :
          P1 ^  : =  Chr(B1  +   48 )
         else
          P1 ^  : =  Chr(B1  +   65   -   10 );
      end;

      Inc(P1);
      Inc(P);
    end;

  ShowMessage(sOutHex);

   // 初始化密钥
  dessetkey(PByte(PChar(sKey)));

  NewLen : =  Length(sIn);
  block : =  Pointer(sIn);
   while ( NewLen  >   0  )  do
    begin
       // 解密
      dedes(PByte(block));
      Dec(NewLen,  8 );
      Inc(block,  8 );
    end;
  SetLength(sIn,strlen(PChar(sIn)));

  ShowMessage(sIn);
end;