//聲明:這個是在網上下載下來之後,加入了UNICODE的處理部份
//在D7和D2010中測試通過
unit U_DES;

interface
uses
    SysUtils, Variants,strutils;
type
  TKeyByte = array[0..5] of Byte;
  TDesMode = (dmEncry, dmDecry);

  //加密
  function EncryStr(const Str: String;const Key: {$IFDEF UNICODE}ANSIString{$ELSE}String{$ENDIF}): String;
  function EncryStrHex(const Str: String;const Key: {$IFDEF UNICODE}ANSIString{$ELSE}String{$ENDIF}): String;
  //解密
  function DecryStr(const Str: String;const Key: {$IFDEF UNICODE}ANSIString{$ELSE}String{$ENDIF}): String;
  function DecryStrHex(StrHex: String;const Key: {$IFDEF UNICODE}ANSIString{$ELSE}String{$ENDIF}): String;

const
  BitIP: array[0..63] of Byte =   //初始值置IP
    (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,
     56, 48, 40, 32, 24, 16,  8,  0,
     58, 50, 42, 34, 26, 18, 10,  2,
     60, 52, 44, 36, 28, 20, 12,  4,
     62, 54, 46, 38, 30, 22, 14,  6 );

  BitCP: array[0..63] of Byte = //逆初始置IP-1
    ( 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,
      32,  0, 40,  8, 48, 16, 56, 24 );

  BitExp: array[0..47] of Integer = // 位选择函数E
    ( 31, 0, 1, 2, 3, 4, 3, 4, 5, 6, 7, 8, 7, 8, 9,10,
      11,12,11,12,13,14,15,16,15,16,17,18,19,20,19,20,
      21,22,23,24,23,24,25,26,27,28,27,28,29,30,31,0  );

  BitPM: array[0..31] of Byte =  //置换函数P
    ( 15, 6,19,20,28,11,27,16, 0,14,22,25, 4,17,30, 9,
       1, 7,23,13,31,26, 2, 8,18,12,29, 5,21,10, 3,24 );

  sBox: array[0..7] of array[0..63] of Byte =    //S盒
    ( ( 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 ) );

  BitPMC1: array[0..55] of Byte = //选择置换PC-1
    ( 56, 48, 40, 32, 24, 16,  8,
       0, 57, 49, 41, 33, 25, 17,
       9,  1, 58, 50, 42, 34, 26,
      18, 10,  2, 59, 51, 43, 35,
      62, 54, 46, 38, 30, 22, 14,
       6, 61, 53, 45, 37, 29, 21,
      13,  5, 60, 52, 44, 36, 28,
      20, 12,  4, 27, 19, 11,  3 );

  BitPMC2: array[0..47] of Byte =//选择置换PC-2
    ( 13, 16, 10, 23,  0,  4,
       2, 27, 14,  5, 20,  9,
      22, 18, 11,  3, 25,  7,
      15,  6, 26, 19, 12,  1,
      40, 51, 30, 36, 46, 54,
      29, 39, 50, 44, 32, 47,
      43, 48, 38, 55, 33, 52,
      45, 41, 49, 35, 28, 31 );

var
  subKey: array[0..15] of TKeyByte;

implementation

procedure initPermutation(var inData: array of Byte);
var
  newData: array[0..7] of Byte;
  i: Integer;
begin
  FillChar(newData, 8, 0);
  for i := 0 to 63 do
    if (inData[BitIP[i] shr 3] and (1 shl (7- (BitIP[i] and $07)))) <> 0 then
      newData[i shr 3] := newData[i shr 3] or (1 shl (7-(i and $07)));
  for i := 0 to 7 do inData[i] := newData[i];
end;

procedure conversePermutation(var inData: array of Byte);
var
  newData: array[0..7] of Byte;
  i: Integer;
begin
  FillChar(newData, 8, 0);
  for i := 0 to 63 do
    if (inData[BitCP[i] shr 3] and (1 shl (7-(BitCP[i] and $07)))) <> 0 then
      newData[i shr 3] := newData[i shr 3] or (1 shl (7-(i and $07)));
  for i := 0 to 7 do inData[i] := newData[i];
