posted September 27, 2002 08:34 AM            

I have ported the GOST data encryption implementation from a VB app to PB.
Have fun!

check this site for more info on GOST: http://www.jetico.com/index.htm#/gost.htm

'
'Ported to PB/Win 26.09.2002 by bi@inside.net
'From a VB source by Ásgeir Bjarni Ingvarsson
'
'Gosudarstvennyi Standard Soyuza SSR 28147-89
'              (GOST 28147-89)
'
#Compile Exe
#Include "win32api.inc"
Declare Function DeHex(Inpt As String) As String
Declare Function GenKeyGOST() As String
Declare Function DeHex(Inpt As String) As String
Declare Function DeHex(Inpt As String) As String
Declare Function BigXOR(ByVal value1 As String, ByVal value2 As String) As String
Declare Function BigMod32Add(ByVal value1 As String, ByVal value2 As String) As String
Declare Function BigAdd(ByVal value1 As String, ByVal value2 As String) As String
Declare Function BigShiftLeft(value1 As String, shifts As Integer) As String
Declare Function F(R As String, k As String) As String
Declare Function EncryptGOST(ByVal Inpt As String, ByVal key As String) As String
Declare Function DecryptGOST(ByVal Inpt As String, ByVal key As String) As String
Declare Function Encrypt(ByVal Inpt As String, ByVal key As String) As String
Declare Function PadInpt(Inpt As String) As String
Global S1 As Dword Ptr
Global S2 As Dword Ptr
Global S3 As Dword Ptr
Global S4 As Dword Ptr
Global S5 As Dword Ptr
Global S6 As Dword Ptr
Global S7 As Dword Ptr
Global S8 As Dword Ptr
Sub InitGOST()
  GoTo defs
  AS1:
  !DD &H6, &H5, &H1, &H7, &HE, &H0, &H4, &HA, &HB, &H9, &H3, &HD, &H8, &HC, &H2, &HF
  AS2:
  !DD &HE, &HD, &H9, &H0, &H8, &HA, &HC, &H4, &H7, &HF, &H6, &HB, &H3, &H1, &H5, &H2
  AS3:
  !DD &H6, &H5, &H1, &H7, &H2, &H4, &HA, &H0, &HB, &HD, &HE, &H3, &H8, &HC, &HF, &H9
  AS4:
  !DD &H8, &H7, &H3, &H9, &H6, &H4, &HE, &H5, &H2, &HD, &H0, &HC, &H1, &HB, &HA, &HF
  AS5:
  !DD &HA, &H9, &H6, &HB, &H5, &H1, &H8, &H4, &H0, &HD, &H7, &H2, &HE, &H3, &HF, &HC
  AS6:
  !DD &H5, &H3, &H0, &H6, &HB, &HD, &H4, &HE, &HA, &H7, &H1, &HC, &H2, &H8, &HF, &H9
  AS7:
  !DD &H2, &H1, &HC, &H3, &HB, &HD, &HF, &H7, &HA, &H6, &H9, &HE, &H0, &H8, &H4, &H5
  AS8:
  !DD &H6, &H5, &H1, &H7, &H8, &H9, &H4, &H2, &HF, &H3, &HD, &HC, &HA, &HE, &HB, &H0
defs:
  S1 = CodePtr(AS1)
  S2 = CodePtr(AS2)
  S3 = CodePtr(AS3)
  S4 = CodePtr(AS4)
  S5 = CodePtr(AS5)
  S6 = CodePtr(AS6)
  S7 = CodePtr(AS7)
  S8 = CodePtr(AS8)
End Sub
Function GenKeyGOST() As String
  Dim i As Integer
  Dim dat As String
  Dim key As String
  Randomize
  For i = 1 To 32
      dat = Hex$(Rnd(1,255))
      If Len(dat) = 1 Then dat = "0" & dat
      key = key & dat
  Next i
  Function = key
End Function
Function EnHex(X As String) As String
  Dim i As Integer
  Dim v As String
  Dim inpt As String
  For i = 1 To Len(X)
      v = Hex$(Asc(Mid$(X, i, 1)))
      If Len(v) = 1 Then v = "0" & v
      Inpt = Inpt & v
  Next i
  EnHex = Inpt
End Function
Function DeHex(Inpt As String) As String
  Dim i As Integer
  Dim X As String
  For i = 1 To Len(Inpt) Step 2
      X = X & Chr$(Val("&H" & Mid$(Inpt, i, 2)))
  Next i
  DeHex = X
  End Function
Function PadInpt(Inpt As String) As String
  check1:
  If Not (Len(Inpt) / 16) = (Len(Inpt) \ 16) Then
      Inpt = Inpt & "0"
      GoTo check1
  End If
  PadInpt = Inpt
