{ ****************************************************************** }
{                                                                    }
{   VCL component TDESCrypt                                          }
{                                                                    }
{   Code generated by Component Create for Delphi                    }
{                                                                    }
{   Generated from untitled component definition                     }
{   on 30 Oct 1997 at 12:51                                          }
{   Copyright © 1997 by S.Herzog,email: s.herzog@netlab-center.ch for}
{   udescrypt.pas                                                    }
{                                                                    }
{   PLEASE NOTICE THAT I DO NOT TAKE ANY WARRANTY OF SAVETY FOR THE  }
{   TRANSLATION FROM THE GNU C-LIBRARY TO DELPHI !!                  }
{   IF YOU FIND SOME BUG OR MAKE ANY CODE CHANGES, THEN SEND ME PLEASE}
{   A COPY.                                                          }
{   HAVE FUN WITH THE DELPHI !!! :)                                  }
{   Last changes : 12.Nov 97  - initialize the propertys             }
{                             - set the property length              }
{                               Input lenght 8 chars                 }
{                               Output lenght 8 chars                }
{                               Salt length 2 chars                  }
{                  14.Nov 97  - found some bugs about the            }
{                               string length of the properties      }
{                  18.Nov 97  - another string length problem        }
{   Angus - 9 June 2002 - removed forms, etc                         }
{   Angus Oct 2022 warnings off, too many signed/unsigned            }
{ ****************************************************************** }

unit UDESCryp;

interface

uses {Windows, Messages,} SysUtils, Classes {, Controls, Forms, Graphics } ;

{$WARNINGS OFF}

type
  TDESCrypt = class(TComponent)
    private
      { Private fields of TDESCrypt }
        FInput : String;
        FOutput : String;
        FSalt : String;

      { Private methods of TDESCrypt }
        { Method to set variable and property values and create objects }
        procedure AutoInitialize;
        { Method to free any objects created by AutoInitialize }
        procedure AutoDestroy;

    protected
      { Protected fields of TDESCrypt }

      { Protected methods of TDESCrypt }
        procedure Loaded; override;
        procedure setInput(_s:string);
        procedure setSalt(_s:string);
    public
      { Public fields and properties of TDESCrypt }

      { Public methods of TDESCrypt }
        constructor Create(AOwner: TComponent); override;
        destructor Destroy; override;
        function Execute : Boolean;

    published
      { Published properties of TDESCrypt }
       { property OnError;}
        { The input string which will be crypted }
        property Input : String read FInput write setInput;
        { This is the DES crypted output }
        property Output : String read FOutput;
        { The cook need some salt for a good meal }
        property Salt : String read FSalt write SetSalt;

  end;

procedure Register;

implementation