end;

procedure expand(inData: array of Byte; var outData: array of Byte);
var
  i: Integer;
begin
  FillChar(outData, 6, 0);
  for i := 0 to 47 do
    if (inData[BitExp[i] shr 3] and (1 shl (7-(BitExp[i] and $07)))) <> 0 then
      outData[i shr 3] := outData[i shr 3] or (1 shl (7-(i and $07)));
end;

procedure permutation(var inData: array of Byte);
var
  newData: array[0..3] of Byte;
  i: Integer;
begin
  FillChar(newData, 4, 0);
  for i := 0 to 31 do
    if (inData[BitPM[i] shr 3] and (1 shl (7-(BitPM[i] and $07)))) <> 0 then
      newData[i shr 3] := newData[i shr 3] or (1 shl (7-(i and $07)));
  for i := 0 to 3 do inData[i] := newData[i];
end;

function si(s,inByte: Byte): Byte;
var
  c: Byte;
begin
  c := (inByte and $20) or ((inByte and $1e) shr 1) or
    ((inByte and $01) shl 4);
  Result := (sBox[s][c] and $0f);
end;

procedure permutationChoose1(inData: array of Byte;
  var outData: array of Byte);
var
  i: Integer;
begin
  FillChar(outData, 7, 0);
  for i := 0 to 55 do
    if (inData[BitPMC1[i] shr 3] and (1 shl (7-(BitPMC1[i] and $07)))) <> 0 then
      outData[i shr 3] := outData[i shr 3] or (1 shl (7-(i and $07)));
end;

procedure permutationChoose2(inData: array of Byte;
  var outData: array of Byte);
var
  i: Integer;
begin
  FillChar(outData, 6, 0);
  for i := 0 to 47 do
    if (inData[BitPMC2[i] shr 3] and (1 shl (7-(BitPMC2[i] and $07)))) <> 0 then
      outData[i shr 3] := outData[i shr 3] or (1 shl (7-(i and $07)));
end;

procedure cycleMove(var inData: array of Byte; bitMove: Byte);
var
  i: Integer;
begin
  for i := 0 to bitMove - 1 do
  begin
    inData[0] := (inData[0] shl 1) or (inData[1] shr 7);
    inData[1] := (inData[1] shl 1) or (inData[2] shr 7);
    inData[2] := (inData[2] shl 1) or (inData[3] shr 7);
    inData[3] := (inData[3] shl 1) or ((inData[0] and $10) shr 4);
    inData[0] := (inData[0] and $0f);
  end;
end;

procedure makeKey(inKey: array of Byte; var outKey: array of TKeyByte);
const
  bitDisplace: array[0..15] of Byte =
    ( 1,1,2,2, 2,2,2,2, 1,2,2,2, 2,2,2,1 );
var
  outData56: array[0..6] of Byte;
  key28l: array[0..3] of Byte;
  key28r: array[0..3] of Byte;
  key56o: array[0..6] of Byte;
  i: Integer;
begin
  permutationChoose1(inKey, outData56);

  key28l[0] := outData56[0] shr 4;
  key28l[1] := (outData56[0] shl 4) or (outData56[1] shr 4);
  key28l[2] := (outData56[1] shl 4) or (outData56[2] shr 4);
  key28l[3] := (outData56[2] shl 4) or (outData56[3] shr 4);
  key28r[0] := outData56[3] and $0f;
  key28r[1] := outData56[4];
  key28r[2] := outData56[5];
  key28r[3] := outData56[6];

  for i := 0 to 15 do
  begin
    cycleMove(key28l, bitDisplace[i]);
    cycleMove(key28r, bitDisplace[i]);
    key56o[0] := (key28l[0] shl 4) or (key28l[1] shr 4);
    key56o[1] := (key28l[1] shl 4) or (key28l[2] shr 4);
    key56o[2] := (key28l[2] shl 4) or (key28l[3] shr 4);
    key56o[3] := (key28l[3] shl 4) or (key28r[0]);
    key56o[4] := key28r[1];
    key56o[5] := key28r[2];
    key56o[6] := key28r[3];
    permutationChoose2(key56o, outKey[i]);
  end;