End Function
Function BigXOR(ByVal value1 As String, ByVal value2 As String) As String
  Dim valueans As String
  Dim loopit As Integer, tempnum As Integer
      tempnum = Len(value1) - Len(value2)
      If tempnum < 0 Then
          valueans = Left$(value2, Abs(tempnum))
          value2 = Mid$(value2, Abs(tempnum) + 1)
      ElseIf tempnum > 0 Then
          valueans = Left$(value1, Abs(tempnum))
          value1 = Mid$(value1, tempnum + 1)
      End If
      For loopit = 1 To Len(value1)
          valueans = valueans + Hex$(Val("&H" + Mid$(value1, loopit, 1)) Xor Val("&H" + Mid$(value2, loopit, 1)))
      Next loopit
      BigXOR = Right$(valueans, 8)
End Function
Function BigMod32Add(ByVal value1 As String, ByVal value2 As String) As String
    BigMod32Add = Right$(BigAdd(value1, value2), 8)
End Function
Function BigAdd(ByVal value1 As String, ByVal value2 As String) As String
  Dim valueans As String
  Dim loopit As Integer, tempnum As Integer
      tempnum = Len(value1) - Len(value2)
      If tempnum < 0 Then
          value1 = Space$(Abs(tempnum)) + value1
      ElseIf tempnum > 0 Then
            value2 = Space$(Abs(tempnum)) + value2
      End If
      tempnum = 0
      For loopit = Len(value1) To 1 Step -1
          tempnum = tempnum + Val("&H" + Mid$(value1, loopit, 1)) + Val("&H" + Mid$(value2, loopit, 1))
          valueans = Hex$(tempnum Mod 16) + valueans
          tempnum = Int(tempnum / 16)
      Next loopit
      If tempnum <> 0 Then
          valueans = Hex$(tempnum) + valueans
      End If
    BigAdd = Right$(valueans, 8)
End Function
Function BigShiftLeft(value1 As String, shifts As Integer) As String
  Dim tempstr As String
  Dim loopit As Integer, loopinner As Integer
  Dim tempnum As Integer
  Dim i As Integer, j As Integer
      shifts = shifts Mod 32
      If shifts = 0 Then
          BigShiftLeft = value1
          Exit Function
      End If
      value1 = Right$(value1, 8)
      tempstr = String$(8 - Len(value1), "0") + value1
      value1 = ""
    ' Convert to binary
      For loopit = 1 To 8
          tempnum = Val("&H" + Mid$(tempstr, loopit, 1))
          For loopinner = 3 To 0 Step -1
              If tempnum And 2 ^ loopinner Then
                  value1 = value1 + "1"
              Else
                  value1 = value1 + "0"
              End If
          Next loopinner
      Next loopit
      For i = 1 To shifts
          For j = 1 To 32
              Mid$(value1, j, 1) = Mid$(value1, j + 1, 1)
              If Not Mid$(value1, 1, 1) = "0" Then Mid$(value1, 1, 1) = "0"
          Next j
      Next i
      tempstr = value1
    ' And convert back to hex
      value1 = ""
      For loopit = 0 To 7
          tempnum = 0
          For loopinner = 0 To 3
              If Val(Mid$(tempstr, 4 * loopit + loopinner + 1, 1)) Then
                  tempnum = tempnum + 2 ^ (3 - loopinner)
              End If
          Next loopinner
          value1 = value1 + Hex$(tempnum)
      Next loopit
      BigShiftLeft = Right$(value1, 8)
End Function
Function F(R As String, k As String) As String
  Dim X As String
  Dim A As Long, B As Long, C As Long, D As Long, E As Long, l As Long, G As Long, h As Long
  X = BigMod32Add(R, k)
  A = Val("&H" & Mid$(X, 1, 1))
  B = Val("&H" & Mid$(X, 2, 1))
  C = Val("&H" & Mid$(X, 3, 1))
  D = Val("&H" & Mid$(X, 4, 1))
  E = Val("&H" & Mid$(X, 5, 1))
  l = Val("&H" & Mid$(X, 6, 1))
  G = Val("&H" & Mid$(X, 7, 1))
  h = Val("&H" & Mid$(X, 8, 1))
  A = @S1[A]
  B = @S2[B]
  C = @S3[C]
  D = @S4[D]
  E = @S5[E]
  l = @S6[l]
  G = @S7[G]
  h = @S8[h]
  X = Str$(A) & Str$(B) & Str$(C) & Str$(D) & Str$(E) & Str$(l) & Str$(G) & Str$(h)
  X = BigShiftLeft(X, 11)
  F = X
