source: tol/tolsh/tolsh.vfs/lib/tcllib1.10/des/tcldes.tcl @ 8597867d

1941-docker-image-to-testdevel
Last change on this file since 8597867d was 8597867d, checked in by Jorge Pérez <josp.jorge@…>, 16 years ago

closes #976, se incluye tcllib1.10, base64 debe eliminarse del raiz de lib ya que esta incluido en tcllib

git-svn-id: ​https://www.tol-project.org/svn/tolp/trunk@2556 be4846ae-f051-483a-831f-b64e7d08527f
  • Property mode set to 100644
File size: 45.4 KB
Line 
1# des.tcl
2# $Revision: 1.1 $
3# $Date: 2005/09/26 09:16:59 $
4#
5# Port of Javascript implementation to Tcl 8.4 by Mac A. Cody,
6# October, 2002 - February, 2003
7# August, 2003 - Separated key set generation from encryption/decryption.
8#                Renamed "des" procedure to "block" to differentiate from the
9#                "stream" procedure used for CFB and OFB modes.
10#                Modified the "encrypt" and "decrypt" procedures to support
11#                CFB and OFB modes. Changed the procedure arguments.
12#                Added the "stream" procedure to support CFB and OFB modes.
13# June, 2004 - Corrected input vector bug in stream-mode processing.  Added
14#              support for feedback vector storage and management function.
15#              This enables a stream of data to be processed over several calls
16#              to the encryptor or decryptor.
17# September, 2004 - Added feedback vector to the CBC mode of operation to allow
18#                   a large data set to be processed over several calls to the
19#                   encryptor or decryptor.
20# October, 2004 - Added test for weak keys in the createKeys procedure.
21#
22# Paul Tero, July 2001
23# http://www.shopable.co.uk/des.html
24#
25# Optimised for performance with large blocks by Michael Hayworth,
26# November 2001, http://www.netdealing.com
27#
28# This software is copyrighted (c) 2003, 2004 by Mac A. Cody.  All rights
29# reserved.  The following terms apply to all files associated with
30# the software unless explicitly disclaimed in individual files or
31# directories.
32
33# The authors hereby grant permission to use, copy, modify, distribute,
34# and license this software for any purpose, provided that existing
35# copyright notices are retained in all copies and that this notice is
36# included verbatim in any distributions. No written agreement, license,
37# or royalty fee is required for any of the authorized uses.
38# Modifications to this software may be copyrighted by their authors and
39# need not follow the licensing terms described here, provided that the
40# new terms are clearly indicated on the first page of each file where
41# they apply.
42
43# IN NO EVENT SHALL THE AUTHORS OR DISTRIBUTORS BE LIABLE TO ANY PARTY
44# FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES
45# ARISING OUT OF THE USE OF THIS SOFTWARE, ITS DOCUMENTATION, OR ANY
46# DERIVATIVES THEREOF, EVEN IF THE AUTHORS HAVE BEEN ADVISED OF THE
47# POSSIBILITY OF SUCH DAMAGE.
48
49# THE AUTHORS AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY WARRANTIES,
50# INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY,
51# FITNESS FOR A PARTICULAR PURPOSE, AND NON-INFRINGEMENT.  THIS SOFTWARE
52# IS PROVIDED ON AN "AS IS" BASIS, AND THE AUTHORS AND DISTRIBUTORS HAVE
53# NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR
54# MODIFICATIONS.
55
56# GOVERNMENT USE: If you are acquiring this software on behalf of the
57# U.S. government, the Government shall have only "Restricted Rights"
58# in the software and related documentation as defined in the Federal
59# Acquisition Regulations (FARs) in Clause 52.227.19 (c) (2).  If you
60# are acquiring the software on behalf of the Department of Defense, the
61# software shall be classified as "Commercial Computer Software" and the
62# Government shall have only "Restricted Rights" as defined in Clause
63# 252.227-7013 (c) (1) of DFARs.  Notwithstanding the foregoing, the
64# authors grant the U.S. Government and others acting in its behalf
65# permission to use and distribute the software in accordance with the
66# terms specified in this license.
67namespace eval des {
68    variable keysets
69    variable WeakKeysError
70    if {![info exists WeakKeysError]} { set WeakKeysError 1 }
71    set keysets(ndx) 1
72    # Produre: keyset - Create or destroy a keyset created from a 64-bit
73    #                   DES key or a 192-bit 3DES key.
74    # Inputs:
75    #   oper  : The operation to be performed.  This will be either "create"
76    #           (make a new keyset) or "destroy" (delete an existing keyset).
77    #           The meaning of the argument "value" depends of the operation
78    #           performed.  An error is generated if "oper" is not "create"
79    #           or "destroy".
80    #             
81    #   value : If the argument "oper" is "create", then "value" is the 64-bit
82    #           DES key or the 192-bit 3DES key.  (Note: The lsb of each byte
83    #           is ignored; odd parity is not required).  If the argument
84    #           "oper" is "destroy", then "value" is a handle to a keyset that
85    #           was created previously.
86    #
87    #   weak:   If true then weak keys are allowed. The default is to raise an
88    #           error when a weak key is seen.
89    # Output:
90    #   If the argument "oper" is "create", then the output is a handle to the
91    #   keyset stored in the des namespace.  If the argument "oper" is
92    #   "destroy", then nothing is returned.
93    proc keyset {oper value {weak 0}} {
94        variable keysets
95        set newset {}
96        switch -exact -- $oper {
97            create {
98                # Create a new keyset handle.
99                set newset keyset$keysets(ndx)
100                # Create key set
101                set keysets($newset) [createKeys $value $weak]
102                # Never use that keyset handle index again.
103                incr keysets(ndx)
104            }
105            destroy {
106                # Determine if the keyset handle is valid.
107                if {[array names keysets $value] != {}} {
108                    # Delete the handle and corresponding keyset.
109                    unset keysets($value)
110                } else {
111                    error "The keyset handle \"$value\" is invalid!"
112                }
113            }
114            default {
115                error {The operator must be either "create" or "destroy".}
116            }
117        }
118        return $newset
119    }
120
121    # Procedure: encrypt - Encryption front-end for the des procedure
122    # Inputs:
123    #   keyset  : Handle to an existing keyset.
124    #   message : String to be encrypted.
125    #   mode    : DES mode ecb (default), cbc, cfb, or ofb.
126    #   iv      : Name of the initialization vector used in CBC, CFB,
127    #             and OFB modes.
128    #   kbits   : Number of bits in a data block (default of 64).
129    # Output:
130    #   The encrypted data string.
131    proc encrypt {keyset message {mode ecb} {iv {}} {kbits 64}} {
132        switch -exact -- $mode {
133            ecb {
134                return [block $keyset $message 1 0]
135            }
136            cbc -
137            ofb -
138            cfb {
139                # Is the initialization/feedback vector variable is valid?
140                if {[string length $iv] == 0} {
141                    error "An initialization variable must be specified."
142                } else {
143                    upvar $iv ivec
144                    if {![info exists ivec]} {
145                        error "The variable $iv does not exist."
146                    }
147                }
148                switch -exact -- $mode {
149                    cbc {
150                        return [block $keyset $message 1 1 ivec]
151                    }
152                    ofb {
153                        return [stream $keyset $message 1 0 ivec $kbits]
154                    }
155                    cfb {
156                        return [stream $keyset $message 1 1 ivec $kbits]
157                    }
158                }
159            }
160            default {
161                error {Mode must be ecb, cbc, cfb, or ofb.}
162            }
163        }
164    }
165
166    # Procedure: decrypt - Decryption front-end for the des procedure
167    # Inputs:
168    #   keyset  : Handle to an existing keyset.
169    #   message : String to be decrypted.
170    #   mode    : DES mode ecb (default), cbc, cfb, or ofb.
171    #   iv      : Name of the initialization vector used in CBC, CFB,
172    #             and OFB modes.
173    #   kbits   : Number of bits in a data block (default of 64).
174    # Output:
175    #   The encrypted or decrypted data string.
176    proc decrypt {keyset message {mode ecb} {iv {}} {kbits 64}} {
177        switch -exact -- $mode {
178            ecb {
179                return [block $keyset $message 0 0]
180            }
181            cbc -
182            ofb -
183            cfb {
184                # Is the initialization/feedback vector variable is valid?
185                if {[string length $iv] < 1} {
186                    error "An initialization variable must be specified."
187                } else {
188                    upvar $iv ivec
189                    if {![info exists ivec]} {
190                        error "The variable $iv does not exist."
191                    }
192                }
193                switch -exact -- $mode {
194                    cbc {
195                        return [block $keyset $message 0 1 ivec]
196                    }
197                    ofb {
198                        return [stream $keyset $message 0 0 ivec $kbits]
199                    }
200                    cfb {
201                        return [stream $keyset $message 0 1 ivec $kbits]
202                    }
203                }
204            }
205            default {
206                error {Mode must be ecb, cbc, cfb, or ofb.}
207            }
208        }
209    }
210
211    variable spfunction1 [list 0x1010400 0 0x10000 0x1010404 0x1010004 0x10404 0x4 0x10000 0x400 0x1010400 0x1010404 0x400 0x1000404 0x1010004 0x1000000 0x4 0x404 0x1000400 0x1000400 0x10400 0x10400 0x1010000 0x1010000 0x1000404 0x10004 0x1000004 0x1000004 0x10004 0 0x404 0x10404 0x1000000 0x10000 0x1010404 0x4 0x1010000 0x1010400 0x1000000 0x1000000 0x400 0x1010004 0x10000 0x10400 0x1000004 0x400 0x4 0x1000404 0x10404 0x1010404 0x10004 0x1010000 0x1000404 0x1000004 0x404 0x10404 0x1010400 0x404 0x1000400 0x1000400 0 0x10004 0x10400 0 0x1010004];
212    variable spfunction2 [list 0x80108020 0x80008000 0x8000 0x108020 0x100000 0x20 0x80100020 0x80008020 0x80000020 0x80108020 0x80108000 0x80000000 0x80008000 0x100000 0x20 0x80100020 0x108000 0x100020 0x80008020 0 0x80000000 0x8000 0x108020 0x80100000 0x100020 0x80000020 0 0x108000 0x8020 0x80108000 0x80100000 0x8020 0 0x108020 0x80100020 0x100000 0x80008020 0x80100000 0x80108000 0x8000 0x80100000 0x80008000 0x20 0x80108020 0x108020 0x20 0x8000 0x80000000 0x8020 0x80108000 0x100000 0x80000020 0x100020 0x80008020 0x80000020 0x100020 0x108000 0 0x80008000 0x8020 0x80000000 0x80100020 0x80108020 0x108000];
213    variable spfunction3 [list 0x208 0x8020200 0 0x8020008 0x8000200 0 0x20208 0x8000200 0x20008 0x8000008 0x8000008 0x20000 0x8020208 0x20008 0x8020000 0x208 0x8000000 0x8 0x8020200 0x200 0x20200 0x8020000 0x8020008 0x20208 0x8000208 0x20200 0x20000 0x8000208 0x8 0x8020208 0x200 0x8000000 0x8020200 0x8000000 0x20008 0x208 0x20000 0x8020200 0x8000200 0 0x200 0x20008 0x8020208 0x8000200 0x8000008 0x200 0 0x8020008 0x8000208 0x20000 0x8000000 0x8020208 0x8 0x20208 0x20200 0x8000008 0x8020000 0x8000208 0x208 0x8020000 0x20208 0x8 0x8020008 0x20200];
214    variable spfunction4 [list 0x802001 0x2081 0x2081 0x80 0x802080 0x800081 0x800001 0x2001 0 0x802000 0x802000 0x802081 0x81 0 0x800080 0x800001 0x1 0x2000 0x800000 0x802001 0x80 0x800000 0x2001 0x2080 0x800081 0x1 0x2080 0x800080 0x2000 0x802080 0x802081 0x81 0x800080 0x800001 0x802000 0x802081 0x81 0 0 0x802000 0x2080 0x800080 0x800081 0x1 0x802001 0x2081 0x2081 0x80 0x802081 0x81 0x1 0x2000 0x800001 0x2001 0x802080 0x800081 0x2001 0x2080 0x800000 0x802001 0x80 0x800000 0x2000 0x802080];
215    variable spfunction5 [list 0x100 0x2080100 0x2080000 0x42000100 0x80000 0x100 0x40000000 0x2080000 0x40080100 0x80000 0x2000100 0x40080100 0x42000100 0x42080000 0x80100 0x40000000 0x2000000 0x40080000 0x40080000 0 0x40000100 0x42080100 0x42080100 0x2000100 0x42080000 0x40000100 0 0x42000000 0x2080100 0x2000000 0x42000000 0x80100 0x80000 0x42000100 0x100 0x2000000 0x40000000 0x2080000 0x42000100 0x40080100 0x2000100 0x40000000 0x42080000 0x2080100 0x40080100 0x100 0x2000000 0x42080000 0x42080100 0x80100 0x42000000 0x42080100 0x2080000 0 0x40080000 0x42000000 0x80100 0x2000100 0x40000100 0x80000 0 0x40080000 0x2080100 0x40000100];
216    variable spfunction6 [list 0x20000010 0x20400000 0x4000 0x20404010 0x20400000 0x10 0x20404010 0x400000 0x20004000 0x404010 0x400000 0x20000010 0x400010 0x20004000 0x20000000 0x4010 0 0x400010 0x20004010 0x4000 0x404000 0x20004010 0x10 0x20400010 0x20400010 0 0x404010 0x20404000 0x4010 0x404000 0x20404000 0x20000000 0x20004000 0x10 0x20400010 0x404000 0x20404010 0x400000 0x4010 0x20000010 0x400000 0x20004000 0x20000000 0x4010 0x20000010 0x20404010 0x404000 0x20400000 0x404010 0x20404000 0 0x20400010 0x10 0x4000 0x20400000 0x404010 0x4000 0x400010 0x20004010 0 0x20404000 0x20000000 0x400010 0x20004010];
217    variable spfunction7 [list 0x200000 0x4200002 0x4000802 0 0x800 0x4000802 0x200802 0x4200800 0x4200802 0x200000 0 0x4000002 0x2 0x4000000 0x4200002 0x802 0x4000800 0x200802 0x200002 0x4000800 0x4000002 0x4200000 0x4200800 0x200002 0x4200000 0x800 0x802 0x4200802 0x200800 0x2 0x4000000 0x200800 0x4000000 0x200800 0x200000 0x4000802 0x4000802 0x4200002 0x4200002 0x2 0x200002 0x4000000 0x4000800 0x200000 0x4200800 0x802 0x200802 0x4200800 0x802 0x4000002 0x4200802 0x4200000 0x200800 0 0x2 0x4200802 0 0x200802 0x4200000 0x800 0x4000002 0x4000800 0x800 0x200002];
218    variable spfunction8 [list 0x10001040 0x1000 0x40000 0x10041040 0x10000000 0x10001040 0x40 0x10000000 0x40040 0x10040000 0x10041040 0x41000 0x10041000 0x41040 0x1000 0x40 0x10040000 0x10000040 0x10001000 0x1040 0x41000 0x40040 0x10040040 0x10041000 0x1040 0 0 0x10040040 0x10000040 0x10001000 0x41040 0x40000 0x41040 0x40000 0x10041000 0x1000 0x40 0x10040040 0x1000 0x41040 0x10001000 0x40 0x10000040 0x10040000 0x10040040 0x10000000 0x40000 0x10001040 0 0x10041040 0x40040 0x10000040 0x10040000 0x10001000 0x10001040 0 0x10041040 0x41000 0x41000 0x1040 0x1040 0x40040 0x10000000 0x10041000];
219
220    variable desEncrypt {0 32 2}
221    variable desDecrypt {30 -2 -2}
222    variable des3Encrypt {0 32 2 62 30 -2 64 96 2}
223    variable des3Decrypt {94 62 -2 32 64 2 30 -2 -2}
224
225    # Procedure: block - DES ECB and CBC mode support
226    # Inputs:
227    #   keyset   : Handle to an existing keyset.
228    #   message  : String to be encrypted or decrypted (Note: For encryption,
229    #              the string is extended with null characters to an integral
230    #              multiple of eight bytes.  For decryption, the string length
231    #              must be an integral multiple of eight bytes.
232    #   encrypt  : Perform encryption (1) or decryption (0)
233    #   mode     : DES mode 1=CBC, 0=ECB (default).
234    #   iv       : Name of the variable containing the initialization vector
235    #              used in CBC mode.  The value must be 64 bits in length.
236    # Output:
237    #   The encrypted or decrypted data string.
238    proc block {keyset message encrypt {mode 0} {iv {}}} {
239        variable spfunction1
240        variable spfunction2
241        variable spfunction3
242        variable spfunction4
243        variable spfunction5
244        variable spfunction6
245        variable spfunction7
246        variable spfunction8
247        variable desEncrypt
248        variable desDecrypt
249        variable des3Encrypt
250        variable des3Decrypt
251        variable keysets
252
253        # Determine if the keyset handle is valid.
254        if {[array names keysets $keyset] != {}} {
255            # Acquire the 16 or 48 subkeys we will need
256            set keys $keysets($keyset)
257        } else {
258            error "The keyset handle \"$keyset\" is invalid!"
259        }
260        set m 0
261        set cbcleft 0x00; set cbcleft2 0x00
262        set cbcright 0x00; set cbcright2 0x00
263        set len [string length $message];
264        if {$len == 0} {
265            return -code error "invalid message size: the message may not be empty"
266        }
267        set chunk 0;
268        # Set up the loops for single and triple des
269        set iterations [expr {[llength $keys] == 32 ? 3 : 9}];
270        if {$iterations == 3} {
271            expr {$encrypt ? [set looping $desEncrypt] : \
272                      [set looping $desDecrypt]}
273        } else {
274            expr {$encrypt ? [set looping $des3Encrypt] : \
275                      [set looping $des3Decrypt]}
276        }
277
278        # Pad the message out with null bytes.
279        append message "\0\0\0\0\0\0\0\0"
280
281        # Store the result here
282        set result {};
283        set tempresult {};
284
285        # CBC mode
286        if {$mode == 1} {
287            # Is the initialization/feedback vector variable is valid?
288            if {[string length $iv] < 1} {
289                error "An initialization variable must be specified."
290            } else {
291                upvar $iv ivec
292                if {![info exists ivec]} {
293                    error "The variable $iv does not exist."
294                }
295                if {[string length $ivec] != 8} {
296                    return -code error "invalid initialization vector size:\
297                        the initialization vector must be 8 bytes"
298                }
299            }
300            # Use the input vector as the intial vector.
301            binary scan $ivec H8H8 cbcleftTemp cbcrightTemp
302            set cbcleft "0x$cbcleftTemp"
303            set cbcright "0x$cbcrightTemp"
304        }
305
306        # Loop through each 64 bit chunk of the message
307        while {$m < $len} {
308            binary scan $message x${m}H8H8 lefttemp righttemp
309            set left {}
310            append left "0x" $lefttemp
311            set right {}
312            append right "0x" $righttemp
313            incr m 8
314
315            #puts "Left start: $left";
316            #puts "Right start: $right";
317            # For Cipher Block Chaining mode, xor the
318            # message with the previous result.
319            if {$mode == 1} {
320                if {$encrypt} {
321                    set left [expr {$left ^ $cbcleft}]
322                    set right [expr {$right ^ $cbcright}]
323                } else {
324                    set cbcleft2 $cbcleft;
325                    set cbcright2 $cbcright;
326                    set cbcleft $left;
327                    set cbcright $right;
328                }
329            }
330
331            #puts "Left mode: $left";
332            #puts "Right mode: $right";
333            #puts "cbcleft: $cbcleft";
334            #puts "cbcleft2: $cbcleft2";
335            #puts "cbcright: $cbcright";
336            #puts "cbcright2: $cbcright2";
337
338            # First each 64 but chunk of the message
339            # must be permuted according to IP.
340            set temp [expr {(($left >> 4) ^ $right) & 0x0f0f0f0f}];
341            set right [expr {$right ^ $temp}];
342            set left [expr {$left ^ ($temp << 4)}];
343            set temp [expr {(($left >> 16) ^ $right) & 0x0000ffff}];
344            set right [expr {$right ^ $temp}];
345            set left [expr {$left ^ ($temp << 16)}];
346            set temp [expr {(($right >> 2) ^ $left) & 0x33333333}];
347            set left [expr {$left ^ $temp}]
348            set right [expr {$right ^ ($temp << 2)}];
349
350            set temp [expr {(($right >> 8) ^ $left) & 0x00ff00ff}];
351            set left [expr {$left ^ $temp}];
352            set right [expr {$right ^ ($temp << 8)}];
353            set temp [expr {(($left >> 1) ^ $right) & 0x55555555}];
354            set right [expr {$right ^ $temp}];
355            set left [expr {$left ^ ($temp << 1)}];
356
357            set left [expr {((($left << 1) & 0xffffffff) | \
358                                 (($left >> 31) & 0x00000001))}];
359            set right [expr {((($right << 1) & 0xffffffff) | \
360                                  (($right >> 31) & 0x00000001))}];
361
362            #puts "Left IP: [format %x $left]";
363            #puts "Right IP: [format %x $right]";
364
365            # Do this either 1 or 3 times for each chunk of the message
366            for {set j 0} {$j < $iterations} {incr j 3} {
367                set endloop [lindex $looping [expr {$j + 1}]];
368                set loopinc [lindex $looping [expr {$j + 2}]];
369
370                #puts "endloop: $endloop";
371                #puts "loopinc: $loopinc";
372
373                # Now go through and perform the encryption or decryption 
374                for {set i [lindex $looping $j]} \
375                    {$i != $endloop} {incr i $loopinc} {
376                    # For efficiency
377                    set right1 [expr {$right ^ [lindex $keys $i]}];
378                    set right2 [expr {((($right >> 4) & 0x0fffffff) | \
379                                           (($right << 28) & 0xffffffff)) ^ \
380                                          [lindex $keys [expr {$i + 1}]]}];
381 
382                    # puts "right1: [format %x $right1]";
383                    # puts "right2: [format %x $right2]";
384
385                    # The result is attained by passing these
386                    # bytes through the S selection functions.
387                    set temp $left;
388                    set left $right;
389                    set right [expr {$temp ^ ([lindex $spfunction2 [expr {($right1 >> 24) & 0x3f}]] | \
390                                                  [lindex $spfunction4 [expr {($right1 >> 16) & 0x3f}]] | \
391                                                  [lindex $spfunction6 [expr {($right1 >>  8) & 0x3f}]] | \
392                                                  [lindex $spfunction8 [expr {$right1 & 0x3f}]] | \
393                                                  [lindex $spfunction1 [expr {($right2 >> 24) & 0x3f}]] | \
394                                                  [lindex $spfunction3 [expr {($right2 >> 16) & 0x3f}]] | \
395                                                  [lindex $spfunction5 [expr {($right2 >>  8) & 0x3f}]] | \
396                                                  [lindex $spfunction7 [expr {$right2 & 0x3f}]])}];
397 
398                    # puts "Left iter: [format %x $left]";
399                    # puts "Right iter: [format %x $right]";
400
401                }
402                set temp $left;
403                set left $right;
404                set right $temp; # Unreverse left and right
405            }; # For either 1 or 3 iterations
406
407            #puts "Left Iterated: [format %x $left]";
408            #puts "Right Iterated: [format %x $right]";
409
410            # Move then each one bit to the right
411            set left [expr {((($left >> 1) & 0x7fffffff) \
412                                 | (($left << 31) & 0xffffffff))}];
413            set right [expr {((($right >> 1) & 0x7fffffff) \
414                                  | (($right << 31) & 0xffffffff))}];
415
416            #puts "Left shifted: [format %x $left]";
417            #puts "Right shifted: [format %x $right]";
418
419            # Now perform IP-1, which is IP in the opposite direction
420            set temp [expr {((($left >> 1) & 0x7fffffff) ^ $right) & 0x55555555}];
421            set right [expr {$right ^ $temp}];
422            set left [expr {$left ^ ($temp << 1)}];
423            set temp [expr {((($right >> 8) & 0x00ffffff) ^ $left) & 0x00ff00ff}];
424            set left [expr {$left ^ $temp}];
425            set right [expr {$right ^ ($temp << 8)}];
426            set temp [expr {((($right >> 2) & 0x3fffffff) ^ $left) & 0x33333333}];
427            set left [expr {$left ^ $temp}];
428            set right [expr {$right ^ ($temp << 2)}];
429            set temp [expr {((($left >> 16) & 0x0000ffff) ^ $right) & 0x0000ffff}];
430            set right [expr {$right ^ $temp}];
431            set left [expr {$left ^ ($temp << 16)}];
432            set temp [expr {((($left >> 4) & 0x0fffffff) ^ $right) & 0x0f0f0f0f}];
433            set right [expr {$right ^ $temp}];
434            set left [expr {$left ^ ($temp << 4)}];
435
436            #puts "Left IP-1: [format %x $left]";
437            #puts "Right IP-1: [format %x $right]";
438
439            # For Cipher Block Chaining mode, xor
440            # the message with the previous result.
441            if {$mode == 1} {
442                if {$encrypt} {
443                    set cbcleft $left;
444                    set cbcright $right;
445                } else {
446                    set left [expr {$left ^ $cbcleft2}];
447                    set right [expr {$right ^ $cbcright2}];
448                }
449            }
450
451            append tempresult \
452                [binary format H16 [format %08x%08x $left $right]]
453
454            #puts "Left final: [format %x $left]";
455            #puts "Right final: [format %x $right]";
456
457            incr chunk 8;
458            if {$chunk == 512} {
459                append result $tempresult
460                set tempresult {};
461                set chunk 0;
462            }
463        }; # For every 8 characters, or 64 bits in the message
464
465        if {$mode == 1} {
466            if {$encrypt} {
467                # Save the left and right registers to the feedback vector.
468                set ivec [binary format H* \
469                              [format %08x $left][format %08x $right]]
470            } else {
471                set ivec [binary format H* \
472                              [format %08x $cbcleft][format %08x $cbcright]]
473            }
474        }
475
476        # Return the result as an array
477        return ${result}$tempresult
478    }; # End of block
479
480    # Procedure: stream - DES CFB and OFB mode support
481    # Inputs:
482    #   keyset   : Handle to an existing keyset.
483    #   message  : String to be encrypted or decrypted (Note: The length of the
484    #              string is dependent upon the value of kbits.  Remember that
485    #              the string is part of a stream of data, so it must be sized
486    #              properly for subsequent encryptions/decryptions to be
487    #              correct.  See the man page for correct message lengths for
488    #              values of kbits).
489    #   encrypt  : Perform encryption (1) or decryption (0)
490    #   mode     : DES mode 0=OFB, 1=CFB.
491    #   iv       : Name of variable containing the initialization vector.  The
492    #              value must be 64 bits in length with the first 64-L bits set
493    #              to zero.
494    #   kbits    : Number of bits in a data block (default of 64).
495    # Output:
496    #   The encrypted or decrypted data string.
497    proc stream {keyset message encrypt mode iv {kbits 64}} {
498        variable spfunction1
499        variable spfunction2
500        variable spfunction3
501        variable spfunction4
502        variable spfunction5
503        variable spfunction6
504        variable spfunction7
505        variable spfunction8
506        variable desEncrypt
507        variable des3Encrypt
508        variable keysets
509
510        # Determine if the keyset handle is valid.
511        if {[array names keysets $keyset] != {}} {
512            # Acquire the 16 or 48 subkeys we will need.
513            set keys $keysets($keyset)
514        } else {
515            error "The keyset handle \"$keyset\" is invalid!"
516        }
517
518        # Is the initialization/feedback vector variable is valid?
519        if {[string length $iv] < 1} {
520            error "An initialization variable must be specified."
521        } else {
522            upvar $iv ivec
523            if {![info exists ivec]} {
524                error "The variable $iv does not exist."
525            }
526        }
527
528        # Determine if message length (in bits)
529        # is not an integral number of kbits.
530        set len [string length $message];
531        #puts "len: $len, kbits: $kbits"
532        if {($kbits < 1) || ($kbits > 64)} {
533            error "The valid values of kbits are 1 through 64."
534        } elseif {($kbits % 8) != 0} {
535            set blockSize [expr {$kbits + (8 - ($kbits % 8))}]
536            set fail [expr {(($len * 8) / $blockSize) % $kbits}]
537        } else {
538            set blockSize [expr {$kbits / 8}]
539            set fail [expr {$len % $blockSize}]
540        }
541        if {$fail} {
542            error "Data length (in bits) is not an integral number of kbits."
543        }
544
545        set m 0
546        set n 0
547        set chunk 0;
548        # Set up the loops for single and triple des
549        set iterations [expr {[llength $keys] == 32 ? 3 : 9}];
550        if {$iterations == 3} {
551            set looping $desEncrypt
552        } else {
553            set looping $des3Encrypt
554        }
555
556        # Set up shifting values.  Used for both CFB and OFB modes.
557        if {$kbits < 32} {
558            # Only some bits from left output are needed.
559            set kOutShift [expr {32 - $kbits}]
560            set kOutMask [expr {0x7fffffff >> (31 - $kbits)}]
561            # Determine number of message bytes needed per iteration.
562            set msgBytes [expr {int(ceil(double($kbits) / 8.0))}]
563            # Determine number of message bits needed per iteration.
564            set msgBits [expr {$msgBytes * 8}]
565            set msgBitsSub1 [expr {$msgBits - 1}]
566            # Define bit caches.
567            set bitCacheIn {}
568            set bitCacheOut {}
569            # Variable used to remove bits 0 through
570            # kbits-1 in the input bit cache.
571            set kbitsSub1 [expr {$kbits - 1}]
572            # Variable used to remove leading dummy binary bits.
573            set xbits [expr {32 - $kbits}]
574        } elseif {$kbits == 32} {
575            # Only bits of left output are used.
576            # Four messages bytes are needed per iteration.
577            set msgBytes 4
578            set xbits 32
579        } elseif {$kbits < 64} {
580            # All bits from left output are needed.
581            set kOutShiftLeft [expr {$kbits - 32}]
582            # Some bits from right output are needed.
583            set kOutShiftRight [expr {64 - $kbits}]
584            set kOutMaskRight [expr {0x7fffffff >> (63 - $kbits)}]
585            # Determine number of message bytes needed per iteration.
586            set msgBytes [expr {int(ceil(double($kbits) / 8.0))}]
587            # Determine number of message bits needed per iteration.
588            set msgBits [expr {$msgBytes * 8}]
589            set msgBitsSub1 [expr {$msgBits - 1}]
590            # Define bit caches.
591            set bitCacheIn {}
592            set bitCacheOut {}
593            # Variable used to remove bits 0 through
594            # kbits-1 in the input bit cache.
595            set kbitsSub1 [expr {$kbits - 1}]
596            # Variable used to remove leading dummy binary bits.
597            set xbits [expr {64 - $kbits}]
598        } else {
599            # All 64 bits of output are used.
600            # Eight messages bytes are needed per iteration.
601            set msgBytes 8
602            set xbits 0
603        }
604
605        # Store the result here
606        set result {}
607        set tempresult {}
608
609        # Set up the initialization vector bitstream
610        binary scan $ivec H8H8 leftTemp rightTemp
611        set left "0x$leftTemp"
612        set right "0x$rightTemp"
613        #puts "Retrieved Feedback vector: $fbvec"
614        #puts "Start: |$left| |$right|"
615       
616        # Loop through each 64 bit chunk of the message
617        while {$m < $len} {
618            # puts "Left start: $left";
619            # puts "Right start: $right";
620
621            # First each 64 but chunk of the
622            # message must be permuted according to IP.
623            set temp [expr {(($left >> 4) ^ $right) & 0x0f0f0f0f}];
624            set right [expr {$right ^ $temp}];
625            set left [expr {$left ^ ($temp << 4)}];
626            set temp [expr {(($left >> 16) ^ $right) & 0x0000ffff}];
627            set right [expr {$right ^ $temp}];
628            set left [expr {$left ^ ($temp << 16)}];
629            set temp [expr {(($right >> 2) ^ $left) & 0x33333333}];
630            set left [expr {$left ^ $temp}];
631            set right [expr {$right ^ ($temp << 2)}];
632
633            set temp [expr {(($right >> 8) ^ $left) & 0x00ff00ff}];
634            set left [expr {$left ^ $temp}];
635            set right [expr {$right ^ ($temp << 8)}];
636            set temp [expr {(($left >> 1) ^ $right) & 0x55555555}];
637            set right [expr {$right ^ $temp}];
638            set left [expr {$left ^ ($temp << 1)}];
639
640            set left [expr {((($left << 1) & 0xffffffff) | \
641                                 (($left >> 31) & 0x00000001))}];
642            set right [expr {((($right << 1) & 0xffffffff) | \
643                                  (($right >> 31) & 0x00000001))}];
644
645            #puts "Left IP: [format %x $left]";
646            #puts "Right IP: [format %x $right]";
647
648            # Do this either 1 or 3 times for each chunk of the message
649            for {set j 0} {$j < $iterations} {incr j 3} {
650                set endloop [lindex $looping [expr {$j + 1}]];
651                set loopinc [lindex $looping [expr {$j + 2}]];
652
653                #puts "endloop: $endloop";
654                #puts "loopinc: $loopinc";
655
656                # Now go through and perform the encryption or decryption 
657                for {set i [lindex $looping $j]} \
658                    {$i != $endloop} {incr i $loopinc} {
659                    # For efficiency
660                    set right1 [expr {$right ^ [lindex $keys $i]}];
661                    set right2 [expr {((($right >> 4) & 0x0fffffff) | \
662                                           (($right << 28) & 0xffffffff)) ^ \
663                                          [lindex $keys [expr {$i + 1}]]}];
664 
665                    # puts "right1: [format %x $right1]";
666                    # puts "right2: [format %x $right2]";
667
668                    # The result is attained by passing these
669                    # bytes through the S selection functions.
670                    set temp $left;
671                    set left $right;
672                    set right [expr {$temp ^ ([lindex $spfunction2 [expr {($right1 >> 24) & 0x3f}]] | \
673                                                  [lindex $spfunction4 [expr {($right1 >> 16) & 0x3f}]] | \
674                                                  [lindex $spfunction6 [expr {($right1 >>  8) & 0x3f}]] | \
675                                                  [lindex $spfunction8 [expr {$right1 & 0x3f}]] | \
676                                                  [lindex $spfunction1 [expr {($right2 >> 24) & 0x3f}]] | \
677                                                  [lindex $spfunction3 [expr {($right2 >> 16) & 0x3f}]] | \
678                                                  [lindex $spfunction5 [expr {($right2 >>  8) & 0x3f}]] | \
679                                                  [lindex $spfunction7 [expr {$right2 & 0x3f}]])}];
680 
681                    # puts "Left iter: [format %x $left]";
682                    # puts "Right iter: [format %x $right]";
683
684                }
685                set temp $left;
686                set left $right;
687                set right $temp; # Unreverse left and right
688            }; # For either 1 or 3 iterations
689
690            #puts "Left Iterated: [format %x $left]";
691            #puts "Right Iterated: [format %x $right]";
692
693            # Move then each one bit to the right
694            set left [expr {((($left >> 1) & 0x7fffffff) | \
695                                 (($left << 31) & 0xffffffff))}];
696            set right [expr {((($right >> 1) & 0x7fffffff) | \
697                                  (($right << 31) & 0xffffffff))}];
698
699            #puts "Left shifted: [format %x $left]";
700            #puts "Right shifted: [format %x $right]";
701
702            # Now perform IP-1, which is IP in the opposite direction
703            set temp [expr {((($left >> 1) & 0x7fffffff) ^ $right) & 0x55555555}];
704            set right [expr {$right ^ $temp}];
705            set left [expr {$left ^ ($temp << 1)}];
706            set temp [expr {((($right >> 8) & 0x00ffffff) ^ $left) & 0x00ff00ff}];
707            set left [expr {$left ^ $temp}];
708            set right [expr {$right ^ ($temp << 8)}];
709            set temp [expr {((($right >> 2) & 0x3fffffff) ^ $left) & 0x33333333}];
710            set left [expr {$left ^ $temp}];
711            set right [expr {$right ^ ($temp << 2)}];
712            set temp [expr {((($left >> 16) & 0x0000ffff) ^ $right) & 0x0000ffff}];
713            set right [expr {$right ^ $temp}];
714            set left [expr {$left ^ ($temp << 16)}];
715            set temp [expr {((($left >> 4) & 0x0fffffff) ^ $right) & 0x0f0f0f0f}];
716            set right [expr {$right ^ $temp}];
717            set left [expr {$left ^ ($temp << 4)}];
718
719            #puts "Left IP-1: [format %x $left]";
720            #puts "Right IP-1: [format %x $right]";
721
722            # Extract the "kbits" most significant bits from the output block.
723            if {$kbits < 32} {
724                # Only some bits from left output are needed.
725                set kData [expr {($left >> $kOutShift) & $kOutMask}]
726                set newBits {}
727                # If necessary, copy message bytes into input bit cache.
728                if {([string length $bitCacheIn] < $kbits) && ($n < $len)} {
729                    if {$len - $n < $msgBytes} {
730                        set lastBits [expr {($len - $n) * 8}]
731                        ###puts -nonewline [binary scan $message x${n}B$lastBits newBits]
732                        binary scan $message x${n}B$lastBits newBits
733                    } else {
734                        # Extract "msgBytes" whole bytes as bits
735                        ###puts -nonewline [binary scan $message x${n}B$msgBits newBits]
736                        binary scan $message x${n}B$msgBits newBits
737                    }
738                    incr n $msgBytes
739                    #puts " $newBits  $n [expr {$len - $n}]"
740                    # Add the bits to the input bit cache.
741                    append bitCacheIn $newBits
742                }
743                #puts -nonewline "In bit cache: $bitCacheIn"
744                # Set up message data from input bit cache.
745                binary scan [binary format B32 [format %032s [string range $bitCacheIn 0 $kbitsSub1]]] H8 temp
746                set msgData "0x$temp"
747                # Mix message bits with crypto bits.
748                set mixData [expr {$msgData ^ $kData}]
749                # Discard collected bits from the input bit cache.
750                set bitCacheIn [string range $bitCacheIn $kbits end]
751                #puts "  After: $bitCacheIn"
752                # Convert back to a bit stream and append to the output bit cache.
753                # Only the lower kbits are wanted.
754                binary scan [binary format H8 [format %08x $mixData]] B32 msgOut
755                append bitCacheOut [string range $msgOut $xbits end]
756                #puts -nonewline "Out bit cache: $bitCacheOut"
757                # If there are sufficient bits, move bytes to the temporary holding string.
758                if {[string length $bitCacheOut] >= $msgBits} {
759                    append tempresult [binary format B$msgBits [string range $bitCacheOut 0 $msgBitsSub1]]
760                    set bitCacheOut [string range $bitCacheOut $msgBits end]
761                    #puts -nonewline "  After: $bitCacheOut"
762                    incr m $msgBytes
763                    ###puts "$m bytes output"
764                    incr chunk $msgBytes
765                }
766                #puts ""
767                # For CFB mode
768                if {$mode == 1} {
769                    if {$encrypt} {
770                        set temp [expr {($right << $kbits) & 0xffffffff}]
771                        set left [expr {(($left << $kbits) & 0xffffffff) | (($right >> $kOutShift) & $kOutMask)}]
772                        set right [expr {$temp | $mixData}]
773                    } else {
774                        set temp [expr {($right << $kbits) & 0xffffffff}]
775                        set left [expr {(($left << $kbits) & 0xffffffff) | (($right >> $kOutShift) & $kOutMask)}]
776                        set right [expr {$temp | $msgData}]
777                    }
778                }
779            } elseif {$kbits == 32} {
780                # Only bits of left output are used.
781                set kData $left
782                # Four messages bytes are needed per iteration.
783                binary scan $message x${m}H8 temp
784                incr m 4
785                incr chunk 4
786                set msgData "0x$temp"
787                # Mix message bits with crypto bits.
788                set mixData [expr {$msgData ^ $kData}]
789                # Move bytes to the temporary holding string.
790                append tempresult [binary format H8 [format %08x $mixData]]
791                # For CFB mode
792                if {$mode == 1} {
793                    set left $right
794                    if {$encrypt} {
795                        set right $mixData
796                    } else {
797                        set right $msgData
798                    }
799                }
800            } elseif {$kbits < 64} {
801                set kDataLeft [expr {($left >> $kOutShiftRight) & $kOutMaskRight}]
802                set temp [expr {($left << $kOutShiftLeft) & 0xffffffff}]
803                set kDataRight [expr {(($right >> $kOutShiftRight) & $kOutMaskRight) | $temp}]
804                # If necessary, copy message bytes into input bit cache.
805                if {([string length $bitCacheIn] < $kbits)  && ($n < $len)} {
806                    if {$len - $n < $msgBytes} {
807                        set lastBits [expr {($len - $n) * 8}]
808                        ###puts -nonewline [binary scan $message x${n}B$lastBits newBits]
809                        binary scan $message x${n}B$lastBits newBits
810                    } else {
811                        # Extract "msgBytes" whole bytes as bits
812                        ###puts -nonewline [binary scan $message x${n}B$msgBits newBits]
813                        binary scan $message x${n}B$msgBits newBits
814                    }
815                    incr n $msgBytes
816                    # Add the bits to the input bit cache.
817                    append bitCacheIn $newBits
818                }
819                # Set up message data from input bit cache.
820                # puts "Bits from cache: [set temp [string range $bitCacheIn 0 $kbitsSub1]]"
821                # puts "Length of bit string: [string length $temp]"
822                binary scan [binary format B64 [format %064s [string range $bitCacheIn 0 $kbitsSub1]]] H8H8 leftTemp rightTemp
823                set msgDataLeft "0x$leftTemp"
824                set msgDataRight "0x$rightTemp"
825                # puts "msgDataLeft: $msgDataLeft"
826                # puts "msgDataRight: $msgDataRight"
827                # puts "kDataLeft: [format 0x%08x $kDataLeft]"
828                # puts "kDataRight: [format 0x%08x $kDataRight]"
829                # Mix message bits with crypto bits.
830                set mixDataLeft [expr {$msgDataLeft ^ $kDataLeft}]
831                set mixDataRight [expr {$msgDataRight ^ $kDataRight}]
832                # puts "mixDataLeft: $mixDataLeft"
833                # puts "mixDataRight: $mixDataRight"
834                # puts "mixDataLeft: [format 0x%08x $mixDataLeft]"
835                # puts "mixDataRight: [format 0x%08x $mixDataRight]"
836                # Discard collected bits from the input bit cache.
837                set bitCacheIn [string range $bitCacheIn $kbits end]
838                # Convert back to a bit stream and
839                # append to the output bit cache.
840                # Only the lower kbits are wanted.
841                binary scan \
842                    [binary format H8H8 \
843                         [format %08x $mixDataLeft] \
844                         [format %08x $mixDataRight]] B64 msgOut
845                append bitCacheOut [string range $msgOut $xbits end]
846                # If there are sufficient bits, move
847                # bytes to the temporary holding string.
848                if {[string length $bitCacheOut] >= $msgBits} {
849                    append tempresult \
850                        [binary format B$msgBits \
851                             [string range $bitCacheOut 0 $msgBitsSub1]]
852                    set bitCacheOut [string range $bitCacheOut $msgBits end]
853                    incr m $msgBytes
854                    incr chunk $msgBytes
855                }
856                # For CFB mode
857                if {$mode == 1} {
858                    if {$encrypt} {
859                        set temp \
860                            [expr {($right << $kOutShiftRight) & 0xffffffff}]
861                        set left [expr {$temp | $mixDataLeft}]
862                        set right $mixDataRight
863                    } else {
864                        set temp \
865                            [expr {($right << $kOutShiftRight) & 0xffffffff}]
866                        set left [expr {$temp | $msgDataLeft}]
867                        set right $msgDataRight
868                    }
869                }
870            } else {
871                # All 64 bits of output are used.
872                set kDataLeft $left
873                set kDataRight $right
874                # Eight messages bytes are needed per iteration.
875                binary scan $message x${m}H8H8 leftTemp rightTemp
876                incr m 8
877                incr chunk 8
878                set msgDataLeft "0x$leftTemp"
879                set msgDataRight "0x$rightTemp"
880                # Mix message bits with crypto bits.
881                set mixDataLeft [expr {$msgDataLeft ^ $kDataLeft}]
882                set mixDataRight [expr {$msgDataRight ^ $kDataRight}]
883                # Move bytes to the temporary holding string.
884                append tempresult \
885                    [binary format H16 \
886                         [format %08x%08x $mixDataLeft $mixDataRight]]
887                # For CFB mode
888                if {$mode == 1} {
889                    if {$encrypt} {
890                        set left $mixDataLeft
891                        set right $mixDataRight
892                    } else {
893                        set left $msgDataLeft
894                        set right $msgDataRight
895                    }
896                }
897            }
898
899            #puts "Left final: [format %x $left]";
900            #puts "Right final: [format %x $right]";
901
902            if {$chunk >= 512} {
903                append result $tempresult
904                set tempresult {};
905                set chunk 0;
906            }
907        }; # For every 8 characters, or 64 bits in the message
908        #puts "End: |[format 0x%08x $left]| |[format 0x%08x $right]|"
909        # Save the left and right registers to the feedback vector.
910        set ivec [binary format H* [format %08x $left][format %08x $right]]
911        #puts "Saved Feedback vector: $fbvectors($fbvector)"
912
913        append result $tempresult
914        if {[string length $result] > $len} {
915            set result [string replace $result $len end]
916        }
917        # Return the result as an array
918        return $result
919    }; # End of stream
920
921    variable pc2bytes0 [list 0 0x4 0x20000000 0x20000004 0x10000 0x10004 0x20010000 0x20010004 0x200 0x204 0x20000200 0x20000204 0x10200 0x10204 0x20010200 0x20010204]
922    variable pc2bytes1 [list 0 0x1 0x100000 0x100001 0x4000000 0x4000001 0x4100000 0x4100001 0x100 0x101 0x100100 0x100101 0x4000100 0x4000101 0x4100100 0x4100101]
923    variable pc2bytes2 [list 0 0x8 0x800 0x808 0x1000000 0x1000008 0x1000800 0x1000808 0 0x8 0x800 0x808 0x1000000 0x1000008 0x1000800 0x1000808]
924    variable pc2bytes3 [list 0 0x200000 0x8000000 0x8200000 0x2000 0x202000 0x8002000 0x8202000 0x20000 0x220000 0x8020000 0x8220000 0x22000 0x222000 0x8022000 0x8222000]
925    variable pc2bytes4 [list 0 0x40000 0x10 0x40010 0 0x40000 0x10 0x40010 0x1000 0x41000 0x1010 0x41010 0x1000 0x41000 0x1010 0x41010]
926    variable pc2bytes5 [list 0 0x400 0x20 0x420 0 0x400 0x20 0x420 0x2000000 0x2000400 0x2000020 0x2000420 0x2000000 0x2000400 0x2000020 0x2000420]
927    variable pc2bytes6 [list 0 0x10000000 0x80000 0x10080000 0x2 0x10000002 0x80002 0x10080002 0 0x10000000 0x80000 0x10080000 0x2 0x10000002 0x80002 0x10080002]
928    variable pc2bytes7 [list 0 0x10000 0x800 0x10800 0x20000000 0x20010000 0x20000800 0x20010800 0x20000 0x30000 0x20800 0x30800 0x20020000 0x20030000 0x20020800 0x20030800]
929    variable pc2bytes8 [list 0 0x40000 0 0x40000 0x2 0x40002 0x2 0x40002 0x2000000 0x2040000 0x2000000 0x2040000 0x2000002 0x2040002 0x2000002 0x2040002]
930    variable pc2bytes9 [list 0 0x10000000 0x8 0x10000008 0 0x10000000 0x8 0x10000008 0x400 0x10000400 0x408 0x10000408 0x400 0x10000400 0x408 0x10000408]
931    variable pc2bytes10 [list 0 0x20 0 0x20 0x100000 0x100020 0x100000 0x100020 0x2000 0x2020 0x2000 0x2020 0x102000 0x102020 0x102000 0x102020]
932    variable pc2bytes11 [list 0 0x1000000 0x200 0x1000200 0x200000 0x1200000 0x200200 0x1200200 0x4000000 0x5000000 0x4000200 0x5000200 0x4200000 0x5200000 0x4200200 0x5200200]
933    variable pc2bytes12 [list 0 0x1000 0x8000000 0x8001000 0x80000 0x81000 0x8080000 0x8081000 0x10 0x1010 0x8000010 0x8001010 0x80010 0x81010 0x8080010 0x8081010]
934    variable pc2bytes13 [list 0 0x4 0x100 0x104 0 0x4 0x100 0x104 0x1 0x5 0x101 0x105 0x1 0x5 0x101 0x105]
935
936    # Now define the left shifts which need to be done
937    variable shifts {0  0  1  1  1  1  1  1  0  1  1  1  1  1  1  0};
938
939    # Procedure: createKeys
940    # Input:
941    #   key     : The 64-bit DES key or the 192-bit 3DES key
942    #             (Note: The lsb of each byte is ignored; odd parity
943    #             is not required).
944    #
945    #   weak:   If true then weak keys are allowed. The default is to raise an
946    #           error when a weak key is seen.
947    # Output:
948    # The 16 (DES) or 48 (3DES) subkeys.
949    proc createKeys {key {weak 0}} {
950        variable pc2bytes0
951        variable pc2bytes1
952        variable pc2bytes2
953        variable pc2bytes3
954        variable pc2bytes4
955        variable pc2bytes5
956        variable pc2bytes6
957        variable pc2bytes7
958        variable pc2bytes8
959        variable pc2bytes9
960        variable pc2bytes10
961        variable pc2bytes11
962        variable pc2bytes12
963        variable pc2bytes13
964        variable shifts
965
966        # How many iterations (1 for des, 3 for triple des)
967        set iterations [expr {([string length $key] >= 24) ? 3 : 1}];
968        # Stores the return keys
969        set keys {}
970        # Other variables
971        set lefttemp {}; set righttemp {}
972        set m 0
973        # Either 1 or 3 iterations
974        for {set j 0} {$j < $iterations} {incr j} {
975            binary scan $key x${m}H8H8 lefttemp righttemp
976            set left {}
977            append left "0x" $lefttemp
978            set right {}
979            append right "0x" $righttemp
980            incr m 8
981
982            #puts "Left key: $left"
983            #puts "Right key: $right"
984
985            # Test for weak keys
986            if {! $weak} {
987                set maskedLeft [expr {$left & 0xfefefefe}]
988                set maskedRight [expr {$right & 0xfefefefe}]
989                if {($maskedLeft == 0x00000000) \
990                        && ($maskedRight == 0x00000000)} {
991                    error "Key [expr {$j + 1}] is weak!"
992                } elseif {($maskedLeft == 0x1e1e1e1e) \
993                              && ($maskedRight == 0x0e0e0e0e)} {
994                    error "Key [expr {$j + 1}] is weak!"
995                } elseif {($maskedLeft == 0xe0e0e0e0) \
996                              && ($maskedRight == 0xf0f0f0f0)} {
997                    error "Key [expr {$j + 1}] is weak!"
998                } elseif {($maskedLeft == 0xfefefefe) \
999                              && ($maskedRight == 0xfefefefe)} {
1000                    error "Key [expr {$j + 1}] is weak!"
1001                }
1002            }
1003
1004            set temp [expr {(($left >> 4) ^ $right) & 0x0f0f0f0f}]
1005            set right [expr {$right ^ $temp}]
1006            set left [expr {$left ^ ($temp << 4)}]
1007            set temp [expr {(($right >> 16) ^ $left) & 0x0000ffff}]
1008            set left [expr {$left ^ $temp}]
1009            set right [expr {$right ^ ($temp << 16)}]
1010            set temp [expr {(($left >> 2) ^ $right) & 0x33333333}]
1011            set right [expr {$right ^ $temp}]
1012            set left [expr {$left ^ ($temp << 2)}]
1013            set temp [expr {(($right >> 16) ^ $left) & 0x0000ffff}]
1014            set left [expr {$left ^ $temp}]
1015            set right [expr {$right ^ ($temp << 16)}]
1016            set temp [expr {(($left >> 1) ^ $right) & 0x55555555}]
1017            set right [expr {$right ^ $temp}]
1018            set left [expr {$left ^ ($temp << 1)}]
1019            set temp [expr {(($right >> 8) ^ $left) & 0x00ff00ff}]
1020            set left [expr {$left ^ $temp}]
1021            set right [expr {$right ^ ($temp << 8)}]
1022            set temp [expr {(($left >> 1) ^ $right) & 0x55555555}]
1023            set right [expr {$right ^ $temp}]
1024            set left [expr {$left ^ ($temp << 1)}]
1025           
1026            #puts "Left key PC1: [format %x $left]"
1027            #puts "Right key PC1: [format %x $right]"
1028
1029            # The right side needs to be shifted and to get
1030            # the last four bits of the left side
1031            set temp [expr {($left << 8) | (($right >> 20) & 0x000000f0)}];
1032            # Left needs to be put upside down
1033            set left [expr {($right << 24) | (($right << 8) & 0x00ff0000) | \
1034                                (($right >> 8) & 0x0000ff00) \
1035                                | (($right >> 24) & 0x000000f0)}];
1036            set right $temp;
1037
1038            #puts "Left key juggle: [format %x $left]"
1039            #puts "Right key juggle: [format %x $right]"
1040
1041            # Now go through and perform these
1042            # shifts on the left and right keys.
1043            foreach i $shifts  {
1044                # Shift the keys either one or two bits to the left.
1045                if {$i} {
1046                    set left [expr {($left << 2) \
1047                                        | (($left >> 26) & 0x0000003f)}];
1048                    set right [expr {($right << 2) \
1049                                         | (($right >> 26) & 0x0000003f)}];
1050                } else {
1051                    set left [expr {($left << 1) \
1052                                        | (($left >> 27) & 0x0000001f)}];
1053                    set right [expr {($right << 1) \
1054                                         | (($right >> 27) & 0x0000001f)}];
1055                }
1056                set left [expr {$left & 0xfffffff0}];
1057                set right [expr {$right & 0xfffffff0}];
1058
1059                # Now apply PC-2, in such a way that E is easier when
1060                # encrypting or decrypting this conversion will look like PC-2
1061                # except only the last 6 bits of each byte are used rather than
1062                # 48 consecutive bits and the order of lines will be according
1063                # to how the S selection functions will be applied: S2, S4, S6,
1064                # S8, S1, S3, S5, S7.
1065                set lefttemp [expr {[lindex $pc2bytes0 [expr {($left >> 28) & 0x0000000f}]] | \
1066                                        [lindex $pc2bytes1 [expr {($left >> 24) & 0x0000000f}]] | \
1067                                        [lindex $pc2bytes2 [expr {($left >> 20) & 0x0000000f}]] | \
1068                                        [lindex $pc2bytes3 [expr {($left >> 16) & 0x0000000f}]] | \
1069                                        [lindex $pc2bytes4 [expr {($left >> 12) & 0x0000000f}]] | \
1070                                        [lindex $pc2bytes5 [expr {($left >> 8) & 0x0000000f}]] | \
1071                                        [lindex $pc2bytes6 [expr {($left >> 4) & 0x0000000f}]]}];
1072                set righttemp [expr {[lindex $pc2bytes7 [expr {($right >> 28) & 0x0000000f}]] | \
1073                                         [lindex $pc2bytes8 [expr {($right >> 24) & 0x0000000f}]] | \
1074                                         [lindex $pc2bytes9 [expr {($right >> 20) & 0x0000000f}]] | \
1075                                         [lindex $pc2bytes10 [expr {($right >> 16) & 0x0000000f}]] | \
1076                                         [lindex $pc2bytes11 [expr {($right >> 12) & 0x0000000f}]] | \
1077                                         [lindex $pc2bytes12 [expr {($right >> 8) & 0x0000000f}]] | \
1078                                         [lindex $pc2bytes13 [expr {($right >> 4) & 0x0000000f}]]}];
1079                set temp [expr {(($righttemp >> 16) ^ $lefttemp) & 0x0000ffff}];
1080                lappend keys [expr {$lefttemp ^ $temp}];
1081                lappend keys [expr {$righttemp ^ ($temp << 16)}];
1082            }
1083        }; # For each iteration.
1084        # Return the keys we've created.
1085        return $keys;
1086    }; # End of createKeys.
1087}; # End of des namespace eval.
1088
1089package provide tclDES 1.0.0
Note: See TracBrowser for help on using the repository browser.