end;

procedure encry(inData, subKey: array of Byte;
   var outData: array of Byte);
var
  outBuf: array[0..5] of Byte;
  buf: array[0..7] of Byte;
  i: Integer;
begin
  expand(inData, outBuf);
  for i := 0 to 5 do outBuf[i] := outBuf[i] xor subKey[i];
  buf[0] := outBuf[0] shr 2;
  buf[1] := ((outBuf[0] and $03) shl 4) or (outBuf[1] shr 4);
  buf[2] := ((outBuf[1] and $0f) shl 2) or (outBuf[2] shr 6);
  buf[3] := outBuf[2] and $3f;
  buf[4] := outBuf[3] shr 2;
  buf[5] := ((outBuf[3] and $03) shl 4) or (outBuf[4] shr 4);
  buf[6] := ((outBuf[4] and $0f) shl 2) or (outBuf[5] shr 6);
  buf[7] := outBuf[5] and $3f;
  for i := 0 to 7 do buf[i] := si(i, buf[i]);
  for i := 0 to 3 do outBuf[i] := (buf[i*2] shl 4) or buf[i*2+1];
  permutation(outBuf);
  for i := 0 to 3 do outData[i] := outBuf[i];
end;

procedure desData(desMode: TDesMode;
  inData: array of Byte; var outData: array of Byte);
// inData, outData 都为8Bytes，否则出错
var
  i, j: Integer;
  temp, buf: array[0..3] of Byte;
begin
  for i := 0 to 7 do outData[i] := inData[i];
  initPermutation(outData);
  if desMode = dmEncry then
  begin
    for i := 0 to 15 do
    begin
      for j := 0 to 3 do temp[j] := outData[j];          //temp = Ln
      for j := 0 to 3 do outData[j] := outData[j + 4];         //Ln+1 = Rn
      encry(outData, subKey[i], buf);          //Rn ==Kn==> buf
      for j := 0 to 3 do outData[j + 4] := temp[j] xor buf[j];  //Rn+1 = Ln^buf
    end;

    for j := 0 to 3 do temp[j] := outData[j + 4];
    for j := 0 to 3 do outData[j + 4] := outData[j];
    for j := 0 to 3 do outData[j] := temp[j];
  end
  else if desMode = dmDecry then
  begin
    for i := 15 downto 0 do
    begin
      for j := 0 to 3 do temp[j] := outData[j];
      for j := 0 to 3 do outData[j] := outData[j + 4];
      encry(outData, subKey[i], buf);
      for j := 0 to 3 do outData[j + 4] := temp[j] xor buf[j];
    end;
    for j := 0 to 3 do temp[j] := outData[j + 4];
    for j := 0 to 3 do outData[j + 4] := outData[j];
    for j := 0 to 3 do outData[j] := temp[j];
  end;
  conversePermutation(outData);
end;

//////////

function EncryStr(const Str: String;const Key: {$IFDEF UNICODE}ANSIString{$ELSE}String{$ENDIF}): String;
{$IFDEF UNICODE}
var
  StrBts, KeyBts: TBytes;
  StrByte, OutByte, KeyByte: array[0..7] of Byte;
  BtsResult: TBytes;
  I, J, ln, lj: Integer;