End Function
Function Encrypt(ByVal Inpt As String, ByVal key As String) As String
  Dim k(1 To 8) As String
  Dim l As String
  Dim R As String
  Dim j As Integer, i As Integer
  k(1) = Mid$(key, 1, 8)
  k(2) = Mid$(key, 8, 8)
  k(3) = Mid$(key, 16, 8)
  k(4) = Mid$(key, 24, 8)
  k(5) = Mid$(key, 32, 8)
  k(6) = Mid$(key, 40, 8)
  k(7) = Mid$(key, 48, 8)
  k(8) = Mid$(key, 56, 8)
  For j = 1 To Len(Inpt) Step 16
      l = Mid$(Inpt, j, 8)
      R = Mid$(Inpt, j + 8, 8)
      For i = 1 To 3
          R = BigXOR(R, F(l, k(1)))
          l = BigXOR(l, F(R, k(2)))
          R = BigXOR(R, F(l, k(3)))
          l = BigXOR(l, F(R, k(4)))
          R = BigXOR(R, F(l, k(5)))
          l = BigXOR(l, F(R, k(6)))
          R = BigXOR(R, F(l, k(7)))
          l = BigXOR(l, F(R, k(8)))
      Next i
      R = BigXOR(R, F(l, k(8)))
      l = BigXOR(l, F(R, k(7)))
      R = BigXOR(R, F(l, k(6)))
      l = BigXOR(l, F(R, k(5)))
      R = BigXOR(R, F(l, k(4)))
      l = BigXOR(l, F(R, k(3)))
      R = BigXOR(R, F(l, k(2)))
      l = BigXOR(l, F(R, k(1)))
      Mid$(Inpt, j, 8) = R
      Mid$(Inpt, j + 8, 8) = l
  Next j
  Encrypt = Inpt
End Function
Function EncryptGOST(ByVal Inpt As String, ByVal key As String) As String
  Dim InptHex As String
  InptHex = PadInpt(EnHex(Inpt))
  EncryptGOST = Encrypt(InptHex, key)
End Function
Function DecryptGOST(ByVal Inpt As String, ByVal key As String) As String
  Dim k(1 To 8) As String
  Dim l As String
  Dim R As String
  Dim j As Integer, i As Integer
  k(1) = Mid$(key, 1, 8)
  k(2) = Mid$(key, 8, 8)
  k(3) = Mid$(key, 16, 8)
  k(4) = Mid$(key, 24, 8)
  k(5) = Mid$(key, 32, 8)
  k(6) = Mid$(key, 40, 8)
  k(7) = Mid$(key, 48, 8)
  k(8) = Mid$(key, 56, 8)
  For j = 1 To Len(Inpt) Step 16
      l = Mid$(Inpt, j, 8)
      R = Mid$(Inpt, j + 8, 8)
      R = BigXOR(R, F(l, k(1)))
      l = BigXOR(l, F(R, k(2)))
      R = BigXOR(R, F(l, k(3)))
      l = BigXOR(l, F(R, k(4)))
      R = BigXOR(R, F(l, k(5)))
      l = BigXOR(l, F(R, k(6)))
      R = BigXOR(R, F(l, k(7)))
      l = BigXOR(l, F(R, k(8)))
      For i = 1 To 3
          R = BigXOR(R, F(l, k(8)))
          l = BigXOR(l, F(R, k(7)))
          R = BigXOR(R, F(l, k(6)))
          l = BigXOR(l, F(R, k(5)))
          R = BigXOR(R, F(l, k(4)))
          l = BigXOR(l, F(R, k(3)))
          R = BigXOR(R, F(l, k(2)))
          l = BigXOR(l, F(R, k(1)))
      Next i
      Mid$(Inpt, j, 8) = R
      Mid$(Inpt, j + 8, 8) = l
  Next j
  DecryptGOST = Inpt
End Function
Function PbMain
  Dim key As String
  Dim x As String
  Dim L As String
  Dim inpt As String
  Dim inpt2 As String
  Dim outmsg As String
  InitGOST
  inpt = "This string to be encrypted."
  key = GenKeyGOST
  x = PadInpt(EnHex(inpt))
  L = Encrypt(x, key)
  outmsg = "This string: " + inpt + $CrLf + "with this key: " + key + $CrLf + "results in this crypt string: " + L
  inpt2 = DecryptGOST(L, key)
  x = DeHex(inpt2)
  outmsg = outmsg + $CrLf + "decrypts to: " + x
  MsgBox outmsg, %MB_OK, "GOST for PB"
End Function

...and formatting corrected. Thanks Eddie!

------------------
Balthasar Indermuehle, M.Sc.

posted September 27, 2002 12:30 PM            

A small tip: use the 'code' formatting statement (surrounded by []) to make your source code easier to read on the forums.
Read all about it here:
http://www.powerbasic.com/support/forums/ubbcode.html

Kind regards