Posted to tcl by Zarutian at Sat Jun 21 11:26:21 GMT 2008view raw

  1. package require Tcl 8.5
  2. package require sha1 1.0.3
  3.  
  4. # an simple cipher feedback (cfb) based cipher
  5. #
  6. # This version actually works
  7. # I suspect that the strength of this cipher
  8. # is based on the strength of the one-way function it uses
  9. # (which is sha1)
  10.  
  11. proc encrypt {iv plain key} {
  12. set out {}
  13. set tmp1 $iv
  14. set tmp2 [string length $plain]
  15. while {$tmp2 > 0} {
  16. while {[string length $plain] < 20} {
  17. append plain \x00
  18. }
  19. set tmp3 [sha1::sha1 "[set key][set tmp1]"]
  20. set tmp4 [bin2hex [string range $plain 0 19]]
  21. set tmp5 [XOR $tmp3 $tmp4]
  22. set cipher [hex2bin $tmp5]
  23. append out [string range $cipher 0 [expr {$tmp2 - 1}]]
  24. set plain [string range $plain 20 end]
  25. set tmp1 $cipher
  26. set tmp2 [string length $plain]
  27. }
  28. return $out
  29. }
  30. proc decrypt {iv cipher key} {
  31. set out {}
  32. set tmp1 $iv
  33. set tmp2 [string length $cipher]
  34. while {$tmp2 > 0} {
  35. while {[string length $cipher] < 20} {
  36. append cipher \x00
  37. }
  38. set tmp3 [sha1::sha1 "[set key][set tmp1]"]
  39. set tmp4 [string range $cipher 0 19]
  40. set tmp5 [bin2hex $tmp4]
  41. set tmp6 [XOR $tmp3 $tmp5]
  42. set tmp7 [hex2bin $tmp6]
  43. append out [string range $tmp7 0 [expr {$tmp2 - 1}]]
  44. set cipher [string range $cipher 20 end]
  45. set tmp1 $tmp4
  46. set tmp2 [string length $cipher]
  47. }
  48. return $out
  49. }
  50.  
  51. proc XOR {a b} {
  52. if {[string length $a] != [string length $b]} {
  53. error "a and b arent of same length!"
  54. }
  55. set out {}
  56. foreach i [split $a ""] j [split $b ""] {
  57. scan $i "%x" i
  58. scan $j "%x" j
  59. set c [expr {$i ^ $j}]
  60. append out [format "%x" $c]
  61. }
  62. return $out
  63. }
  64. proc bin2hex {input} {
  65. set out {}
  66. foreach byte [split $input ""] {
  67. binary scan $byte H* t
  68. append out $t
  69. }
  70. return $out
  71. }
  72. proc hex2bin {input} {
  73. set out {}
  74. foreach {a b} [split $input ""] {
  75. set c "[set a][set b]"
  76. append out [binary format H* $c]
  77. }
  78. return $out
  79. }