begin
  if (Length(Str) > 0) and (Ord(Str[Length(Str)]) = 0) then
    raise Exception.Create('Error: the last char is NULL char.');
  StrBts  :=  WideBytesOf(Str);
  KeyBts  :=  BytesOf(Key);

  ln  :=  Length(KeyBts);
  if ln< 8 then
  begin
    SetLength(KeyBts, 8);
    for I := ln to 8 do
      KeyBts[I-1] :=  Byte(0);
  end;

  ln  :=  Length(StrBts);
  lj  :=  ln mod 8;
  if lj<>0 then
  begin
    SetLength(StrBts, ln + 8-lj);
    for I := ln to ln+8-lj-1 do
      StrBts[I] :=  Byte(0);
  end;

  for J := 0 to 7 do
    KeyByte[J] := KeyBts[J];
  makeKey(keyByte, subKey);

  SetLength(BtsResult, Length(StrBts));
  for I := 0 to Length(StrBts) div 8 - 1 do
  begin
    for J := 0 to 7 do
      StrByte[J] := StrBts[I * 8 + J];
    desData(dmEncry, StrByte, OutByte);
    Move(OutByte[0], BtsResult[8*I], 8);
  end;

  Result := WideStringOf(BtsResult);
{$ELSE}
var
  StrByte, OutByte, KeyByte: array[0..7] of Byte;
  StrResult: String;
  I, J: Integer;
begin
  if (Length(Str) > 0) and (Ord(Str[Length(Str)]) = 0) then
    raise Exception.Create('Error: the last char is NULL char.');
  if Length(Key) < 8 then
    while Length(Key) < 8 do Key := Key + Chr(0);
  while Length(Str) mod 8 <> 0 do Str := Str + Chr(0);

  for J := 0 to 7 do KeyByte[J] := Ord(Key[J + 1]);
  makeKey(keyByte, subKey);

  StrResult := '';

  for I := 0 to Length(Str) div 8 - 1 do
  begin
    for J := 0 to 7 do
      StrByte[J] := Ord(Str[I * 8 + J + 1]);
    desData(dmEncry, StrByte, OutByte);
    for J := 0 to 7 do
      StrResult := StrResult + Chr(OutByte[J]);
  end;

  Result := StrResult;
{$ENDIF}
end;

function DecryStr(const Str: String;const Key: {$IFDEF UNICODE}ANSIString{$ELSE}String{$ENDIF}): String;
{$IFDEF UNICODE}
var
  StrBts, KeyBts: TBytes;
  StrByte, OutByte, KeyByte: array[0..7] of Byte;
  BtsResult: TBytes;
  I, J: Integer;
begin
  StrBts  :=  WideBytesOf(Str);
  KeyBts  :=  BytesOf(Key);

  if Length(KeyBts) < 8 then
    SetLength(KeyBts, 8);

  for J := 0 to 7 do
    KeyByte[J] := KeyBts[J ];
  makeKey(keyByte, subKey);

  SetLength(BtsResult, Length(StrBts));
  for I := 0 to Length(StrBts) div 8 - 1 do
  begin
    for J := 0 to 7 do
      StrByte[J] := StrBts[I * 8 + J];
    desData(dmDecry, StrByte, OutByte);
    Move(OutByte[0], BtsResult[I*8], 8);
  end;
  Result := WideStringOf(BtsResult);
{$ELSE}
var
  StrByte, OutByte, KeyByte: array[0..7] of Byte;
  StrResult: String;
  I, J: Integer;
begin
  if Length(Key) < 8 then
    while Length(Key) < 8 do Key := Key + Chr(0);

  for J := 0 to 7 do KeyByte[J] := Ord(Key[J + 1]);
  makeKey(keyByte, subKey);

  StrResult := '';

  for I := 0 to Length(Str) div 8 - 1 do
  begin
    for J := 0 to 7 do StrByte[J] := Ord(Str[I * 8 + J + 1]);
    desData(dmDecry, StrByte, OutByte);
    for J := 0 to 7 do
      StrResult := StrResult + Chr(OutByte[J]);
  end;
  while (Length(StrResult) > 0) and
    (Ord(StrResult[Length(StrResult)]) = 0) do
    Delete(StrResult, Length(StrResult), 1);
  Result := StrResult;
{$ENDIF}
end;

//////////

function EncryStrHex(const Str: String;const Key: {$IFDEF UNICODE}ANSIString{$ELSE}String{$ENDIF}): String;
{$IFDEF UNICODE}
var
  StrResult, TempResult, Temp: String;
  I,k: Integer;
  StrBts, BtsResult: TBytes;