{*
 * UFC-crypt: ultra fast crypt(3) implementation
 * Copyright (C) 1991, 1992, Michael Glad, email: glad@daimi.aau.dk         for crypt.c
 *
 * This library is free software; you can redistribute it and/or
 * modify it under the terms of the GNU Library General Public
 * License as published by the Free Software Foundation; either
 * version 2 of the License, or (at your option) any later version.
 *
 * This library is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 * Library General Public License for more details.
 *
 * You should have received a copy of the GNU Library General Public
 * License along with this library; if not, write to the Free
 * Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 *
 * @(#)crypt_util.c	2.29 01/23/92
 *
 * Support routines
 *
 *}





type
st15=String[15];
st10=string[10];
pword=^word;
pCardinal=^Cardinal;
pLongint=^Longint;
TAry=array[0..1] of Longint;
Tusb=array[0..8191] of Longint;
pUsb=^Tusb;
var
eperm32tab:array[0..3,0..255,0..1] of Longint;

pc1:array[0..55] of integer = (
  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
);

rots:array[0..15] of integer = (1, 1, 2, 2, 2, 2, 2, 2, 1, 2, 2, 2, 2, 2, 2, 1);

pc2:array[0..47]of integer = (
  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
);

esel:array[0..47]of integer = (
  32,  1,  2,  3,  4,  5,  4,  5,  6,  7,  8,  9,
   8,  9, 10, 11, 12, 13, 12, 13, 14, 15, 16, 17,
  16, 17, 18, 19, 20, 21, 20, 21, 22, 23, 24, 25,
  24, 25, 26, 27, 28, 29, 28, 29, 30, 31, 32,  1
);

e_inverse:array[0..63] of integer;
perm32:array[0..31] of integer = (
  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
);
sbox:array[0..7,0..3,0..15]of integer = (
        ( ( 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 )
        ),

        ( ( 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 )
        ),

        ( ( 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 )
        ),

        ( (  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 )
        ),

        ( (  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 )
        ),

        ( ( 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 )
        ),

        ( (  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 )
        ),

        ( ( 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 )
        )
);

initial_perm:array[0..63] of integer = (
  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_perm:array[0..63] of integer = (
  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
);

{* The 16 DES keys in BITMASK format}
ufc_keytab:array[0..15,0..1] of Longint;


{
 * sb arrays:
 *
 * Workhorses of the inner loop of the DES implementation.
 * They do sbox lookup, shifting of this  value, 32 bit
 * permutation and E permutation for the next round.
 *
 * Kept in 'BITMASK' format.
 }

ufc_sb0:Tusb;
ufc_sb1:Tusb;
ufc_sb2:Tusb;
ufc_sb3:Tusb;
sb:array[0..3] of Pusb;
{static unsigned long *sb[4] = (ufc_sb0, ufc_sb1, ufc_sb2, ufc_sb3);}
do_pc1:array[0..7,0..1,0..127] of Longint;
do_pc2:array[0..7,0..127] of Longint;
efp:array[0..15,0..63,0..1] of Longint;
bytemask:array[0..7]of byte  = ($80, $40, $20, $10, $08, $04, $02, $01);
longmask:array[0..31] of cardinal = (               // June 2021 
  $80000000, $40000000, $20000000, $10000000,
  $08000000, $04000000, $02000000, $01000000,
  $00800000, $00400000, $00200000, $00100000,
  $00080000, $00040000, $00020000, $00010000,
  $00008000, $00004000, $00002000, $00001000,
  $00000800, $00000400, $00000200, $00000100,
  $00000080, $00000040, $00000020, $00000010,
  $00000008, $00000004, $00000002, $00000001
);

initialized,direction:integer;
current_saltbits:Longint;
current_salt:array[0..2] of char='&&';

function ascii_to_bin(c:char):byte;
begin
   if (c>='a') then c:=char(byte(c)-59)
     else
     if (c>='A') then C:=char(byte(c)-53) else c:=char(byte(c)-byte('.'));
   ascii_to_bin:=byte(c);
end;


function bin_to_ascii(c:byte):char;
var
ch:char;
begin
  if (c>=38) then ch:=char((c-38+byte('a')))
    else
    if c>=12 then ch:=char(c-12+byte('A')) else ch:=char(c+byte('.'));
  bin_to_ascii:=ch;
end;

function s_lookup(i,s:integer):integer;
begin
 s_lookup:=sbox[i,((s shr 4) and $2) or (s and $1),(s shr 1) and $f];
end;

function get_value(_seg:PLongint;_ofs:Longint):longint;
var
temp:Plongint;
v:longint;
begin
  temp:=_seg;
  inc(temp,_ofs);
  v:=temp^;
  get_value:=v;
end;

procedure clearmem(mem:pword;len:Cardinal);
var
i:longint;
begin
  for i:=0 to (len div 2)-1 do
  begin
    mem^:=0;
    inc(mem);
  end;
end;


function bitmask(i:Longint):Longint;
var
m:longint;
begin
  if i<12 then m:=16 else m:=0;
  bitmask:=1 shl(11-(i mod 12)+3) shl m;
end;

function SBA(_sb:pLongint;_ofs:Longint):Longint;
var
v:Longint;
temp:pLongint;
begin
  temp:=_sb;
  inc(temp,_ofs div 4);
  v:=temp^;
  sba:=v;
end;


{ 28.10.97}
procedure init_des;
var
comes_from_bit:Longint;
bit, sg:Longint;
j:Longint;
mask1, mask2,temp:Longint; { !!!!!!! achtung typ ?}
mask11,comes_from1:Longint;
j1, j2,s1, s2:Longint;
to_permute, inx:Longint;
o_bit, o_long:Longint;
word_value:Longint;
mask12, mask22:Longint;
comes_from_f_bit, comes_from_e_bit:Longint;
comes_from_word, bit_within_word:Longint;
begin
  {*
   * Create the do_pc1 table used
   * to affect pc1 permutation
   * when generating keys
   *}
  for bit:=0 to 55 do
  begin
    comes_from_bit:= pc1[bit] - 1;
    mask1:= bytemask[comes_from_bit mod 8 + 1];
    mask2:= longmask[bit mod 28 + 4];
    for j:=0 to 127 do
    begin
      if (j and mask1)>0 then
      begin
        temp:=do_pc1[comes_from_bit div 8,bit div 28,j];
        temp:=temp or mask2;
        do_pc1[comes_from_bit div 8,bit div 28,j]:=temp;
      end;
    end;
  end;

  {*
   * Create the do_pc2 table used
   * to affect pc2 permutation when
   * generating keys
   *}
  for bit:=0 to 47 do
  begin
    comes_from_bit:= pc2[bit] - 1;
    mask1:= bytemask[comes_from_bit mod 7 + 1];
    mask2:= BITMASK(bit mod 24);
    for j:=0 to 127 do
    begin
      if (j and mask1)>0 then
      begin
        temp:=do_pc2[comes_from_bit div 7,j];
        temp:=temp or mask2;
        do_pc2[comes_from_bit div 7][j]:=temp;
      end;
    end;
  end;

  {*
   * Now generate the table used to do combined
   * 32 bit permutation and e expansion
   *
   * We use it because we have to permute 16384 32 bit
   * longs into 48 bit in order to initialize sb.
   *
   * Looping 48 rounds per permutation becomes
   * just too slow...
   *
   *}
  clearmem(@eperm32tab,sizeof(eperm32tab));
  for bit:=0 to 47 do
  begin
    comes_from1:=perm32[esel[bit]-1]-1;
    mask11:= bytemask[comes_from1 mod 8];
    for j:=255 downto 0 do
    begin
      if (j and mask11)>0 then
      begin
        temp:=eperm32tab[comes_from1 div 8,j,bit div 24];
        temp:=temp or BITMASK(bit mod 24);
        eperm32tab[comes_from1 div 8,j,bit div 24]:=temp;
      end;
    end;
  end;

  {*
   * Create the sb tables:
   *
   * For each 12 bit segment of an 48 bit intermediate
   * result, the sb table precomputes the two 4 bit
   * values of the sbox lookups done with the two 6
   * bit halves, shifts them to their proper place,
   * sends them through perm32 and finally E expands
   * them so that they are ready for the next
   * DES round.
   *
   *}
  for sg:=0 to 3 do
  begin
    for j1:=0 to 63 do
    begin
      s1:= s_lookup(2 * sg, j1);
      for j2:=0 to 63 do
      begin
        s2:= s_lookup(2 * sg + 1, j2);
        to_permute:= ((s1 shl 4)  or s2) shl (24 - 8 * sg);
        inx:= ((j1 shl 6)  or j2) shl 1;
        sb[sg,inx ]:= eperm32tab[0,(to_permute shr 24) and $ff,0];
        sb[sg,inx+1]:= eperm32tab[0,(to_permute shr 24) and $ff,1];
        sb[sg,inx  ]:= sb[sg,inx  ] or eperm32tab[1,(to_permute shr 16) and $ff,0];
        sb[sg,inx+1]:= sb[sg,inx+1] or eperm32tab[1,(to_permute shr 16) and $ff,1];
        sb[sg,inx  ]:= sb[sg,inx  ] or eperm32tab[2,(to_permute shr  8) and $ff,0];
        sb[sg,inx+1]:= sb[sg,inx+1] or eperm32tab[2,(to_permute shr  8) and $ff,1];
        sb[sg,inx  ]:= sb[sg,inx  ] or eperm32tab[3,(to_permute)       and $ff,0];
        sb[sg,inx+1]:= sb[sg,inx+1] or eperm32tab[3,(to_permute)       and $ff,1];
      end;
    end;
  end;

  {*
   * Create an inverse matrix for esel telling
   * where to plug out bits if undoing it
   *}
  for bit:=48 downto 0 do
  begin
    e_inverse[esel[bit] - 1     ]:= bit;
    e_inverse[esel[bit] - 1 + 32]:= bit + 48;
  end;

  {*
   * create efp: the matrix used to
   * undo the E expansion and effect final permutation
   *}
  clearmem(@efp[0,0,0],sizeof(efp));
  for bit:=0 to 63 do
  begin

    {* See where bit i belongs in the two 32 bit long's *}
    o_long:= bit div 32; {* 0..1  *}
    o_bit := bit mod 32; {* 0..31 *}

    {*
     * And find a bit in the e permutated value setting this bit.
     *
     * Note: the e selection may have selected the same bit several
     * times. By the initialization of e_inverse, we only look
     * for one specific instance.
     *}
    comes_from_f_bit:= final_perm[bit] - 1;          { 0..63 }
    comes_from_e_bit:= e_inverse[comes_from_f_bit];  { 0..95 }
    comes_from_word:= comes_from_e_bit div 6;        { 0..15 }
    bit_within_word:= comes_from_e_bit mod 6;        { 0..5  }
    mask12:= longmask[bit_within_word + 26];
    mask22:= longmask[o_bit];

    for word_value:= 63 downto 1 do
    begin
      if word_value and mask12>0 then
      begin
        temp:= efp[comes_from_word,word_value,o_long];
        temp:=temp or mask22;
        efp[comes_from_word,word_value,o_long]:=temp;
      end;
    end;
  end;
  inc(initialized);
end;

{
 * Process the elements of the sb table permuting the
 * bits swapped in the expansion by the current salt.
 }

{ 28.10.97}
procedure shuffle_sb(k:PLongint;saltbits:longint);
var
j:word;
x:Longint;
temp:PLongint;
k0,k1:Longint;
begin
  for j:=4096 downto 1 do
  begin
    k0:=k^;
    temp:=k;
    inc(k);
    k1:=k^;
    k:=temp;
    x:= (k0 xor k1) and longint(saltbits);
    k^:=k^ xor x;inc(k);
    k^:=k^ xor x;inc(k);
  end;
end;


{ 28.10.97}
procedure ufc_mk_keytab(key:pChar);
var
v1,v2:Longint;
k1:PLongint;
i:integer;
v:Longint;
k2:PLongint;
begin
  k2:= @ufc_keytab[0,0];
  v1:=0;
  v2:=0;
  k1:=@do_pc1[0,0,0];
  for i:=8 downto 0 do
  begin
    v1:=v1 or  get_value(k1,(byte(key^) and $7f));inc(k1,128);
    v2:=v2 or  get_value(k1,(byte(key^) and $7f));inc(key);inc(k1,128);
  end;
  for i:=0 to 15 do
  begin
    k1:=@do_pc2[0,0];
    v1:=(v1 shl rots[i]) or (v1 shr (28 - rots[i]));
    v:= get_value(k1,(v1 shr 21) and $7f); inc(k1,128);
    v:=v or get_value(k1,(v1 shr 14) and $7f);inc(k1,128);
    v:=v or get_value(k1,(v1 shr  7) and $7f);inc(k1,128);
    v:=v or get_value(k1,(v1      ) and $7f);inc(k1,128);
    k2^:=v;inc(k2);
    v:=0;
    v2:= (v2 shl rots[i]) or (v2 shr (28 - rots[i]));
    v:=v or get_value(k1,(v2 shr 21) and $7f);inc(k1,128);
    v:=v or get_value(k1,(v2 shr 14) and $7f);inc(k1,128);
    v:=v or get_value(k1,(v2 shr  7) and $7f);inc(k1,128);
    v:=v or get_value(k1,(v2      )  and $7f);
    k2^:= v;inc(k2);
  end;
  direction:= 0;
end;

{ 28.10.97}
procedure setup_salt(var s:string);
var
i, j, saltbits:Longint;
c:longint;
begin

  if initialized=0 then init_des;
  if(s[1]=current_salt[0]) and (s[2]=current_salt[1]) then exit;
  current_salt[0]:= s[1]; current_salt[1]:= s[2];
  {*
   * This is the only crypt change to DES:
   * entries are swapped in the expansion table
   * according to the bits set in the salt.
   *}
  saltbits:= 0;
  for i:=1 to 2 do
  begin
    c:=ascii_to_bin(s[i]);
    if (c<0) or (c>63) then c:= 0;
    for j:=0 to 5 do
      if((c shr j) and $1)>0 then saltbits:=saltbits or BITMASK(6 * (i-1) + j);
  end;
  {*
   * Permute the sb table values
   * to reflect the changed e
   * selection table
   *}
  shuffle_sb(@sb[0,0], current_saltbits xor saltbits);
  shuffle_sb(@sb[1,0], current_saltbits xor saltbits);
  shuffle_sb(@sb[2,0], current_saltbits xor saltbits);
  shuffle_sb(@sb[3,0], current_saltbits xor saltbits);
  current_saltbits:= saltbits;
end;


function ufc_dofinalperm(l1,l2,r1,r2:Longint):pLongint;
var
ary:Tary;
v1,v2,x:Longint;
begin
  x:=(l1 xor l2) and current_saltbits;
  l1:=l1 xor x;
  l2:=l2 xor x;
  x:=(r1 xor r2) and current_saltbits;
  r1:=r1 xor x;
  r2:=r2 xor x;
  v1:=0;v2:=0;
  l1:=l1 shr 3;
  l2:=l2 shr 3;
  r1:=r1 shr 3;
  r2:=r2 shr 3;
  v1 := v1 or efp[15,r2 and $3f,0];              v2:=v2 or efp[15, r2 and $3f,1];
  r2:=r2 shr 6 ;
  v1 := v1 or efp[14,r2 and $3f,0];v2:=v2 or efp[14, r2 and $3f,1];
  r2:=r2 shr 10;
  v1 := v1 or efp[13,r2 and $3f,0];v2:=v2 or efp[13, r2 and $3f,1];
  r2:=r2 shr 6;
  v1 := v1 or efp[12,r2 and $3f,0]; v2:=v2 or efp[12, r2 and $3f,1];
  v1 := v1 or efp[11,r1 and $3f,0];              v2:=v2 or efp[11, r1 and $3f,1];
  r1:=r1 shr 6;
  v1 := v1 or efp[10,r1 and $3f,0]; v2:=v2 or efp[10, r1 and $3f,1];
  r1:=r1 shr 10;
  v1 := v1 or efp[ 9,r1 and $3f,0];v2:=v2 or efp[ 9, r1 and $3f,1];
  r1:=r1 shr 6 ;
  v1 := v1 or efp[ 8,r1 and $3f,0];v2:=v2 or efp[ 8, r1 and $3f,1];
  v1 := v1 or efp[ 7,l2 and $3f,0];              v2:=v2 or efp[ 7, l2 and $3f,1];
  l2:=l2 shr 6 ;
  v1 := v1 or efp[ 6,l2 and $3f,0];v2:=v2 or efp[ 6, l2 and $3f,1];
  l2:=l2 shr 10;
  v1 := v1 or efp[ 5,l2 and $3f,0];v2:=v2 or efp[ 5, l2 and $3f,1];
  l2:=l2 shr 6 ;
  v1 := v1 or efp[ 4,l2 and $3f,0];v2:=v2 or efp[ 4, l2 and $3f,1];
  v1 := v1 or efp[ 3,l1 and $3f,0];              v2:=v2 or efp[ 3, l1 and $3f,1];
  l1:=l1 shr 6 ;
  v1 := v1 or efp[ 2,l1 and $3f,0];v2:=v2 or efp[ 2, l1 and $3f,1];
  l1:=l1 shr 10;
  v1 := v1 or efp[ 1,l1 and $3f,0];v2:=v2 or efp[ 1, l1 and $3f,1];
  l1:=l1 shr 6 ;
  v1 := v1 or efp[ 0,l1 and $3f,0];v2:=v2 or efp[ 0, l1 and $3f,1];
  ary[0]:=v1;
  ary[1]:= v2;
  ufc_dofinalperm:=@ary[0];
end;

{
 * crypt only: convert from 64 bit to 11 bit ASCII
 * prefixing with the salt
 }

function output_conversion(v1,v2:Cardinal;salt:pChar):string;
var
outbuf:array[0..13] of char;
temp_string:string;
i, s:integer;
begin
  outbuf[0] := salt[0];
  outbuf[1] := salt[1];
  if salt[1]<>'' then  Outbuf[1]:=salt[1]  else Outbuf[1]:=salt[0];
  for i:= 0 to 4 do outbuf[i + 2] := bin_to_ascii((v1 shr (26 - 6 * i)) and $3f);
  s  := (v2 and $f) shl 2;
  v2 := (v2 shr 2) or ((v1 and $3) shl 30);
  for i:= 5 to 9 do outbuf[i + 2]:= bin_to_ascii((v2 shr (56 - 6 * i)) and $3f);
  outbuf[12] := bin_to_ascii(s);
  outbuf[13] := #0;
  temp_string:='                ';
  for i:=0 to 12 do
  begin
    temp_string[i+1]:=outbuf[i];
  end;
  setlength(temp_string,13);
  output_conversion:=temp_string;
end;


{29.10.97}
function ufc_doit(l1, l2, r1, r2, itr:Cardinal):pLongint;
var
i:integer;
s:Longint;
k:pLongint;
begin
  while(itr>=1) do
  begin
    k:=@ufc_keytab[0,0];
    for i:=8 downto 1 do
    begin
      s  :=k^ xor r1;inc(k);
      l1 :=l1 xor SBA(@ufc_sb1[0],s and $ffff);  l2 :=l2 xor SBA(@ufc_sb1[0], (s and $ffff) + 4);
      s  :=s  shr 16;
      l1 :=l1 xor SBA(@ufc_sb0[0], s );          l2 :=l2 xor SBA(@ufc_sb0[0], (s)          + 4);  { !!!!!!}
      s  :=k^ xor r2;inc(k);
      l1 :=l1 xor SBA(@ufc_sb3[0], s and $ffff); l2 :=l2 xor sbA(@ufc_sb3[0], (s and $ffff) + 4);
      s  :=s  shr 16;
      l1 :=l1 xor sbA(@ufc_sb2[0], s);           l2 :=l2 xor sbA(@ufc_sb2[0], (s)          + 4);  { !!!!!!}
      s  :=k^ xor l1;inc(k);
      r1 :=r1 xor sbA(@ufc_sb1[0], s and $ffff); r2 :=r2 xor sbA(@ufc_sb1[0], (s and $ffff) + 4);
      s  :=s  shr 16;
      r1 :=r1 xor sbA(@ufc_sb0[0], s);           r2 :=r2 xor sbA(@ufc_sb0[0], (s)          + 4);  { !!!!!!}
      s  :=k^ xor l2;inc(k);
      r1 :=r1 xor sbA(@ufc_sb3[0], s and $ffff); r2 :=r2 xor sbA(@ufc_sb3[0], (s and $ffff) + 4);
      s  :=s  shr 16;
      r1 :=r1 xor sbA(@ufc_sb2[0], s);           r2 :=r2 xor sbA(@ufc_sb2[0], (s)          + 4);  { !!!!!!}
    end;
    s:=l1; l1:=r1; r1:=s; s:=l2; l2:=r2; r2:=s;
    dec(itr);
  end;
  ufc_doit:=ufc_dofinalperm(l1, l2, r1, r2);
end;



function des_crypt(var _key:string;_salt:string):string;
var
s:pLongint;
s1,s2:Longint;
ktab:array[0..10] of char;
i:integer;
begin
  setup_salt(_salt);
  clearmem(@ktab,sizeof(ktab));
  for i:=0 to length(_key)-1 do ktab[i]:=_key[i+1];
  ufc_mk_keytab(ktab);
  s:= ufc_doit(0,0,0,0,25);
  s1:=s^;
  inc(s);
  s2:=s^;
  des_crypt:=output_conversion(s1, s2, @_salt[1]);
end;
{
 * Setup the unit for a new salt
 * Hopefully we'll not see a new salt in each crypt call.
 }




procedure Register;
begin
     { Register TDESCrypt with Netlab as its    // angus changed to samples
       default page on the Delphi component palette }
     RegisterComponents('Samples', [TDESCrypt]);
end;


procedure TDESCrypt.setInput(_s:string);
begin
  if length(_s)>8 then setlength(_s,8);
  FInput:=_s;
end;

procedure TDESCrypt.setSalt(_s:string);
begin
  if length(_s)>8 then setlength(_s,8);
  FSalt:=_s;
end;

{ Method to set variable and property values and create objects }
procedure TDESCrypt.AutoInitialize;
begin
  FInput:='';
  FOutput:='';
  FSalt:='';
end; { of AutoInitialize }

{ Method to free any objects created by AutoInitialize }
procedure TDESCrypt.AutoDestroy;
begin
     { No objects from AutoInitialize to free }
end; { of AutoDestroy }

constructor TDESCrypt.Create(AOwner: TComponent);
begin
     inherited Create(AOwner);
     AutoInitialize;

     { Code to perform other tasks when the component is created }

end;

destructor TDESCrypt.Destroy;
begin
     AutoDestroy;
     inherited Destroy;
end;

procedure TDESCrypt.Loaded;
begin
     inherited Loaded;

     { Perform any component setup that depends on the property
       values having been set }

end;

function TDESCrypt.Execute : Boolean;
begin
     { Perform the component operation }
     if FInput<>'' then
     Foutput:=des_crypt(Finput,FSalt)
     else
     FOutput:='';
     { Return True if the operation was successful, False otherwise }
     Result := True;
end;

begin
  current_salt:='&&'; { invalid value }
  current_saltbits:= 0;
  direction:= 0;
  initialized:= 0;
  sb[0]:=@ufc_sb0[0];
  sb[1]:=@ufc_sb1[0];
  sb[2]:=@ufc_sb2[0];
  sb[3]:=@ufc_sb3[0];
end.