begin
  TempResult  :=  EncryStr(Str, Key);
  StrBts      :=  WideBytesOf(TempResult);
  for I := 0 to Length(StrBts) - 1 do
  begin
    Temp := Format('%x', [Ord(StrBts[I])]);
    if Length(Temp) = 1 then
      Temp := '0' + Temp;
    StrResult := StrResult + Temp;
  end;
  k:=0;
  for i := 0 to Length(StrResult) - 1 do
    k:=k + ord((StrResult[I+1]));

  Result := StrResult + intToHex(Byte(k),2);
{$ELSE}
var
  StrResult, TempResult, Temp: String;
  I,k: Integer;
begin
  TempResult := EncryStr(Str, Key);
  StrResult := '';
  for I := 0 to Length(TempResult) - 1 do
  begin
    Temp := Format('%x', [Ord(TempResult[I + 1])]);
    if Length(Temp) = 1 then Temp := '0' + Temp;
    StrResult := StrResult + Temp;
  end;
  k:=0;
  for i := 0 to length(StrResult) - 1 do
    k:=k + ord((StrResult[i+1]));

  Result := StrResult + intToHex(Byte(k),2);
{$ENDIF}
end;

function DecryStrHex(StrHex: String;const Key: {$IFDEF UNICODE}ANSIString{$ELSE}String{$ENDIF}): String;

  function HexToInt(Hex: AnsiString): Integer;
  var
    I, Res: Integer;
    ch: AnsiChar;
  begin
    Res := 0;
    for I := 0 to Length(Hex) - 1 do
    begin
      ch := Hex[I + 1];
      if (ch >= '0') and (ch <= '9') then
        Res := Res * 16 + Ord(ch) - Ord('0')
      else if (ch >= 'A') and (ch <= 'F') then
        Res := Res * 16 + Ord(ch) - Ord('A') + 10
      else if (ch >= 'a') and (ch <= 'f') then
        Res := Res * 16 + Ord(ch) - Ord('a') + 10
      else
        raise Exception.Create('Error: not a Hex String');
    end;
    Result := Res;
  end;
{$IFDEF UNICODE}
var
  Str: String;
  Temp: AnsiString;
  I,k: Integer;
  BtsStr: TBytes;
begin
  Str := '';
  if Length(StrHex)<=2 then
  begin
    Result:='';
    Exit;
  end;

  K:=0;
  for I := 0 to Length(StrHex) - 3 do
    k:=k + ord((StrHex[i+1]));
  try
    if Byte(k)<>Byte(strToInt('$' + rightStr(StrHex,2))) then
    begin
      Result:='';
      Exit;
    end;
    Delete(StrHex,  Length(StrHex)-1,2);
    SetLength(BtsStr, Length(StrHex) div 2);

    for I := 0 to Length(StrHex) div 2 - 1 do
    begin
      Temp := Copy(StrHex, I * 2 + 1, 2);
      BtsStr[I] :=  Byte(HexToInt(Temp));
    end;
    Str :=  WideStringOf(BtsStr);
    Result := DecryStr(Str, Key);
  except
    Result:='';
  end;
{$ELSE}
var
  Str, Temp: String;
  I,k: Integer;
begin
  Str := '';

  if length(StrHex)<=2 then
  begin
      result:='';
      exit;
  end;
  K:=0;
  for i := 0 to length(StrHex) - 3 do
    k:=k + ord((StrHex[i+1]));
  try
      if Byte(k)<>Byte(strToInt('$' + rightStr(StrHex,2))) then
      begin
          result:='';
          exit;
      end;
      delete(StrHex,length(StrHex)-1,2);

      for I := 0 to Length(StrHex) div 2 - 1 do
      begin
        Temp := Copy(StrHex, I * 2 + 1, 2);
        Str := Str + Chr(HexToInt(Temp));
      end;
      Result := DecryStr(Str, Key);
  except
    result:='';
  end;
{$ENDIF}
end;

end.