TextSweep

Check-in [2e6360a121]
Login

Many hyperlinks are disabled.
Use anonymous login to enable hyperlinks.

Overview
Comment:Refine listing of files to elimimnate binary non-text files
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA1:2e6360a1212a5b8f46297cee90b8c2df1e5246df
User & Date: kevin 2018-04-25 03:01:16
Context
2018-04-25
03:01
Tweak build check-in: 24bd7be413 user: kevin tags: trunk
03:01
Refine listing of files to elimimnate binary non-text files check-in: 2e6360a121 user: kevin tags: trunk
2018-04-24
02:39
Fix typos in license check-in: 391db8288f user: kevin tags: trunk
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to buildapp.

158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182

hdiutil create  -srcfolder build -fs HFS+ -volname TextSweep TextSweep.dmg

codesign  --signature-size 9400 -f -s "Developer ID Application: Kevin Walzer" --verbose=2  TextSweep.dmg

echo "Uploading DMG..."

upload TextSweep.dmg updates

upload textsweep-changes.tcl

upload textsweep-version.tcl


cd ../

#create archive of entire source tree
tar cvfz TextSweep-$1.tgz TextSweep



echo "Done."










|

|

|













158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182

hdiutil create  -srcfolder build -fs HFS+ -volname TextSweep TextSweep.dmg

codesign  --signature-size 9400 -f -s "Developer ID Application: Kevin Walzer" --verbose=2  TextSweep.dmg

echo "Uploading DMG..."

#upload TextSweep.dmg updates

#upload textsweep-changes.tcl

#upload textsweep-version.tcl


cd ../

#create archive of entire source tree
tar cvfz TextSweep-$1.tgz TextSweep



echo "Done."



Changes to scriptlibs/machelp/help.txt.

163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179

-------------------
title: License
alias: License
 
'''The MIT License (MIT)'''

TextSweep source code: [http://fossil.codebykevin.com/fossil.cgi/textsweep/]

Copyright (c) 2018 WordTech Communications LLC

Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions:

The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software.

THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.








|









163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179

-------------------
title: License
alias: License
 
'''The MIT License (MIT)'''

TextSweep source code: [https://www.codebykevin.com/fossil.cgi/textsweep/]

Copyright (c) 2018 WordTech Communications LLC

Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions:

The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software.

THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.

Deleted scriptlibs/tcllib1.12/aes/aes.tcl.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
# aes.tcl - 
#
# Copyright (c) 2005 Thorsten Schloermann
# Copyright (c) 2005 Pat Thoyts <patthoyts@users.sourceforge.net>
#
# A Tcl implementation of the Advanced Encryption Standard (US FIPS PUB 197)
#
# AES is a block cipher with a block size of 128 bits and a variable
# key size of 128, 192 or 256 bits.
# The algorithm works on each block as a 4x4 state array. There are 4 steps
# in each round:
#   SubBytes    a non-linear substitution step using a predefined S-box
#   ShiftRows   cyclic transposition of rows in the state matrix
#   MixColumns  transformation upon columns in the state matrix
#   AddRoundKey application of round specific sub-key
#
# -------------------------------------------------------------------------
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# -------------------------------------------------------------------------

package require Tcl 8.2

namespace eval ::aes {
    variable version 1.0.1
    variable rcsid {$Id: aes.tcl,v 1.6 2008/05/12 23:16:09 andreas_kupries Exp $}
    variable uid ; if {![info exists uid]} { set uid 0 }

    namespace export {aes}

    # constants

    # S-box
    variable sbox {
        0x63 0x7c 0x77 0x7b 0xf2 0x6b 0x6f 0xc5 0x30 0x01 0x67 0x2b 0xfe 0xd7 0xab 0x76
        0xca 0x82 0xc9 0x7d 0xfa 0x59 0x47 0xf0 0xad 0xd4 0xa2 0xaf 0x9c 0xa4 0x72 0xc0
        0xb7 0xfd 0x93 0x26 0x36 0x3f 0xf7 0xcc 0x34 0xa5 0xe5 0xf1 0x71 0xd8 0x31 0x15
        0x04 0xc7 0x23 0xc3 0x18 0x96 0x05 0x9a 0x07 0x12 0x80 0xe2 0xeb 0x27 0xb2 0x75
        0x09 0x83 0x2c 0x1a 0x1b 0x6e 0x5a 0xa0 0x52 0x3b 0xd6 0xb3 0x29 0xe3 0x2f 0x84
        0x53 0xd1 0x00 0xed 0x20 0xfc 0xb1 0x5b 0x6a 0xcb 0xbe 0x39 0x4a 0x4c 0x58 0xcf
        0xd0 0xef 0xaa 0xfb 0x43 0x4d 0x33 0x85 0x45 0xf9 0x02 0x7f 0x50 0x3c 0x9f 0xa8
        0x51 0xa3 0x40 0x8f 0x92 0x9d 0x38 0xf5 0xbc 0xb6 0xda 0x21 0x10 0xff 0xf3 0xd2
        0xcd 0x0c 0x13 0xec 0x5f 0x97 0x44 0x17 0xc4 0xa7 0x7e 0x3d 0x64 0x5d 0x19 0x73
        0x60 0x81 0x4f 0xdc 0x22 0x2a 0x90 0x88 0x46 0xee 0xb8 0x14 0xde 0x5e 0x0b 0xdb
        0xe0 0x32 0x3a 0x0a 0x49 0x06 0x24 0x5c 0xc2 0xd3 0xac 0x62 0x91 0x95 0xe4 0x79
        0xe7 0xc8 0x37 0x6d 0x8d 0xd5 0x4e 0xa9 0x6c 0x56 0xf4 0xea 0x65 0x7a 0xae 0x08
        0xba 0x78 0x25 0x2e 0x1c 0xa6 0xb4 0xc6 0xe8 0xdd 0x74 0x1f 0x4b 0xbd 0x8b 0x8a
        0x70 0x3e 0xb5 0x66 0x48 0x03 0xf6 0x0e 0x61 0x35 0x57 0xb9 0x86 0xc1 0x1d 0x9e
        0xe1 0xf8 0x98 0x11 0x69 0xd9 0x8e 0x94 0x9b 0x1e 0x87 0xe9 0xce 0x55 0x28 0xdf
        0x8c 0xa1 0x89 0x0d 0xbf 0xe6 0x42 0x68 0x41 0x99 0x2d 0x0f 0xb0 0x54 0xbb 0x16
    }
    # inverse S-box
    variable xobs {
        0x52 0x09 0x6a 0xd5 0x30 0x36 0xa5 0x38 0xbf 0x40 0xa3 0x9e 0x81 0xf3 0xd7 0xfb
        0x7c 0xe3 0x39 0x82 0x9b 0x2f 0xff 0x87 0x34 0x8e 0x43 0x44 0xc4 0xde 0xe9 0xcb
        0x54 0x7b 0x94 0x32 0xa6 0xc2 0x23 0x3d 0xee 0x4c 0x95 0x0b 0x42 0xfa 0xc3 0x4e
        0x08 0x2e 0xa1 0x66 0x28 0xd9 0x24 0xb2 0x76 0x5b 0xa2 0x49 0x6d 0x8b 0xd1 0x25
        0x72 0xf8 0xf6 0x64 0x86 0x68 0x98 0x16 0xd4 0xa4 0x5c 0xcc 0x5d 0x65 0xb6 0x92
        0x6c 0x70 0x48 0x50 0xfd 0xed 0xb9 0xda 0x5e 0x15 0x46 0x57 0xa7 0x8d 0x9d 0x84
        0x90 0xd8 0xab 0x00 0x8c 0xbc 0xd3 0x0a 0xf7 0xe4 0x58 0x05 0xb8 0xb3 0x45 0x06
        0xd0 0x2c 0x1e 0x8f 0xca 0x3f 0x0f 0x02 0xc1 0xaf 0xbd 0x03 0x01 0x13 0x8a 0x6b
        0x3a 0x91 0x11 0x41 0x4f 0x67 0xdc 0xea 0x97 0xf2 0xcf 0xce 0xf0 0xb4 0xe6 0x73
        0x96 0xac 0x74 0x22 0xe7 0xad 0x35 0x85 0xe2 0xf9 0x37 0xe8 0x1c 0x75 0xdf 0x6e
        0x47 0xf1 0x1a 0x71 0x1d 0x29 0xc5 0x89 0x6f 0xb7 0x62 0x0e 0xaa 0x18 0xbe 0x1b
        0xfc 0x56 0x3e 0x4b 0xc6 0xd2 0x79 0x20 0x9a 0xdb 0xc0 0xfe 0x78 0xcd 0x5a 0xf4
        0x1f 0xdd 0xa8 0x33 0x88 0x07 0xc7 0x31 0xb1 0x12 0x10 0x59 0x27 0x80 0xec 0x5f
        0x60 0x51 0x7f 0xa9 0x19 0xb5 0x4a 0x0d 0x2d 0xe5 0x7a 0x9f 0x93 0xc9 0x9c 0xef
        0xa0 0xe0 0x3b 0x4d 0xae 0x2a 0xf5 0xb0 0xc8 0xeb 0xbb 0x3c 0x83 0x53 0x99 0x61
        0x17 0x2b 0x04 0x7e 0xba 0x77 0xd6 0x26 0xe1 0x69 0x14 0x63 0x55 0x21 0x0c 0x7d
    }
}

# aes::Init --
#
#	Initialise our AES state and calculate the key schedule. An initialization
#	vector is maintained in the state for modes that require one. The key must
#	be binary data of the correct size and the IV must be 16 bytes.
#
#	Nk: columns of the key-array
#	Nr: number of rounds (depends on key-length)
#	Nb: columns of the text-block, is always 4 in AES
#
proc ::aes::Init {mode key iv} {
    switch -exact -- $mode {
        ecb - cbc { }
        cfb - ofb {
            return -code error "$mode mode not implemented"
        }
        default {
            return -code error "invalid mode \"$mode\":\
                must be one of ecb or cbc."
        }
    }

    set size [expr {[string length $key] << 3}]
    switch -exact -- $size {
        128 {set Nk 4; set Nr 10; set Nb 4}
        192 {set Nk 6; set Nr 12; set Nb 4}
        256 {set Nk 8; set Nr 14; set Nb 4}
        default {
            return -code error "invalid key size \"$size\":\
                must be one of 128, 192 or 256."
        }
    }

    variable uid
    set Key [namespace current]::[incr uid]
    upvar #0 $Key state
    array set state [list M $mode K $key I $iv Nk $Nk Nr $Nr Nb $Nb W {}]
    ExpandKey $Key
    return $Key
}

# aes::Reset --
#
#	Reset the initialization vector for the specified key. This permits the
#	key to be reused for encryption or decryption without the expense of
#	re-calculating the key schedule.
#
proc ::aes::Reset {Key iv} {
    upvar #0 $Key state
    set state(I) $iv
    return
}
    
# aes::Final --
#
#	Clean up the key state
#
proc ::aes::Final {Key} {
    # FRINK: nocheck
    unset $Key
}

# -------------------------------------------------------------------------

# 5.1 Cipher:  Encipher a single block of 128 bits.
proc ::aes::EncryptBlock {Key block} {
    upvar #0 $Key state
    if {[binary scan $block I4 data] != 1} {
        return -code error "invalid block size: blocks must be 16 bytes"
    }

    if {[string equal $state(M) cbc]} {
        if {[binary scan $state(I) I4 iv] != 1} {
            return -code error "invalid initialization vector: must be 16 bytes"
        }
        for {set n 0} {$n < 4} {incr n} {
            lappend data2 [expr {0xffffffff & ([lindex $data $n] ^ [lindex $iv $n])}]
        }
        set data $data2
    }

    set data [AddRoundKey $Key 0 $data]
    for {set n 1} {$n < $state(Nr)} {incr n} {
        set data [AddRoundKey $Key $n [MixColumns [ShiftRows [SubBytes $data]]]]
    }
    set data [AddRoundKey $Key $n [ShiftRows [SubBytes $data]]]
    return [set state(I) [binary format I4 $data]]
}

# 5.3: Inverse Cipher: Decipher a single 128 bit block.
proc ::aes::DecryptBlock {Key block} {
    upvar #0 $Key state
    if {[binary scan $block I4 data] != 1} {
        return -code error "invalid block size: block must be 16 bytes"
    }

    set n $state(Nr)
    set data [AddRoundKey $Key $state(Nr) $data]
    for {incr n -1} {$n > 0} {incr n -1} {
        set data [InvMixColumns [AddRoundKey $Key $n [InvSubBytes [InvShiftRows $data]]]]
    }
    set data [AddRoundKey $Key $n [InvSubBytes [InvShiftRows $data]]]
    
    if {[string equal $state(M) cbc]} {
        if {[binary scan $state(I) I4 iv] != 1} {
            return -code error "invalid initialization vector: must be 16 bytes"
        }
        for {set n 0} {$n < 4} {incr n} {
            lappend data2 [expr {0xffffffff & ([lindex $data $n] ^ [lindex $iv $n])}]
        }
        set data $data2
    }
    
    set state(I) $block
    return [binary format I4 $data]
}

# 5.2: KeyExpansion
proc ::aes::ExpandKey {Key} {
    upvar #0 $Key state
    set Rcon [list 0x00000000 0x01000000 0x02000000 0x04000000 0x08000000 \
                  0x10000000 0x20000000 0x40000000 0x80000000 0x1b000000 \
                  0x36000000 0x6c000000 0xd8000000 0xab000000 0x4d000000]
    # Split the key into Nk big-endian words
    binary scan $state(K) I* W
    set max [expr {$state(Nb) * ($state(Nr) + 1)}]
    set i $state(Nk)
    set h $state(Nk) ; incr h -1
    set j 0
    for {} {$i < $max} {incr i; incr h; incr j} {
        set temp [lindex $W $h]
        if {($i % $state(Nk)) == 0} {
            set sub [SubWord [RotWord $temp]]
            set rc [lindex $Rcon [expr {$i/$state(Nk)}]]
            set temp [expr {$sub ^ $rc}]
        } elseif {$state(Nk) > 6 && ($i % $state(Nk)) == 4} { 
            set temp [SubWord $temp]
        }
        lappend W [expr {[lindex $W $j] ^ $temp}]
    }
    set state(W) $W
    return
}

# 5.2: Key Expansion: Apply S-box to each byte in the 32 bit word
proc ::aes::SubWord {w} {
    variable sbox
    set s3 [lindex $sbox [expr {(($w >> 24) & 255)}]]
    set s2 [lindex $sbox [expr {(($w >> 16) & 255)}]]
    set s1 [lindex $sbox [expr {(($w >> 8 ) & 255)}]]
    set s0 [lindex $sbox [expr {( $w        & 255)}]]
    return [expr {($s3 << 24) | ($s2 << 16) | ($s1 << 8) | $s0}]
}

proc ::aes::InvSubWord {w} {
    variable xobs
    set s3 [lindex $xobs [expr {(($w >> 24) & 255)}]]
    set s2 [lindex $xobs [expr {(($w >> 16) & 255)}]]
    set s1 [lindex $xobs [expr {(($w >> 8 ) & 255)}]]
    set s0 [lindex $xobs [expr {( $w        & 255)}]]
    return [expr {($s3 << 24) | ($s2 << 16) | ($s1 << 8) | $s0}]
}

# 5.2: Key Expansion: Rotate a 32bit word by 8 bits
proc ::aes::RotWord {w} {
    return [expr {(($w << 8) | (($w >> 24) & 0xff)) & 0xffffffff}]
}

# 5.1.1: SubBytes() Transformation
proc ::aes::SubBytes {words} {
    set r {}
    foreach w $words {
        lappend r [SubWord $w]
    }
    return $r
}

# 5.3.2: InvSubBytes() Transformation
proc ::aes::InvSubBytes {words} {
    set r {}
    foreach w $words {
        lappend r [InvSubWord $w]
    }
    return $r
}

# 5.1.2: ShiftRows() Transformation
proc ::aes::ShiftRows {words} {
    for {set n0 0} {$n0 < 4} {incr n0} {
        set n1 [expr {($n0 + 1) % 4}]
        set n2 [expr {($n0 + 2) % 4}]
        set n3 [expr {($n0 + 3) % 4}]
        lappend r [expr {(  [lindex $words $n0] & 0xff000000)
                         | ([lindex $words $n1] & 0x00ff0000)
                         | ([lindex $words $n2] & 0x0000ff00)
                         | ([lindex $words $n3] & 0x000000ff)
                     }]
    }
    return $r
}


# 5.3.1: InvShiftRows() Transformation
proc ::aes::InvShiftRows {words} {
    for {set n0 0} {$n0 < 4} {incr n0} {
        set n1 [expr {($n0 + 1) % 4}]
        set n2 [expr {($n0 + 2) % 4}]
        set n3 [expr {($n0 + 3) % 4}]
        lappend r [expr {(  [lindex $words $n0] & 0xff000000)
                         | ([lindex $words $n3] & 0x00ff0000)
                         | ([lindex $words $n2] & 0x0000ff00)
                         | ([lindex $words $n1] & 0x000000ff)
                     }]
    }
    return $r
}

# 5.1.3: MixColumns() Transformation
proc ::aes::MixColumns {words} {
    set r {}
    foreach w $words {
        set r0 [expr {(($w >> 24) & 255)}]
        set r1 [expr {(($w >> 16) & 255)}]
        set r2 [expr {(($w >> 8 ) & 255)}]
        set r3 [expr {( $w        & 255)}]

        set s0 [expr {[GFMult2 $r0] ^ [GFMult3 $r1] ^ $r2 ^ $r3}]
        set s1 [expr {$r0 ^ [GFMult2 $r1] ^ [GFMult3 $r2] ^ $r3}]
        set s2 [expr {$r0 ^ $r1 ^ [GFMult2 $r2] ^ [GFMult3 $r3]}]
        set s3 [expr {[GFMult3 $r0] ^ $r1 ^ $r2 ^ [GFMult2 $r3]}]

        lappend r [expr {($s0 << 24) | ($s1 << 16) | ($s2 << 8) | $s3}]
    }
    return $r
}

# 5.3.3: InvMixColumns() Transformation
proc ::aes::InvMixColumns {words} {
    set r {}
    foreach w $words {
        set r0 [expr {(($w >> 24) & 255)}]
        set r1 [expr {(($w >> 16) & 255)}]
        set r2 [expr {(($w >> 8 ) & 255)}]
        set r3 [expr {( $w        & 255)}]

        set s0 [expr {[GFMult0e $r0] ^ [GFMult0b $r1] ^ [GFMult0d $r2] ^ [GFMult09 $r3]}]
        set s1 [expr {[GFMult09 $r0] ^ [GFMult0e $r1] ^ [GFMult0b $r2] ^ [GFMult0d $r3]}]
        set s2 [expr {[GFMult0d $r0] ^ [GFMult09 $r1] ^ [GFMult0e $r2] ^ [GFMult0b $r3]}]
        set s3 [expr {[GFMult0b $r0] ^ [GFMult0d $r1] ^ [GFMult09 $r2] ^ [GFMult0e $r3]}]

        lappend r [expr {($s0 << 24) | ($s1 << 16) | ($s2 << 8) | $s3}]
    }
    return $r
}

# 5.1.4: AddRoundKey() Transformation
proc ::aes::AddRoundKey {Key round words} {
    upvar #0 $Key state
    set r {}
    set n [expr {$round * $state(Nb)}]
    foreach w $words {
        lappend r [expr {$w ^ [lindex $state(W) $n]}]
        incr n
    }
    return $r
}
    
# -------------------------------------------------------------------------
# ::aes::GFMult*
#
#	some needed functions for multiplication in a Galois-field
#
proc ::aes::GFMult2 {number} {
    # this is a tabular representation of xtime (multiplication by 2)
    # it is used instead of calculation to prevent timing attacks
    set xtime {
        0x00 0x02 0x04 0x06 0x08 0x0a 0x0c 0x0e 0x10 0x12 0x14 0x16 0x18 0x1a 0x1c 0x1e
        0x20 0x22 0x24 0x26 0x28 0x2a 0x2c 0x2e 0x30 0x32 0x34 0x36 0x38 0x3a 0x3c 0x3e 
        0x40 0x42 0x44 0x46 0x48 0x4a 0x4c 0x4e 0x50 0x52 0x54 0x56 0x58 0x5a 0x5c 0x5e
        0x60 0x62 0x64 0x66 0x68 0x6a 0x6c 0x6e 0x70 0x72 0x74 0x76 0x78 0x7a 0x7c 0x7e 
        0x80 0x82 0x84 0x86 0x88 0x8a 0x8c 0x8e 0x90 0x92 0x94 0x96 0x98 0x9a 0x9c 0x9e 
        0xa0 0xa2 0xa4 0xa6 0xa8 0xaa 0xac 0xae 0xb0 0xb2 0xb4 0xb6 0xb8 0xba 0xbc 0xbe 
        0xc0 0xc2 0xc4 0xc6 0xc8 0xca 0xcc 0xce 0xd0 0xd2 0xd4 0xd6 0xd8 0xda 0xdc 0xde 
        0xe0 0xe2 0xe4 0xe6 0xe8 0xea 0xec 0xee 0xf0 0xf2 0xf4 0xf6 0xf8 0xfa 0xfc 0xfe 
        0x1b 0x19 0x1f 0x1d 0x13 0x11 0x17 0x15 0x0b 0x09 0x0f 0x0d 0x03 0x01 0x07 0x05 
        0x3b 0x39 0x3f 0x3d 0x33 0x31 0x37 0x35 0x2b 0x29 0x2f 0x2d 0x23 0x21 0x27 0x25 
        0x5b 0x59 0x5f 0x5d 0x53 0x51 0x57 0x55 0x4b 0x49 0x4f 0x4d 0x43 0x41 0x47 0x45 
        0x7b 0x79 0x7f 0x7d 0x73 0x71 0x77 0x75 0x6b 0x69 0x6f 0x6d 0x63 0x61 0x67 0x65 
        0x9b 0x99 0x9f 0x9d 0x93 0x91 0x97 0x95 0x8b 0x89 0x8f 0x8d 0x83 0x81 0x87 0x85 
        0xbb 0xb9 0xbf 0xbd 0xb3 0xb1 0xb7 0xb5 0xab 0xa9 0xaf 0xad 0xa3 0xa1 0xa7 0xa5 
        0xdb 0xd9 0xdf 0xdd 0xd3 0xd1 0xd7 0xd5 0xcb 0xc9 0xcf 0xcd 0xc3 0xc1 0xc7 0xc5 
        0xfb 0xf9 0xff 0xfd 0xf3 0xf1 0xf7 0xf5 0xeb 0xe9 0xef 0xed 0xe3 0xe1 0xe7 0xe5
    }
    return [lindex $xtime $number]
}

proc ::aes::GFMult3 {number} {
    # multliply by 2 (via GFMult2) and add the number again on the result (via XOR)
    return [expr {$number ^ [GFMult2 $number]}]
}

proc ::aes::GFMult09 {number} {
    # 09 is: (02*02*02) + 01
    return [expr {[GFMult2 [GFMult2 [GFMult2 $number]]] ^ $number}]
}

proc ::aes::GFMult0b {number} {
    # 0b is: (02*02*02) + 02 + 01
    #return [expr [GFMult2 [GFMult2 [GFMult2 $number]]] ^ [GFMult2 $number] ^ $number]
    #set g0 [GFMult2 $number]
    return [expr {[GFMult09 $number] ^ [GFMult2 $number]}]
}

proc ::aes::GFMult0d {number} {
    # 0d is: (02*02*02) + (02*02) + 01
    set temp [GFMult2 [GFMult2 $number]]
    return [expr {[GFMult2 $temp] ^ ($temp ^ $number)}]
}

proc ::aes::GFMult0e {number} {
    # 0e is: (02*02*02) + (02*02) + 02
    set temp [GFMult2 [GFMult2 $number]]
    return [expr {[GFMult2 $temp] ^ ($temp ^ [GFMult2 $number])}]
}

# -------------------------------------------------------------------------

# aes::Encrypt --
#
#	Encrypt a blocks of plain text and returns blocks of cipher text.
#	The input data must be a multiple of the block size (16).
#
proc ::aes::Encrypt {Key data} {
    set len [string length $data]
    if {($len % 16) != 0} {
        return -code error "invalid block size: AES requires 16 byte blocks"
    }

    set result {}
    for {set i 0} {$i < $len} {incr i 1} {
        set block [string range $data $i [incr i 15]]
        append result [EncryptBlock $Key $block]
    }
    return $result
}

# aes::DecryptBlock --
#
#	Decrypt a blocks of cipher text and returns blocks of plain text.
#	The input data must be a multiple of the block size (16).
#
proc ::aes::Decrypt {Key data} {
    set len [string length $data]
    if {($len % 16) != 0} {
        return -code error "invalid block size: AES requires 16 byte blocks"
    }

    set result {}
    for {set i 0} {$i < $len} {incr i 1} {
        set block [string range $data $i [incr i 15]]
        append result [DecryptBlock $Key $block]
    }
    return $result
}

# -------------------------------------------------------------------------
# Fileevent handler for chunked file reading.
#
proc ::aes::Chunk {Key in {out {}} {chunksize 4096}} {
    upvar #0 $Key state
    
    if {[eof $in]} {
        fileevent $in readable {}
        set state(reading) 0
    }

    set data [read $in $chunksize]
    # FIX ME: we should ony pad after eof
    set data [Pad $data 16]
    
    if {$out == {}} {
        append state(output) [$state(cmd) $Key $data]
    } else {
        puts -nonewline $out [$state(cmd) $Key $data]
    }
}

proc ::aes::SetOneOf {lst item} {
    set ndx [lsearch -glob $lst "${item}*"]
    if {$ndx == -1} {
        set err [join $lst ", "]
        return -code error "invalid mode \"$item\": must be one of $err"
    }
    return [lindex $lst $ndx]
}

proc ::aes::CheckSize {what size thing} {
    if {[string length $thing] != $size} {
        return -code error "invalid value for $what: must be $size bytes long"
    }
    return $thing
}

proc ::aes::Pad {data blocksize {fill \0}} {
    set len [string length $data]
    if {$len == 0} {
        set data [string repeat $fill $blocksize]
    } elseif {($len % $blocksize) != 0} {
        set pad [expr {$blocksize - ($len % $blocksize)}]
        append data [string repeat $fill $pad]
    }
    return $data
}

proc ::aes::Pop {varname {nth 0}} {
    upvar 1 $varname args
    set r [lindex $args $nth]
    set args [lreplace $args $nth $nth]
    return $r
}

proc ::aes::Hex {data} {
    binary scan $data H* r
    return $r 
}

proc ::aes::aes {args} {
    array set opts {-dir encrypt -mode cbc -key {} -in {} -out {} -chunksize 4096 -hex 0}
    set opts(-iv) [string repeat \0 16]
    set modes {ecb cbc}
    set dirs {encrypt decrypt}
    while {[string match -* [set option [lindex $args 0]]]} {
        switch -exact -- $option {
            -mode      { set opts(-mode) [SetOneOf $modes [Pop args 1]] }
            -dir       { set opts(-dir) [SetOneOf $dirs [Pop args 1]] }
            -iv        { set opts(-iv) [CheckSize -iv 16 [Pop args 1]] }
            -key       { set opts(-key) [Pop args 1] }
            -in        { set opts(-in) [Pop args 1] }
            -out       { set opts(-out) [Pop args 1] }
            -chunksize { set opts(-chunksize) [Pop args 1] }
            -hex       { set opts(-hex) 1 }
            --         { Pop args ; break }
            default {
                set err [join [lsort [array names opts]] ", "]
                return -code error "bad option \"$option\":\
                    must be one of $err"
            }
        }
        Pop args
    }

    if {$opts(-key) == {}} {
        return -code error "no key provided: the -key option is required"
    }

    set r {}
    if {$opts(-in) == {}} {

        if {[llength $args] != 1} {
            return -code error "wrong \# args:\
                should be \"aes ?options...? -key keydata plaintext\""
        }

        set data [Pad [lindex $args 0] 16]
        set Key [Init $opts(-mode) $opts(-key) $opts(-iv)]
        if {[string equal $opts(-dir) "encrypt"]} {
            set r [Encrypt $Key $data]
        } else {
            set r [Decrypt $Key $data]
        }

        if {$opts(-out) != {}} {
            puts -nonewline $opts(-out) $r
            set r {}
        }
        Final $Key

    } else {

        if {[llength $args] != 0} {
            return -code error "wrong \# args:\
                should be \"aes ?options...? -key keydata -in channel\""
        }

        set Key [Init $opts(-mode) $opts(-key) $opts(-iv)]
        upvar 1 $Key state
        set state(reading) 1
        if {[string equal $opts(-dir) "encrypt"]} {
            set state(cmd) Encrypt
        } else {
            set state(cmd) Decrypt
        }
        set state(output) ""
        fileevent $opts(-in) readable \
            [list [namespace origin Chunk] \
                 $Key $opts(-in) $opts(-out) $opts(-chunksize)]
        if {[info commands ::tkwait] != {}} {
            tkwait variable [subst $Key](reading)
        } else {
            vwait [subst $Key](reading)
        }
        if {$opts(-out) == {}} {
            set r $state(output)
        }
        Final $Key

    }

    if {$opts(-hex)} {
        set r [Hex $r]
    }
    return $r
}

# -------------------------------------------------------------------------

package provide aes $::aes::version

# -------------------------------------------------------------------------
# Local variables:
# mode: tcl
# indent-tabs-mode: nil
# End:
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<






































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































Deleted scriptlibs/tcllib1.12/aes/pkgIndex.tcl.

1
2
3
4
5
if {![package vsatisfies [package provide Tcl] 8.2]} {
    # PRAGMA: returnok
    return
}
package ifneeded aes 1.0.1 [list source [file join $dir aes.tcl]]
<
<
<
<
<










Deleted scriptlibs/tcllib1.12/amazon-s3/S3.tcl.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
1483
1484
1485
1486
1487
1488
1489
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
1613
1614
1615
1616
1617
1618
1619
1620
1621
1622
1623
1624
1625
1626
1627
1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
1656
1657
1658
1659
1660
1661
1662
1663
1664
1665
1666
1667
1668
1669
1670
1671
1672
1673
1674
1675
1676
1677
1678
1679
1680
1681
1682
1683
1684
1685
1686
1687
1688
1689
1690
1691
1692
1693
1694
1695
1696
1697
1698
1699
1700
1701
1702
1703
1704
1705
1706
1707
1708
1709
1710
1711
1712
1713
1714
1715
1716
1717
1718
1719
1720
1721
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
1736
1737
1738
1739
1740
1741
1742
1743
1744
1745
1746
1747
1748
1749
1750
1751
1752
1753
1754
1755
1756
1757
1758
1759
1760
1761
1762
1763
1764
1765
1766
1767
1768
1769
1770
1771
1772
1773
1774
1775
1776
1777
1778
1779
1780
1781
1782
1783
1784
1785
1786
1787
1788
1789
1790
1791
1792
1793
1794
1795
1796
1797
1798
1799
1800
1801
1802
1803
1804
1805
1806
1807
1808
1809
1810
1811
1812
1813
1814
1815
1816
1817
1818
1819
1820
1821
1822
1823
1824
1825
1826
1827
1828
1829
1830
1831
1832
1833
1834
1835
1836
1837
1838
1839
1840
1841
1842
1843
1844
1845
1846
1847
1848
1849
1850
1851
1852
1853
1854
1855
1856
1857
1858
1859
1860
1861
1862
1863
1864
1865
1866
1867
1868
1869
1870
1871
1872
1873
1874
1875
1876
1877
1878
1879
1880
1881
1882
1883
1884
1885
1886
1887
1888
1889
1890
1891
1892
1893
1894
1895
1896
1897
1898
1899
1900
1901
1902
1903
1904
1905
1906
1907
1908
1909
1910
1911
1912
1913
1914
1915
1916
1917
1918
1919
1920
1921
1922
1923
1924
1925
1926
1927
1928
1929
1930
1931
1932
1933
1934
1935
1936
1937
1938
1939
1940
1941
1942
1943
1944
1945
1946
1947
1948
1949
1950
1951
1952
1953
1954
1955
1956
1957
1958
1959
1960
# S3.tcl
# 
###Abstract
# This presents an interface to Amazon's S3 service.
# The Amazon S3 service allows for reliable storage
# and retrieval of data via HTTP.
#
# Copyright (c) 2006,2008 Darren New. All Rights Reserved.
#
###Copyright
# NO WARRANTIES OF ANY TYPE ARE PROVIDED.
# COPYING OR USE INDEMNIFIES THE AUTHOR IN ALL WAYS.
#
# This software is licensed under essentially the same 
# terms as Tcl. See LICENSE.txt for the terms.
#
###Revision String
# SCCS: %Z% %M% %I% %E% %U%
# 
###Change history:
# 0.7.2 - added -default-bucket.
# 0.8.0 - fixed bug in getLocal using wrong prefix.
#         Upgraded to Tcl 8.5 release version.
# 1.0.0 - added SetAcl, GetAcl, and -acl keep option.
#

package require Tcl 8.5

# This is by Darren New too. 
# It is a SAX package to format XML for easy retrieval.
# It should be in the same distribution as S3.
package require xsxp

# These three are required to do the auth, so always require them.
#    Note that package registry and package fileutil are required
#    by the individual routines that need them. Grep for "package".
package require sha1
package require md5
package require base64

package provide S3 1.0.0

namespace eval S3 { 
    variable config ; # A dict for current config info.
    variable config_orig ; # Holds "reset" version.
    variable debug 0 ; # Turns on or off S3::debug
    variable debuglog 0 ; # Turns on or off debugging into a file
    variable bgvar_counter 0 ; # Makes unique names for bgvars.

    set config_orig [dict create \
        -reset false \
        -retries 3 \
        -accesskeyid "" -secretaccesskey "" \
	-service-access-point "s3.amazonaws.com" \
        -slop-seconds 3 \
	-use-tls false \
        -bucket-prefix "TclS3" \
	-default-compare "always" \
	-default-separator "/" \
	-default-acl "" \
	-default-bucket "" \
	]

    set config $config_orig
}

# Internal, for development. Print a line, and maybe log it.
proc S3::debuglogline {line} {
    variable debuglog
    puts $line
    if {$debuglog} {
	set x [open debuglog.txt a]
	puts $x $line
	close $x
    }
}

# Internal, for development. Print debug info properly formatted.
proc S3::debug {args} {
    variable debug
    variable debuglog
    if {!$debug} return
    set res ""
    if {"-hex" == [lindex $args 0]} {
	set str [lindex $args 1]
	foreach ch [split $str {}] {
	    scan $ch %c val
	    append res [format %02x $val] 
	    append res " "
	}
	debuglogline $res
	return
    } 
    if {"-dict" == [lindex $args 0]} {
	set dict [lindex $args 1]
	debuglogline "DEBUG dict:"
	foreach {key val} $dict {
	    set val [string map [list \
		\r \\r \n \\n \0 \\0 ] $val]
	    debuglogline "$key=$val"
	}
	return
    }
    set x [string map [list \
        \r \\r \n \\n \0 \\0 ] $args]
    debuglogline "DEBUG: $x"
}

# Internal. Throws an error if keys have not been initialized.
proc S3::checkinit {} {
    variable config
    set error "S3 must be initialized with -accesskeyid and -secretaccesskey before use" 
    set e1 {S3 usage -accesskeyid "S3 identification not initialized"}
    set e2 {S3 usage -secretaccesskey "S3 identification not initialized"}
    if {[dict get $config -accesskeyid] eq ""} {
	error $error "" $e1
    }
    if {[dict get $config -secretaccesskey] eq ""} { 
	error $error "" $e2
    }
}

# Internal. Calculates the Content-Type for a given file name.
# Naturally returns application/octet-stream if anything goes wrong.
proc S3::contenttype {fname} {
    if {$::tcl_platform(platform) == "windows"} {
	set extension [file extension $fname]
	uplevel #0 package require registry
	set key "\\\\HKEY_CLASSES_ROOT\\"
	set key "HKEY_CLASSES_ROOT\\"
	if {"." != [string index $extension 0]} {append key .}
	append key $extension
	set ct "application/octet-stream"
	if {$extension != ""} {
	    catch {set ct [registry get $key {Content Type}]} caught
	}
    } else {
	# Assume something like Unix.
	if {[file readable /etc/mime.types]} {
	    set extension [string trim [file extension $fname] "."]
	    set f [open /etc/mime.types r]
	    while {-1 != [gets $f line] && ![info exists c]} {
		set line [string trim $line]
		if {[string match "#*" $line]} continue
		if {0 == [string length $line]} continue
		set items [split $line]
		for {set i 1} {$i < [llength $items]} {incr i} {
		    if {[lindex $items $i] eq $extension} {
			set c [lindex $items 0]
			break
		    }
		}
	    }
	    close $f
	    if {![info exists c]} {
		set ct "application/octet-stream"
	    } else {
		set ct [string trim $c]
	    }
	} else {
	    # No /etc/mime.types here.
	    if {[catch {exec file -i $fname} res]} {
		set ct "application/octet-stream"
	    } else {
		set ct [string range $res [expr {1+[string first : $res]}] end]
		if {-1 != [string first ";" $ct]} {
		    set ct [string range $ct 0 [string first ";" $ct]]
		}
		set ct [string trim $ct "; "]
	    }
	}
    }
    return $ct
}

# Change current configuration. Not object-oriented, so only one
# configuration is tracked per interpreter.
proc S3::Configure {args} {
    variable config
    variable config_orig
    if {[llength $args] == 0} {return $config}
    if {[llength $args] == 1 && ![dict exists $config [lindex $args 0]]} {
	error "Bad option \"[lindex $args 0]\": must be [join [dict keys $config] ,\  ]" "" [list S3 usage [lindex $args 0] "Bad option to config"]
    }
    if {[llength $args] == 1} {return [dict get $config [lindex $args 0]]}
    if {[llength $args] % 2 != 0} {
	error "Config args must be -name val -name val" "" [list S3 usage [lindex $args end] "Odd number of config args"]
    }
    set new $config
    foreach {tag val} $args {
	if {![dict exists $new $tag]} {
	    error "Bad option \"$tag\": must be [join [dict keys $config] ,\  ]" "" [list S3 usage $tag "Bad option to config"]
	}
	dict set new $tag $val
	if {$tag eq "-reset" && $val} {
	    set new $config_orig
	}
    }
    if {[dict get $config -use-tls]} {
	error "TLS for S3 not yet implemented!" "" \
	    [list S3 notyet -use-tls $config]
    }
    set config $new ; # Only update if all went well
    return $config
}

# Suggest a unique bucket name based on usename and config info.
proc S3::SuggestBucket {{usename ""}} {
    checkinit
    if {$usename eq ""} {set usename [::S3::Configure -bucket-prefix]}
    if {$usename eq ""} {
	error "S3::SuggestBucket requires name or -bucket-prefix set" \
	"" [list S3 usage -bucket-prefix]
    }
    return $usename\.[::S3::Configure -accesskeyid]
}

# Calculate authorization token for REST interaction.
# Doesn't work yet for "Expires" type headers. Hence, only for "REST".
# We specifically don't call checkinit because it's called in all
# callers and we don't want to throw an error inside here.
# Caveat Emptor if you expect otherwise.
# This is internal, but useful enough you might want to invoke it.
proc S3::authREST {verb resource content-type headers args} {
    if {[llength $args] != 0} {
	set body [lindex $args 0] ; # we use [info exists] later
    }
    if {${content-type} != "" && [dict exists $headers content-type]} {
	set content-type [dict get $headers content-type]
    }
    dict unset headers content-type
    set verb [string toupper $verb]
    if {[info exists body]} {
	set content-md5 [::base64::encode [::md5::md5 $body]]
	dict set headers content-md5 ${content-md5}
	dict set headers content-length [string length $body]
    } elseif {[dict exists $headers content-md5]} {
	set content-md5 [dict get $headers content-md5]
    } else {
	set content-md5 ""
    }
    if {[dict exists $headers x-amz-date]} {
	set date ""
	dict unset headers date
    } elseif {[dict exists $headers date]} {
	set date [dict get $headers date]
    } else {
	set date [clock format [clock seconds] -gmt true -format \
	    "%a, %d %b %Y %T %Z"]
	dict set headers date $date
    }
    if {${content-type} != ""} {
	dict set headers content-type ${content-type}
    }
    set xamz ""
    foreach key [lsort [dict keys $headers x-amz-*]] {
	# Assume each is seen only once, for now, and is canonical already.
        append xamz \n[string trim $key]:[string trim [dict get $headers $key]]
    }
    set xamz [string trim $xamz]
    # Hmmm... Amazon lies. No \n after xamz if xamz is empty.
    if {0 != [string length $xamz]} {append xamz \n}
    set signthis \
        "$verb\n${content-md5}\n${content-type}\n$date\n$xamz$resource"
    S3::debug "Sign this:" $signthis ; S3::debug -hex $signthis 
    set sig [::sha1::hmac [S3::Configure -secretaccesskey] $signthis]
    set sig [binary format H* $sig]
    set sig [string trim [::base64::encode $sig]]
    dict set headers authorization "AWS [S3::Configure -accesskeyid]:$sig"
    return $headers
}

# Internal. Takes resource and parameters, tacks them together.
# Useful enough you might want to invoke it yourself.
proc S3::to_url {resource parameters} {
    if {0 == [llength $parameters]} {return $resource}
    if {-1 == [string first "?" $resource]} {
	set front ?
    } else {
	set front &
    }
    foreach {key value} $parameters {
	append resource $front $key "=" $value
	set front &
    }
    return $resource
}

# Internal. Encode a URL, including utf-8 versions.
# Useful enough you might want to invoke it yourself.
proc S3::encode_url {orig} {
    set res ""
    set re {[-a-zA-Z0-9/.,_]}
    foreach ch [split $orig ""] {
	if {[regexp $re $ch]} {
	    append res $ch
	} else {
	    foreach uch [split [encoding convertto utf-8 $ch] ""] {
		append res "%"
		binary scan $uch H2 hex
		append res $hex
	    }
	}
    }
    if {$res ne $orig} {
	S3::debug "URL Encoded:" $orig $res
    }
    return $res
}

# This is used internally to either queue an event-driven
# item or to simply call the next routine, depending on
# whether the current transaction is supposed to be running
# in the background or not.
proc S3::nextdo {routine thunk direction args} {
    global errorCode
    S3::debug "nextdo" $routine $thunk $direction $args
    if {[dict get $thunk blocking]} {
	return [S3::$routine $thunk]
    } else {
	if {[llength $args] == 2} {
	    # fcopy failed!
	    S3::fail "S3 fcopy failed: [lindex $args 1]" "" \
		[list S3 socket $errorCode]
	} else {
	    fileevent [dict get $thunk S3chan] $direction \
		[list S3::$routine $thunk]
	    if {$direction == "writable"} {
		fileevent [dict get $thunk S3chan] readable {}
	    } else {
		fileevent [dict get $thunk S3chan] writable {}
	    }
	}
    }
}

# The proverbial It.  Do a REST call to Amazon S3 service.
proc S3::REST {orig} {
    variable config
    checkinit
    set EndPoint [dict get $config -service-access-point]
    
    # Save the original stuff first.
    set thunk [dict create orig $orig]

    # Now add to thunk's top-level the important things
    if {[dict exists $thunk orig resultvar]} {
	dict set thunk blocking 0
    } else {
	dict set thunk blocking 1
    }
    if {[dict exists $thunk orig S3chan]} {
	dict set thunk S3chan [dict get $thunk orig S3chan]
    } elseif {[dict get $thunk blocking]} {
	dict set thunk S3chan [socket $EndPoint 80]
    } else {
	dict set thunk S3chan [socket -async $EndPoint 80]
    }
    fconfigure [dict get $thunk S3chan] -translation binary -encoding binary

    dict set thunk verb [dict get $thunk orig verb]
    dict set thunk resource [S3::encode_url [dict get $thunk orig resource]]
    if {[dict exists $orig rtype]} {
	dict set thunk resource \
	    [dict get $thunk resource]?[dict get $orig rtype]
    }
    if {[dict exists $orig headers]} {
	dict set thunk headers [dict get $orig headers]
    } else {
	dict set thunk headers [dict create]
    }
    if {[dict exists $orig infile]} {
	dict set thunk infile [dict get $orig infile]
    }
    if {[dict exists $orig content-type]} {
	dict set thunk content-type [dict get $orig content-type]
    } else {
	if {[dict exists $thunk infile]} {
	    set zz [dict get $thunk infile]
	} else {
	    set zz [dict get $thunk resource]
	}
	if {-1 != [string first "?" $zz]} {
	    set zz [string range $zz 0 [expr {[string first "?" $zz]-1}]]
	    set zz [string trim $zz]
	}
	if {$zz != ""} {
	    catch {dict set thunk content-type [S3::contenttype $zz]}
	} else {
	    dict set thunk content-type application/octet-stream
	    dict set thunk content-type ""
	}
    }
    set p {}
    if {[dict exist $thunk orig parameters]} {
	set p [dict get $thunk orig parameters]
    }
    dict set thunk url [S3::to_url [dict get $thunk resource] $p]

    if {[dict exists $thunk orig inbody]} {
        dict set thunk headers [S3::authREST \
            [dict get $thunk verb] [dict get $thunk resource] \
            [dict get $thunk content-type] [dict get $thunk headers] \
	    [dict get $thunk orig inbody] ]
    } else {
        dict set thunk headers [S3::authREST \
            [dict get $thunk verb] [dict get $thunk resource] \
            [dict get $thunk content-type] [dict get $thunk headers] ]
    }
    # Not the best place to put this code.
    if {![info exists body] && [dict exists $thunk infile]} {
	set size [file size [dict get $thunk infile]]
	set x [dict get $thunk headers]
	dict set x content-length $size
	dict set thunk headers $x
    }


    # Ready to go!
    return [S3::nextdo send_headers $thunk writable]
}

# Internal. Send the headers to Amazon. Might block if you have
# really small socket buffers, but Amazon doesn't want
# data that big anyway.
proc S3::send_headers {thunk} {
    S3::debug "Send-headers" $thunk 
    set s3 [dict get $thunk S3chan]
    puts $s3 "[dict get $thunk verb] [dict get $thunk url] HTTP/1.0"
    S3::debug ">> [dict get $thunk verb] [dict get $thunk url] HTTP/1.0"
    foreach {key val} [dict get $thunk headers] {
	puts $s3 "$key: $val"
	S3::debug ">> $key: $val"
    }
    puts $s3 ""
    flush $s3
    return [S3::nextdo send_body $thunk writable]
}

# Internal. Send the body to Amazon.
proc S3::send_body {thunk} {
    global errorCode
    set s3 [dict get $thunk S3chan]
    if {[dict exists $thunk orig inbody]} {
	# Send a string. Let's guess that even in non-blocking
	# mode, this is small enough or Tcl's smart enough that
	# we don't blow up the buffer.
	puts -nonewline $s3 [dict get $thunk orig inbody]
	flush $s3
	return [S3::nextdo read_headers $thunk readable]
    } elseif {![dict exists $thunk orig infile]} {
	# No body, no file, so nothing more to do.
	return [S3::nextdo read_headers $thunk readable]
    } elseif {[dict get $thunk blocking]} {
	# A blocking file copy. Still not too hard.
	if {[catch {set inchan [open [dict get $thunk infile] r]} caught]} {
	    S3::fail $thunk "S3 could not open infile - $caught" "" \
		[list S3 local [dict get $thunk infile] $errorCode]
	}
	fconfigure $inchan -translation binary -encoding binary
	fileevent $s3 readable {}
	fileevent $s3 writable {}
	if {[catch {fcopy $inchan $s3 ; flush $s3 ; close $inchan} caught]} {
	    S3::fail $thunk "S3 could not copy infile - $caught" "" \
		[list S3 local [dict get $thunk infile] $errorCode]
	}
	S3::nextdo read_headers $thunk readable
    } else {
	# The hard one. Background file copy.
	fileevent $s3 readable {}
	fileevent $s3 writable {}
	if {[catch {set inchan [open [dict get $thunk infile] r]} caught]} {
	    S3::fail $thunk "S3 could not open infile - $caught" "" \
		[list S3 local [dict get $thunk infile] $errorCode]
	}
	fconfigure $inchan -buffering none -translation binary -encoding binary
	fconfigure $s3 -buffering none -translation binary \
	    -encoding binary -blocking 0 ; # Doesn't work without this?
	dict set thunk inchan $inchan ; # So we can close it.
        fcopy $inchan $s3 -command \
	    [list S3::nextdo read_headers $thunk readable]
    }
}

# Internal. The first line has come back. Grab out the 
# stuff we care about.
proc S3::parse_status {thunk line} {
    # Got the status line
    S3::debug "<< $line"
    dict set thunk httpstatusline [string trim $line]
    dict set thunk outheaders [dict create]
    regexp {^HTTP/1.. (...) (.*)$} $line junk code message
    dict set thunk httpstatus $code
    dict set thunk httpmessage [string trim $message]
    return $thunk
}

# A line of header information has come back. Grab it.
# This probably is unhappy with multiple lines for one 
# header.
proc S3::parse_header {thunk line} {
    # Got a header line. For now, assume no continuations.
    S3::debug "<< $line"
    set line [string trim $line]
    set left [string range $line 0 [expr {[string first ":" $line]-1}]]
    set right [string range $line [expr {[string first ":" $line]+1}] end]
    set left [string trim [string tolower $left]]
    set right [string trim $right]
    dict set thunk outheaders $left $right
    return $thunk
}

# I don't know if HTTP requires a blank line after the headers if
# there's no body.

# Internal. Read all the headers, and throw if we get EOF before
# we get any headers at all.
proc S3::read_headers {thunk} {
    set s3 [dict get $thunk S3chan]
    flush $s3
    fconfigure $s3 -blocking [dict get $thunk blocking] 
    if {[dict get $thunk blocking]} {
	# Blocking. Just read to a blank line. Otherwise,
	# if we use nextdo here, we wind up nesting horribly.
	# If we're not blocking, of course, we're returning
	# to the event loop each time, so that's OK.
	set count [gets $s3 line]
	if {[eof $s3]} {
	    S3::fail $thunk "S3 EOF during status line read" "" "S3 socket EOF"
	}
	set thunk [S3::parse_status $thunk $line]
	while {[string trim $line] != ""} {
	    set count [gets $s3 line]
	    if {$count == -1 && 0 == [dict size [dict get $thunk outheaders]]} {
		S3::fail $thunk "S3 EOF during headers read" "" "S3 socket EOF"
	    }
	    if {[string trim $line] != ""} {
		set thunk [S3::parse_header $thunk $line]
	    }
	}
	return [S3::nextdo read_body $thunk readable]
    } else {
	# Non-blocking, so we have to reenter for each line.
	#  First, fix up the file handle, tho.
	if {[dict exists $thunk inchan]} {
	    close [dict get $thunk inchan]
	    dict unset thunk inchan
	}
	# Now get one header.
	set count [gets $s3 line]
	if {[eof $s3]} {
	    fileevent $s3 readable {}
	    fileevent $s3 writable {}
	    if {![dict exists $thunk httpstatusline]} {
		S3::fail $thunk "S3 EOF during status line read" "" "S3 socket EOF"
	    } elseif {0 == [dict size [dict get $thunk outheaders]]} {
		S3::fail $thunk "S3 EOF during header read" "" "S3 socket EOF"
	    }
	}
	if {$count < 0} return ; # Wait for a whole line
	set line [string trim $line]
	if {![dict exists $thunk httpstatus]} {
	    set thunk [S3::parse_status $thunk $line]
	    S3::nextdo read_headers $thunk readable ; # New thunk here.
	} elseif {$line != ""} {
	    set thunk [S3::parse_header $thunk $line]
	    S3::nextdo read_headers $thunk readable ; # New thunk here.
	} else {
	    # Got an empty line. Switch to copying the body.
	    S3::nextdo read_body $thunk readable
	}
    }
}

# Internal. Read the body of the response.
proc S3::read_body {thunk} {
    set s3 [dict get $thunk S3chan]
    if {[dict get $thunk blocking]} {
	# Easy. Just read it.
	if {[dict exists $thunk orig outchan]} {
	    fcopy $s3 [dict get $thunk orig outchan]
	} else {
	    set x [read $s3]
	    dict set thunk outbody $x
	    S3::debug "Body: $x"
	}
	return [S3::nextdo all_done $thunk readable]
    } else {
	# Nonblocking mode. 
	if {[dict exists $thunk orig outchan]} {
	    fileevent $s3 readable {}
	    fileevent $s3 writable {}
	    fcopy $s3 [dict get $thunk orig outchan] -command \
	        [list S3::nextdo all_done $thunk readable]
        } else {
            dict append thunk outbody [read $s3]
	    if {[eof $s3]} {
		# We're done.
		S3::nextdo all_done $thunk readable
	    } else {
		S3::nextdo read_body $thunk readable
	    }
	}
    }
}

# Internal. Convenience function.
proc S3::fail {thunk error errorInfo errorCode} {
    S3::all_done $thunk $error $errorInfo $errorCode
}

# Internal. We're all done the transaction. Clean up everything,
# potentially record errors, close channels, etc etc etc.
proc S3::all_done {thunk {error ""} {errorInfo ""} {errorCode ""}} {
    set s3 [dict get $thunk S3chan]
    catch {
	fileevent $s3 readable {}
	fileevent $s3 writable {}
    }
    if {![dict exists $thunk orig S3chan]} {
	catch {close $s3}
    }
    set res [dict get $thunk orig]
    catch {
	dict set res httpstatus [dict get $thunk httpstatus]
	dict set res httpmessage [dict get $thunk httpmessage]
	dict set res outheaders [dict get $thunk outheaders]
    }
    if {![dict exists $thunk orig outchan]} {
	if {[dict exists $thunk outbody]} {
	    dict set res outbody [dict get $thunk outbody]
	} else {
	    # Probably HTTP failure
	    dict set rest outbody {}
	}
    }
    if {$error ne ""} {
	dict set res error $error
	dict set res errorInfo $errorInfo
	dict set res errorCode $errorCode
    }
    if {![dict get $thunk blocking]} {
	after 0 [list uplevel #0 \
	    [list set [dict get $thunk orig resultvar] $res]]
    }
    if {$error eq "" || ![dict get $thunk blocking] || \
	([dict exists $thunk orig throwsocket] && \
	    "return" == [dict get $thunk orig throwsocket])} {
	return $res
    } else {
	error $error $errorInfo $errorCode
    }
}

# Internal. Parse the lst and make sure it has only keys from the 'valid' list.
# Used to parse arguments going into the higher-level functions.
proc S3::parseargs1 {lst valid} {
    if {[llength $lst] % 2 != 0} {
	error "Option list must be even -name val pairs" \
	    "" [list S3 usage [lindex $lst end] $lst]
    }
    foreach {key val} $lst {
	# Sadly, lsearch applies -glob to the wrong thing for our needs
	set found 0
	foreach v $valid {
	    if {[string match $v $key]} {set found 1 ; break}
	}
	if {!$found} {
	    error "Option list has invalid -key" \
		"" [list S3 usage $key $lst]
	}
    }
    return $lst ; # It seems OK
}

# Internal. Create a variable for higher-level functions to vwait.
proc S3::bgvar {} {
    variable bgvar_counter
    incr bgvar_counter
    set name ::S3::bgvar$bgvar_counter
    return $name
}

# Internal. Given a request and the arguments, run the S3::REST in
# the foreground or the background as appropriate. Also, do retries
# for internal errors.
proc S3::maybebackground {req myargs} {
    variable config
    global errorCode errorInfo
    set mytries [expr {1+[dict get $config -retries]}]
    set delay 2000
    dict set req throwsocket return
    while {1} {
	if {![dict exists $myargs -blocking] || [dict get $myargs -blocking]} {
	    set dict [S3::REST $req]
	} else {
	    set res [bgvar]
	    dict set req resultvar $res
	    S3::REST $req
	    vwait $res
	    set dict [set $res]
	    unset $res ; # clean up temps
	}
	if {[dict exists $dict error]} {
	    set code [dict get $dict errorCode]
	    if {"S3" != [lindex $code 0] || "socket" != [lindex $code 1]} {
		error [dict get $dict error] \
		    [dict get $dict errorInfo] \
		    [dict get $dict errorCode]
	    }
	}
	incr mytries -1
	incr delay $delay ; if {20000 < $delay} {set delay 20000}
	if {"500" ne [dict get $dict httpstatus] || $mytries <= 0} {
	    return $dict
	}
	if {![dict exists $myargs -blocking] || [dict get $myargs -blocking]} {
	    after $delay
	} else {
	    set timer [bgvar]
	    after $delay [list set $timer 1]
	    vwait $timer
	    unset $timer
	}
    }
}

# Internal. Maybe throw an HTTP error if httpstatus not in 200 range.
proc S3::throwhttp {dict} {
    set hs [dict get $dict httpstatus]
    if {![string match "2??" $hs]} {
	error "S3 received non-OK HTTP result of $hs"  "" \
	    [list S3 remote $hs $dict]
    }
}

# Public. Returns the list of buckets for this user.
proc S3::ListAllMyBuckets {args} {
    checkinit ; # I know this gets done later.
    set myargs [S3::parseargs1 $args {-blocking -parse-xml -result-type}]
    if {![dict exists $myargs -result-type]} {
	dict set myargs -result-type names
    }
    if {![dict exists $myargs -blocking]} {
	dict set myargs -blocking true
    }
    set restype [dict get $myargs -result-type]
    if {$restype eq "REST" && [dict exists $myargs -parse-xml]} {
	error "Do not use REST with -parse-xml" "" \
	    [list S3 usage -parse-xml $args]
    }
    if {![dict exists $myargs -parse-xml]} {
	# We need to fetch the results.
	set req [dict create verb GET resource /]
	set dict [S3::maybebackground $req $myargs]
	if {$restype eq "REST"} {
	    return $dict ; #we're done!
	}
	S3::throwhttp $dict ; #make sure it worked.
	set xml [dict get $dict outbody] 
    } else {
	set xml [dict get $myargs -parse-xml]
    }
    # Here, we either already returned the dict, or the XML is in "xml".
    if {$restype eq "xml"} {return $xml}
    if {[catch {set pxml [::xsxp::parse $xml]}]} {
	error "S3 invalid XML structure" "" [list S3 usage xml $xml]
    }
    if {$restype eq "pxml"} {return $pxml}
    if {$restype eq "dict" || $restype eq "names"} {
	set buckets [::xsxp::fetch $pxml "Buckets" %CHILDREN]
	set names {} ; set dates {}
	foreach bucket $buckets {
	    lappend names [::xsxp::fetch $bucket "Name" %PCDATA]
	    lappend dates [::xsxp::fetch $bucket "CreationDate" %PCDATA]
	}
	if {$restype eq "names"} {
	    return $names
	} else {
	    return [dict create \
		Owner/ID [::xsxp::fetch $pxml "Owner/ID" %PCDATA] \
		Owner/DisplayName \
		    [::xsxp::fetch $pxml "Owner/DisplayName" %PCDATA] \
		Bucket/Name $names Bucket/Date $dates \
	    ]
	}
    }
    if {$restype eq "owner"} {
	return [list [::xsxp::fetch $pxml Owner/ID %PCDATA] \
	    [::xsxp::fetch $pxml Owner/DisplayName %PCDATA] ]
    }
    error "ListAllMyBuckets requires -result-type to be REST, xml, pxml, dict, owner, or names" "" [list S3 usage -result-type $args]
}

# Public. Create a bucket.
proc S3::PutBucket {args} {
    checkinit
    set myargs [S3::parseargs1 $args {-blocking -bucket -acl}]
    if {![dict exists $myargs -acl]} {
	dict set myargs -acl [S3::Configure -default-acl]
    }
    if {![dict exists $myargs -bucket]} {
	dict set myargs -bucket [S3::Configure -default-bucket]
    }
    dict set myargs -bucket [string trim [dict get $myargs -bucket] "/ "]
    if {"" eq [dict exists $myargs -bucket]} {
	error "PutBucket requires -bucket" "" [list S3 usage -bucket $args]
    }

    set req [dict create verb PUT resource /[dict get $myargs -bucket]]
    if {[dict exists $myargs -acl]} {
	dict set req headers [list x-amz-acl [dict get $myargs -acl]]
    }
    set dict [S3::maybebackground $req $myargs]
    S3::throwhttp $dict
    return "" ; # until we decide what to return.
}

# Public. Delete a bucket.
proc S3::DeleteBucket {args} {
    checkinit
    set myargs [S3::parseargs1 $args {-blocking -bucket}]
    if {![dict exists $myargs -bucket]} {
	error "DeleteBucket requires -bucket" "" [list S3 usage -bucket $args]
    }
    dict set myargs -bucket [string trim [dict get $args -bucket] "/ "]

    set req [dict create verb DELETE resource /[dict get $myargs -bucket]]
    set dict [S3::maybebackground $req $myargs]
    S3::throwhttp $dict
    return "" ; # until we decide what to return.
}

# Internal. Suck out the one and only answer from the list, if needed.
proc S3::firstif {list myargs} {
    if {[dict exists $myargs -max-keys]} {
	return [lindex $list 0]
    } else {
	return $list
    }
}

# Public. Get the list of resources within a bucket.
proc S3::GetBucket {args} {
    checkinit
    set myargs [S3::parseargs1 $args {
	-bucket -blocking -parse-xml -max-keys 
	-result-type -prefix -delimiter
	-TEST
    }]
    if {![dict exists $myargs -bucket]} {
	dict set myargs -bucket [S3::Configure -default-bucket]
    }
    dict set myargs -bucket [string trim [dict get $myargs -bucket] "/ "]
    if {"" eq [dict get $myargs -bucket]} {
	error "GetBucket requires -bucket" "" [list S3 usage -bucket $args]
    }
    if {[dict get $myargs -bucket] eq ""} {
	error "GetBucket requires -bucket nonempty" "" \
	    [list S3 usage -bucket $args]
    }
    if {![dict exists $myargs -result-type]} {
	dict set myargs -result-type names
    }
    if {[dict get $myargs -result-type] eq "REST" && \
	    [dict exists $myargs "-parse-xml"]} {
	error "GetBucket can't have -parse-xml with REST result" "" \
	    [list S3 usage -parse-xml $args]
    }
    set req [dict create verb GET resource /[dict get $myargs -bucket]]
    set parameters {}
    # Now, just to make test cases easier...
    if {[dict exists $myargs -TEST]} {
	dict set parameters max-keys [dict get $myargs -TEST]
    }
    # Back to your regularly scheduled argument parsing
    if {[dict exists $myargs -max-keys]} {
	dict set parameters max-keys [dict get $myargs -max-keys]
    }
    if {[dict exists $myargs -prefix]} {
	set p [dict get $myargs -prefix]
	if {[string match "/*" $p]} {
	    set p [string range $p 1 end]
	}
	dict set parameters prefix $p
    }
    if {[dict exists $myargs -delimiter]} {
	dict set parameters delimiter [dict get $myargs -delimiter]
    }
    set nextmarker0 {} ; # We use this for -result-type dict.
    if {![dict exists $myargs -parse-xml]} {
	# Go fetch answers.
	#   Current xaction in "0" vars, with accumulation in "L" vars.
	#   Ultimate result of this loop is $RESTL, a list of REST results.
	set RESTL [list]
	while {1} {
	    set req0 $req ; dict set req0 parameters $parameters
	    set REST0 [S3::maybebackground $req0 $myargs]
	    S3::throwhttp $REST0
	    lappend RESTL $REST0
	    if {[dict exists $myargs -max-keys]} {
		# We were given a limit, so just return the answer.
		break
	    }
	    set pxml0 [::xsxp::parse [dict get $REST0 outbody]]
	    set trunc0 [expr "true" eq \
		[::xsxp::fetch $pxml0 IsTruncated %PCDATA]]
	    if {!$trunc0} {
		# We've retrieved the final block, so go parse it.
		set nextmarker0 "" ; # For later.
		break
	    }
	    # Find the highest contents entry. (Would have been
	    # easier if Amazon always supplied NextMarker.)
	    set nextmarker0 {}
	    foreach {only tag} {Contents Key CommonPrefixes Prefix} {
		set only0 [::xsxp::only $pxml0 $only]
		if {0 < [llength $only0]} {
		    set k0 [::xsxp::fetch [lindex $only0 end] $tag %PCDATA]
		    if {[string compare $nextmarker0 $k0] < 0} {
			set nextmarker0 $k0
		    }
		}
	    }
	    if {$nextmarker0 eq ""} {error "Internal Error in S3 library"}
	    # Here we have the next marker, so fetch the next REST
	    dict set parameters marker $nextmarker0
	    # Note - $nextmarker0 is used way down below again!
	}
	# OK, at this point, the caller did not provide the xml via -parse-xml
	# And now we have a list of REST results. So let's process.
	if {[dict get $myargs -result-type] eq "REST"} {
	    return [S3::firstif $RESTL $myargs]
	}
	set xmlL [list]
	foreach entry $RESTL {
	    lappend xmlL [dict get $entry outbody]
	}
	unset RESTL ; # just to save memory
    } else {
	# Well, we've parsed out the XML from the REST, 
	# so we're ready for -parse-xml
	set xmlL [list [dict get $myargs -parse-xml]]
    }
    if {[dict get $myargs -result-type] eq "xml"} {
	return [S3::firstif $xmlL $myargs]
    }
    set pxmlL [list]
    foreach xml $xmlL {
	lappend pxmlL [::xsxp::parse $xml]
    }
    unset xmlL
    if {[dict get $myargs -result-type] eq "pxml"} {
	return [S3::firstif $pxmlL $myargs]
    }
    # Here, for result types of "names" and "dict",
    # we need to actually parse out all the results.
    if {[dict get $myargs -result-type] eq "names"} {
	# The easy one.
	set names [list]
	foreach pxml $pxmlL {
	    set con0 [::xsxp::only $pxml Contents]
	    set con1 [::xsxp::only $pxml CommonPrefixes]
	    lappend names {*}[concat [::xsxp::fetchall $con0 Key %PCDATA] \
		[::xsxp::fetchall $con1 Prefix %PCDATA]]
	}
	return [lsort $names]
    } elseif {[dict get $myargs -result-type] eq "dict"} {
	# The harder one.
	set last0 [lindex $pxmlL end]
	set res [dict create]
	foreach thing {Name Prefix Marker MaxKeys IsTruncated} {
	    dict set res $thing [::xsxp::fetch $last0 $thing %PCDATA?]
	}
	dict set res NextMarker $nextmarker0 ; # From way up above.
	set Prefix [list]
	set names {Key LastModified ETag Size Owner/ID Owner/DisplayName StorageClass}
	foreach name $names {set $name [list]}
	foreach pxml $pxmlL {
	    foreach tag [::xsxp::only $pxml CommonPrefixes] {
		lappend Prefix [::xsxp::fetch $tag Prefix %PCDATA]
	    }
	    foreach tag [::xsxp::only $pxml Contents] {
		foreach name $names {
		    lappend $name [::xsxp::fetch $tag $name %PCDATA]
		}
	    }
	}
	dict set res CommonPrefixes/Prefix $Prefix
	foreach name $names {dict set res $name [set $name]}
	return $res
    } else {
	# The hardest one ;-)
	error "GetBucket Invalid result type, must be REST, xml, pxml, names, or dict" "" [list S3 usage -result-type $args]
    }
}

# Internal. Compare a resource to a file.
# Returns 1 if they're different, 0 if they're the same.
#   Note that using If-Modified-Since and/or If-Match,If-None-Match
#   might wind up being more efficient than pulling the head
#   and checking. However, this allows for slop, checking both
#   the etag and the date, only generating local etag if the
#   date and length indicate they're the same, and so on.
# Direction is G or P for Get or Put.
# Assumes the source always exists. Obviously, Get and Put will throw if not,
# but not because of this.
proc S3::compare {myargs direction} {
    variable config
    global errorInfo
    set compare [dict get $myargs -compare]
    if {$compare ni {always never exists missing newer date checksum different}} {
	error "-compare must be always, never, exists, missing, newer, date, checksum, or different" "" \
	    [list S3 usage -compare $myargs]
    }
    if {"never" eq $compare} {return 0}
    if {"always" eq $compare} {return 1}
    if {[dict exists $myargs -file] && [file exists [dict get $myargs -file]]} {
	set local_exists 1
    } else {
	set local_exists 0
    }
    # Avoid hitting S3 if we don't need to.
    if {$direction eq "G" && "exists" eq $compare} {return $local_exists}
    if {$direction eq "G" && "missing" eq $compare} {
	return [expr !$local_exists]
    }
    # We need to get the headers from the resource.
    set req [dict create \
	resource /[dict get $myargs -bucket]/[dict get $myargs -resource] \
	verb HEAD ]
    set res [S3::maybebackground $req $myargs]
    set httpstatus [dict get $res httpstatus]
    if {"404" eq $httpstatus} {
	set remote_exists 0
    } elseif {[string match "2??" $httpstatus]} {
	set remote_exists 1
    } else {
	error "S3: Neither 404 or 2xx on conditional compare" "" \
	    [list S3 remote $httpstatus $res]
    } 
    if {$direction eq "P"} {
	if {"exists" eq $compare} {return $remote_exists}
	if {"missing" eq $compare} {return [expr {!$remote_exists}]}
	if {!$remote_exists} {return 1}
    } elseif {$direction eq "G"} {
	# Actually already handled above, but it never hurts...
	if {"exists" eq $compare} {return $local_exists}
	if {"missing" eq $compare} {return [expr {!$local_exists}]}
    }
    set outheaders [dict get $res outheaders]
    if {[dict exists $outheaders content-length]} {
	set remote_length [dict get $outheaders content-length]
    } else {
	set remote_length -1
    }
    if {[dict exists $outheaders etag]} {
	set remote_etag [string tolower \
	    [string trim [dict get $outheaders etag] \"]]
    } else {
	set remote_etag "YYY"
    }
    if {[dict exists $outheaders last-modified]} {
	set remote_date [clock scan [dict get $outheaders last-modified]]
    } else {
	set remote_date -1
    }
    if {[dict exists $myargs -content]} {
	# Probably should work this out better...
	#set local_length [string length [encoding convert-to utf-8 \
	    #[dict get $myargs -content]]]
	set local_length [string length [dict get $myargs -content]]
    } elseif {$local_exists} {
	if {[catch {file size [dict get $myargs -file]} local_length]} {
	    error "S3: Couldn't stat [dict get $myargs -file]" "" \
		[list S3 local $errorInfo]
	}
    } else {
	set local_length -2
    }
    if {[dict exists $myargs -content]} {
	set local_date [clock seconds]
    } elseif {$local_exists} {
	set local_date [file mtime [dict get $myargs -file]]
	# Shouldn't throw, since [file size] worked.
    } else {
	set local_date -2
    }
    if {$direction eq "P"} {
	if {"newer" eq $compare} {
	    if {$remote_date < $local_date - [dict get $config -slop-seconds]} {
		return 1 ; # Yes, local is newer
	    } else {
		return 0 ; # Older, or the same
	    }
	}
    } elseif {$direction eq "G"} {
	if {"newer" eq $compare} {
	    if {$local_date < $remote_date - [dict get $config -slop-seconds]} {
		return 1 ; # Yes, remote is later.
	    } else {
		return 0 ; # Local is older or same.
	    }
	}
    }
    if {[dict get $config -slop-seconds] <= abs($local_date - $remote_date)} {
	set date_diff 1 ; # Difference is greater
    } else {
	set date_diff 0 ; # Difference negligible
    }
    if {"date" eq $compare} {return $date_diff}
    if {"different" eq $compare && [dict exists $myargs -file] && $date_diff} {
	return 1
    }
    # Date's the same, but we're also interested in content, so check the rest
    # Only others to handle are checksum and different-with-matching-dates
    if {$local_length != $remote_length} {return 1} ; #easy quick case
    if {[dict exists $myargs -file] && $local_exists} {
	if {[catch {
	    # Maybe deal with making this backgroundable too?
	    set local_etag [string tolower \
		[::md5::md5 -hex -filename [dict get $myargs -file]]]
	} caught]} {
	    # Maybe you can stat but not read it?
	    error "S3 could not hash file" "" \
		[list S3 local [dict get $myargs -file] $errorInfo]
	}
    } elseif {[dict exists $myargs -content]} {
	set local_etag [string tolower \
	    [string tolower [::md5::md5 -hex [dict get $myargs -content]]]]
    } else {
	set local_etag "XXX"
    }
    # puts "local:  $local_etag\nremote: $remote_etag"
    if {$local_etag eq $remote_etag} {return 0} {return 1}
}

# Internal. Calculates the ACL based on file permissions.
proc S3::calcacl {myargs} {
    # How would one work this under Windows, then?
    # Silly way: invoke [exec cacls $filename],
    # parse the result looking for Everyone:F or Everyone:R
    # Messy security if someone replaces the cacls.exe or something.
    error "S3 Not Yet Implemented" "" [list S3 notyet calcacl $myargs]
    set result [S3::Configure -default-acl]
    catch {
	set chmod [file attributes [dict get $myargs -file] -permissions]
	set chmod [expr {$chmod & 6}]
	if {$chmod == 0} {set result private}
	if {$chmod == 2} {set result public-write}
	if {$chmod == 6} {set result public-read-write}
    }
}

# Public. Put a resource into a bucket.
proc S3::Put {args} {
    checkinit
    set myargs [S3::parseargs1 $args {
	-bucket -blocking -file -content -resource -acl
	-content-type -x-amz-meta-* -compare
    }]
    if {![dict exists $myargs -bucket]} {
	dict set myargs -bucket [S3::Configure -default-bucket]
    }
    dict set myargs -bucket [string trim [dict get $myargs -bucket] "/ "]
    if {"" eq [dict get $myargs -bucket]} {
	error "Put requires -bucket" "" [list S3 usage -bucket $args]
    }
    if {![dict exists $myargs -blocking]} {
	dict set myargs -blocking true
    }
    if {![dict exists $myargs -file] && ![dict exists $myargs -content]} {
	error "Put requires -file or -content" "" [list S3 usage -file $args]
    }
    if {[dict exists $myargs -file] && [dict exists $myargs -content]} {
	error "Put says -file, -content mutually exclusive" "" [list S3 usage -file $args]
    }
    if {![dict exists $myargs -resource]} {
	error "Put requires -resource" "" [list S3 usage -resource $args]
    }
    if {![dict exists $myargs -compare]} {
	dict set myargs -compare [S3::Configure -default-compare]
    }
    if {![dict exists $myargs -acl] && "" ne [S3::Configure -default-acl]} {
	dict set myargs -acl [S3::Configure -default-acl]
    }
    if {[dict exists $myargs -file] && \
	    "never" ne [dict get $myargs -compare] && \
	    ![file exists [dict get $myargs -file]]} {
	error "Put -file doesn't exist: [dict get $myargs -file]" \
	    "" [list S3 usage -file $args]
    }
    # Clean up bucket, and take one leading slash (if any) off resource.
    if {[string match "/*" [dict get $myargs -resource]]} {
	dict set myargs -resource \
	    [string range [dict get $myargs -resource] 1 end]
    }
    # See if we need to copy it.
    set comp [S3::compare $myargs P]
    if {!$comp} {return 0} ;  # skip it, then.

    # Oookeydookey. At this point, we're actually going to send 
    # the file, so all we need to do is build the request array.
    set req [dict create verb PUT \
	resource /[dict get $myargs -bucket]/[dict get $myargs -resource]]
    if {[dict exists $myargs -file]} {
	dict set req infile [dict get $myargs -file]
    } else {
	dict set req inbody [dict get $myargs -content]
    }
    if {[dict exists $myargs -content-type]} {
	dict set req content-type [dict get $myargs -content-type]
    }
    set headers {}
    foreach xhead [dict keys $myargs -x-amz-meta-*] {
	dict set headers [string range $xhead 1 end] [dict get $myargs $xhead]
    }
    set xmlacl "" ; # For calc and keep
    if {[dict exists $myargs -acl]} {
	if {[dict get $myargs -acl] eq "calc"} {
	    # We could make this more complicated by 
	    # assigning it to xmlacl after building it.
	    dict set myargs -acl [S3::calcacl $myargs]
	} elseif {[dict get $myargs -acl] eq "keep"} {
	    dict set myargs -acl [S3::Configure -default-acl]
	    catch {
		set xmlacl [S3::GetAcl \
		    -bucket [dict get $myargs -bucket] \
		    -resource [dict get $myargs -resource] \
		    -blocking [dict get $myargs -blocking] \
		    -result-type xml]
	    }
	}
	dict set headers x-amz-acl [dict get $myargs -acl]
    }
    dict set req headers $headers
    # That should do it.
    set res [S3::maybebackground $req $myargs]
    S3::throwhttp $res
    if {"<" == [string index $xmlacl 0]} {
	# Set the saved ACL back on the new object
	S3::PutAcl \
	    -bucket [dict get $myargs -bucket] \
	    -resource [dict get $myargs -resource] \
	    -blocking [dict get $myargs -blocking] \
	    -acl $xmlacl
    }
    return 1 ; # Yep, we copied it!
}

# Public. Get a resource from a bucket.
proc S3::Get {args} {
    global errorCode
    checkinit
    set myargs [S3::parseargs1 $args {
	-bucket -blocking -file -content -resource -timestamp
	-headers -compare
    }]
    if {![dict exists $myargs -bucket]} {
	dict set myargs -bucket [S3::Configure -default-bucket]
    }
    dict set myargs -bucket [string trim [dict get $myargs -bucket] "/ "]
    if {"" eq [dict get $myargs -bucket]} {
	error "Get requires -bucket" "" [list S3 usage -bucket $args]
    }
    if {![dict exists $myargs -file] && ![dict exists $myargs -content]} {
	error "Get requires -file or -content" "" [list S3 usage -file $args]
    }
    if {[dict exists $myargs -file] && [dict exists $myargs -content]} {
	error "Get says -file, -content mutually exclusive" "" [list S3 usage -file $args]
    }
    if {![dict exists $myargs -resource]} {
	error "Get requires -resource" "" [list S3 usage -resource $args]
    }
    if {![dict exists $myargs -compare]} {
	dict set myargs -compare [S3::Configure -default-compare]
    }
    # Clean up bucket, and take one leading slash (if any) off resource.
    if {[string match "/*" [dict get $myargs -resource]]} {
	dict set myargs -resource \
	    [string range [dict get $myargs -resource] 1 end]
    }
    # See if we need to copy it.
    if {"never" eq [dict get $myargs -compare]} {return 0}
    if {[dict exists $myargs -content]} {
	set comp 1
    } else {
	set comp [S3::compare $myargs G]
    }
    if {!$comp} {return 0} ;  # skip it, then.

    # Oookeydookey. At this point, we're actually going to fetch 
    # the file, so all we need to do is build the request array.
    set req [dict create verb GET \
	resource /[dict get $myargs -bucket]/[dict get $myargs -resource]]
    if {[dict exists $myargs -file]} {
	set pre_exists [file exists [dict get $myargs -file]]
	if {[catch { 
	    set x [open [dict get $myargs -file] w]
	    fconfigure $x -translation binary -encoding binary
	} caught]} {
	    error "Get could not create file [dict get $myargs -file]" "" \
		[list S3 local -file $errorCode]
	}
	dict set req outchan $x
    }
    # That should do it.
    set res [S3::maybebackground $req $myargs]
    if {[dict exists $req outchan]} {
	catch {close [dict get $req outchan]}
	if {![string match "2??" [dict get $res httpstatus]] && !$pre_exists} {
	    catch {file delete -force -- [dict get $myargs -file]}
	}
    }
    S3::throwhttp $res
    if {[dict exists $myargs -headers]} {
	uplevel 1 \
	    [list set [dict get $myargs -headers] [dict get $res outheaders]]
    }
    if {[dict exists $myargs -content]} {
	uplevel 1 \
	    [list set [dict get $myargs -content] [dict get $res outbody]]
    }
    if {[dict exists $myargs -timestamp] && [dict exists $myargs -file]} {
	if {"aws" eq [dict get $myargs -timestamp]} {
	    catch {
		set t [dict get $res outheaders last-modified]
		set t [clock scan $t -gmt true]
		file mtime [dict get $myargs -file] $t
	    }
	}
    }
    return 1 ; # Yep, we copied it!
}

# Public. Get information about a resource in a bucket.
proc S3::Head {args} {
    global errorCode
    checkinit
    set myargs [S3::parseargs1 $args {
	-bucket -blocking -resource -headers -dict -status
    }]
    if {![dict exists $myargs -bucket]} {
	dict set myargs -bucket [S3::Configure -default-bucket]
    }
    dict set myargs -bucket [string trim [dict get $myargs -bucket] "/ "]
    if {"" eq [dict get $myargs -bucket]} {
	error "Head requires -bucket" "" [list S3 usage -bucket $args]
    }
    if {![dict exists $myargs -resource]} {
	error "Head requires -resource" "" [list S3 usage -resource $args]
    }
    # Clean up bucket, and take one leading slash (if any) off resource.
    if {[string match "/*" [dict get $myargs -resource]]} {
	dict set myargs -resource \
	    [string range [dict get $myargs -resource] 1 end]
    }
    set req [dict create verb HEAD \
	resource /[dict get $myargs -bucket]/[dict get $myargs -resource]]
    set res [S3::maybebackground $req $myargs]
    if {[dict exists $myargs -dict]} {
	uplevel 1 \
	    [list set [dict get $myargs -dict] $res]
    }
    if {[dict exists $myargs -headers]} {
	uplevel 1 \
	    [list set [dict get $myargs -headers] [dict get $res outheaders]]
    }
    if {[dict exists $myargs -status]} {
	set x [list [dict get $res httpstatus] [dict get $res httpmessage]]
	uplevel 1 \
	    [list set [dict get $myargs -status] $x]
    }
    return [string match "2??" [dict get $res httpstatus]]
}

# Public. Get the full ACL from an object and parse it into something useful.
proc S3::GetAcl {args} {
    global errorCode
    checkinit
    set myargs [S3::parseargs1 $args {
	-bucket -blocking -resource -result-type -parse-xml
    }]
    if {![dict exists $myargs -bucket]} {
	dict set myargs -bucket [S3::Configure -default-bucket]
    }
    dict set myargs -bucket [string trim [dict get $myargs -bucket] "/ "]
    if {![dict exists $myargs -result-type]} {
	dict set myargs -result-type "dict"
    }
    set restype [dict get $myargs -result-type]
    if {$restype eq "REST" && [dict exists $myargs -parse-xml]} {
	error "Do not use REST with -parse-xml" "" \
	    [list S3 usage -parse-xml $args]
    }
    if {![dict exists $myargs -parse-xml]} {
	# We need to fetch the results.
	if {"" eq [dict get $myargs -bucket]} {
	    error "GetAcl requires -bucket" "" [list S3 usage -bucket $args]
	}
	if {![dict exists $myargs -resource]} {
	    error "GetAcl requires -resource" "" [list S3 usage -resource $args]
	}
	# Clean up bucket, and take one leading slash (if any) off resource.
	if {[string match "/*" [dict get $myargs -resource]]} {
	    dict set myargs -resource \
		[string range [dict get $myargs -resource] 1 end]
	}
	set req [dict create verb GET \
	    resource /[dict get $myargs -bucket]/[dict get $myargs -resource] \
	    rtype acl]
	set dict [S3::maybebackground $req $myargs]
	if {$restype eq "REST"} {
	    return $dict ; #we're done!
	}
	S3::throwhttp $dict ; #make sure it worked.
	set xml [dict get $dict outbody] 
    } else {
	set xml [dict get $myargs -parse-xml]
    }
    if {[dict get $myargs -result-type] == "xml"} {
	return $xml
    }
    set pxml [xsxp::parse $xml]
    if {[dict get $myargs -result-type] == "pxml"} {
	return $pxml
    }
    if {[dict get $myargs -result-type] == "dict"} {
	array set resdict {}
	set owner [xsxp::fetch $pxml Owner/ID %PCDATA]
	set grants [xsxp::fetch $pxml AccessControlList %CHILDREN]
	foreach grant $grants {
	    set perm [xsxp::fetch $grant Permission %PCDATA]
	    set id ""
	    catch {set id [xsxp::fetch $grant Grantee/ID %PCDATA]}
	    if {$id == ""} {
		set id [xsxp::fetch $grant Grantee/URI %PCDATA]
	    }
	    lappend resdict($perm) $id
	}
	return [dict create owner $owner acl [array get resdict]]
    }
    error "GetAcl requires -result-type to be REST, xml, pxml or dict" "" [list S3 usage -result-type $args]
}

# Make one Grant thingie
proc S3::engrant {who what} {
    if {$who == "AuthenticatedUsers" || $who == "AllUsers"} {
	set who http://acs.amazonaws.com/groups/global/$who
    }
    if {-1 != [string first "//" $who]} {
	set type Group ; set tag URI
    } elseif {-1 != [string first "@" $who]} {
	set type AmazonCustomerByEmail ; set tag EmailAddress
    } else {
	set type CanonicalUser ; set tag ID
    }
    set who [string map {< &lt; > &gt; & &amp;} $who]
    set what [string toupper $what]
    set xml "<Grant><Grantee xmlns:xsi=\"http://www.w3.org/2001/XMLSchema-instance\" xsi:type=\"$type\"><$tag>$who</$tag></Grantee>"
    append xml "<Permission>$what</Permission></Grant>"
    return $xml
}

# Make the owner header
proc S3::enowner {owner} {
    return "<AccessControlPolicy xmlns=\"http://s3.amazonaws.com/doc/2006-03-01/\"><Owner><ID>$owner</ID></Owner><AccessControlList>"
    return "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n<AccessControlPolicy xmlns=\"http://s3.amazonaws.com/doc/2006-03-01/\"><Owner><ID>$owner</ID></Owner><AccessControlList>"
}

proc S3::endacl {} {
    return "</AccessControlList></AccessControlPolicy>\n"
}

# Public. Set the ACL on an existing object.
proc S3::PutAcl {args} {
    global errorCode
    checkinit
    set myargs [S3::parseargs1 $args {
	-bucket -blocking -resource -acl -owner
    }]
    if {![dict exists $myargs -bucket]} {
	dict set myargs -bucket [S3::Configure -default-bucket]
    }
    dict set myargs -bucket [string trim [dict get $myargs -bucket] "/ "]
    if {"" eq [dict get $myargs -bucket]} {
	error "PutAcl requires -bucket" "" [list S3 usage -bucket $args]
    }
    if {![dict exists $myargs -resource]} {
	error "PutAcl requires -resource" "" [list S3 usage -resource $args]
    }
    if {![dict exists $myargs -acl]} {
	dict set myargs -acl [S3::Configure -default-acl]
    }
    dict set myargs -acl [string trim [dict get $myargs -acl]]
    if {[dict get $myargs -acl] == ""} {
	dict set myargs -acl [S3::Configure -default-acl]
    }
    if {[dict get $myargs -acl] == ""} {
	error "PutAcl requires -acl" "" [list D3 usage -resource $args]
    }
    # Clean up bucket, and take one leading slash (if any) off resource.
    if {[string match "/*" [dict get $myargs -resource]]} {
	dict set myargs -resource \
	    [string range [dict get $myargs -resource] 1 end]
    }
    # Now, figure out the XML to send.
    set acl [dict get $myargs -acl]
    set owner ""
    if {"<" != [string index $acl 0] && ![dict exists $myargs -owner]} {
	# Grab the owner off the resource
	set req [dict create verb GET \
	    resource /[dict get $myargs -bucket]/[dict get $myargs -resource] \
	    rtype acl]
	set dict [S3::maybebackground $req $myargs]
	S3::throwhttp $dict ; #make sure it worked.
	set xml [dict get $dict outbody] 
	set pxml [xsxp::parse $xml]
	set owner [xsxp::fetch $pxml Owner/ID %PCDATA]
    }
    if {[dict exists $myargs -owner]} {
	set owner [dict get $myargs -owner]
    }
    set xml [enowner $owner] 
    if {"" == $acl || "private" == $acl} {
	append xml [engrant $owner FULL_CONTROL]
	append xml [endacl]
    } elseif {"public-read" == $acl} {
	append xml [engrant $owner FULL_CONTROL]
	append xml [engrant AllUsers READ]
	append xml [endacl]
    } elseif {"public-read-write" == $acl} {
	append xml [engrant $owner FULL_CONTROL]
	append xml [engrant AllUsers READ]
	append xml [engrant AllUsers WRITE]
	append xml [endacl]
    } elseif {"authenticated-read" == $acl} {
	append xml [engrant $owner FULL_CONTROL]
	append xml [engrant AuthenticatedUsers READ]
	append xml [endacl]
    } elseif {"<" == [string index $acl 0]} {
	set xml $acl
    } elseif {[llength $acl] % 2 != 0} {
	error "S3::PutAcl -acl must be xml, private, public-read, public-read-write, authenticated-read, or a dictionary" \
	"" [list S3 usage -acl $acl]
    } else {
	# ACL in permission/ID-list format.
	if {[dict exists $acl owner] && [dict exists $acl acl]} {
	    set xml [S3::enowner [dict get $acl owner]]
	    set acl [dict get $acl acl]
	}
	foreach perm {FULL_CONTROL READ READ_ACP WRITE WRITE_ACP} {
	    if {[dict exists $acl $perm]} {
		foreach id [dict get $acl $perm] {
		    append xml [engrant $id $perm]
		}
	    }
	}
	append xml [endacl]
    }
    set req [dict create verb PUT \
	resource /[dict get $myargs -bucket]/[dict get $myargs -resource] \
	inbody $xml \
	rtype acl]
    set res [S3::maybebackground $req $myargs]
    S3::throwhttp $res ; #make sure it worked.
    return $xml
}

# Public. Delete a resource from a bucket.
proc S3::Delete {args} {
    global errorCode
    checkinit
    set myargs [S3::parseargs1 $args {
	-bucket -blocking -resource -status
    }]
    if {![dict exists $myargs -bucket]} {
	dict set myargs -bucket [S3::Configure -default-bucket]
    }
    dict set myargs -bucket [string trim [dict get $myargs -bucket] "/ "]
    if {"" eq [dict get $myargs -bucket]} {
	error "Delete requires -bucket" "" [list S3 usage -bucket $args]
    }
    if {![dict exists $myargs -resource]} {
	error "Delete requires -resource" "" [list S3 usage -resource $args]
    }
    # Clean up bucket, and take one leading slash (if any) off resource.
    if {[string match "/*" [dict get $myargs -resource]]} {
	dict set myargs -resource \
	    [string range [dict get $myargs -resource] 1 end]
    }
    set req [dict create verb DELETE \
	resource /[dict get $myargs -bucket]/[dict get $myargs -resource]]
    set res [S3::maybebackground $req $myargs]
    if {[dict exists $myargs -status]} {
	set x [list [dict get $res httpstatus] [dict get $res httpmessage]]
	uplevel 1 \
	    [list set [dict get $myargs -status] $x]
    }
    return [string match "2??" [dict get $res httpstatus]]
}

# Some helper routines for Push, Pull, and Sync

# Internal. Filter for fileutil::find.
proc S3::findfilter {dirs name} {
    # In particular, skip links, devices, etc.
    if {$dirs} {
	return [expr {[file isdirectory $name] || [file isfile $name]}]
    } else {
	return [file isfile $name]
    }
}

# Internal.  Get list of local files, appropriately trimmed.
proc S3::getLocal {root dirs} {
    # Thanks to Michael Cleverly for this first line...
    set base [file normalize [file join [pwd] $root]]
    if {![string match "*/" $base]} {
	set base $base/
    }
    set files {} ; set bl [string length $base]
    foreach file [fileutil::find $base [list S3::findfilter $dirs]] {
	if {[file isdirectory $file]} {
	    lappend files [string range $file $bl end]/
	} else {
	    lappend files [string range $file $bl end]
	}
    }
    set files [lsort $files]
    # At this point, $files is a sorted list of all the local files,
    # with a trailing / on any directories included in the list.
    return $files
}

# Internal. Get list of remote resources, appropriately trimmed.
proc S3::getRemote {bucket prefix blocking} {
    set prefix [string trim $prefix " /"]
    if {0 != [string length $prefix]} {append prefix /}
    set res [S3::GetBucket -bucket $bucket -prefix $prefix \
	-result-type names -blocking $blocking]
    set names {} ; set pl [string length $prefix]
    foreach name $res {
	lappend names [string range $name $pl end]
    }
    return [lsort $names]
}

# Internal. Create any directories we need to put the file in place.
proc S3::makeDirs {directory suffix} {
    set sofar {}
    set nodes [split $suffix /]
    set nodes [lrange $nodes 0 end-1]
    foreach node $nodes {
	lappend sofar $node
	set tocheck [file join $directory {*}$sofar]
	if {![file exists $tocheck]} {
	    catch {file mkdir $tocheck}
	}
    }
}

# Internal. Default progress monitor for push, pull, toss.
proc S3::ignore {args} {} ; # default progress monitor

# Internal. For development and testing. Progress monitor.
proc S3::printargs {args} {puts $args} ; # For testing.

# Public. Send a local directory tree to S3.
proc S3::Push {args} {
    uplevel #0 package require fileutil
    global errorCode errorInfo
    checkinit
    set myargs [S3::parseargs1 $args {
	-bucket -blocking -prefix -directory 
	-compare -x-amz-meta-* -acl -delete -error -progress
    }]
    if {![dict exists $myargs -bucket]} {
	dict set myargs -bucket [S3::Configure -default-bucket]
    }
    dict set myargs -bucket [string trim [dict get $myargs -bucket] "/ "]
    if {"" eq [dict get $myargs -bucket]} {
	error "Push requires -bucket" "" [list S3 usage -bucket $args]
    }
    if {![dict exists $myargs -directory]} {
	error "Push requires -directory" "" [list S3 usage -directory $args]
    }
    # Set default values.
    set defaults "
    -acl \"[S3::Configure -default-acl]\"
    -compare [S3::Configure -default-compare]
    -prefix {} -delete 0 -error continue -progress ::S3::ignore -blocking 1"
    foreach {key val} $defaults {
	if {![dict exists $myargs $key]} {dict set myargs $key $val}
    }
    # Pull out arguments for convenience
    foreach i {progress prefix directory bucket blocking} {
	set $i [dict get $myargs -$i]
    }
    set prefix [string trimright $prefix /]
    set meta [dict filter $myargs key x-amz-meta-*]
    # We're readdy to roll here.
    uplevel 1 [list {*}$progress args $myargs]
    if {[catch {
	set local [S3::getLocal $directory 0]
    } caught]}  {
	error "Push could not walk local directory - $caught" \
	    $errorInfo $errorCode
    }
    uplevel 1 [list {*}$progress local $local]
    if {[catch {
	set remote [S3::getRemote $bucket $prefix $blocking]
    } caught]} {
	error "Push could not walk remote directory - $caught" \
	    $errorInfo $errorCode
    }
    uplevel 1 [list {*}$progress remote $remote]
    set result [dict create]
    set result0 [dict create \
	filescopied 0 bytescopied 0 compareskipped 0 \
	errorskipped 0 filesdeleted 0 filesnotdeleted 0]
    foreach suffix $local {
	uplevel 1 [list {*}$progress copy $suffix start]
	set err [catch {
	    S3::Put -bucket $bucket -blocking $blocking \
	    -file [file join $directory $suffix] \
	    -resource $prefix/$suffix \
	    -acl [dict get $myargs -acl] \
	    {*}$meta \
	    -compare [dict get $myargs -compare]} caught]
	if {$err} {
	    uplevel 1 [list {*}$progress copy $suffix $errorCode]
	    dict incr result0 errorskipped
	    dict set result $suffix $errorCode
	    if {[dict get $myargs -error] eq "throw"} {
		error "Push failed to Put - $caught" $errorInfo $errorCode
	    } elseif {[dict get $myargs -error] eq "break"} {
		break
	    }
	} else {
	    if {$caught} {
		uplevel 1 [list {*}$progress copy $suffix copied]
		dict incr result0 filescopied
		dict incr result0 bytescopied \
		    [file size [file join $directory $suffix]]
		dict set result $suffix copied
	    } else {
		uplevel 1 [list {*}$progress copy $suffix skipped]
		dict incr result0 compareskipped
		dict set result $suffix skipped
	    }
	}
    }
    # Now do deletes, if so desired
    if {[dict get $myargs -delete]} {
	foreach suffix $remote {
	    if {$suffix ni $local} {
		set err [catch {
		    S3::Delete -bucket $bucket -blocking $blocking \
			-resource $prefix/$suffix } caught]
		if {$err} {
		    uplevel 1 [list {*}$progress delete $suffix $errorCode]
		    dict incr result0 filesnotdeleted
		    dict set result $suffix notdeleted
		} else {
		    uplevel 1 [list {*}$progress delete $suffix {}]
		    dict incr result0 filesdeleted
		    dict set result $suffix deleted
		}
	    }
	}
    }
    dict set result {} $result0
    uplevel 1 [list {*}$progress finished $result]
    return $result
}

# Public. Fetch a portion of a remote bucket into a local directory tree.
proc S3::Pull {args} {
    # This is waaaay to similar to Push for comfort.
    # Fold it up later.
    uplevel #0 package require fileutil
    global errorCode errorInfo
    checkinit
    set myargs [S3::parseargs1 $args {
	-bucket -blocking -prefix -directory 
	-compare -timestamp -delete -error -progress
    }]
    if {![dict exists $myargs -bucket]} {
	dict set myargs -bucket [S3::Configure -default-bucket]
    }
    dict set myargs -bucket [string trim [dict get $myargs -bucket] "/ "]
    if {"" eq [dict get $myargs -bucket]} {
	error "Pull requires -bucket" "" [list S3 usage -bucket $args]
    }
    if {![dict exists $myargs -directory]} {
	error "Pull requires -directory" "" [list S3 usage -directory $args]
    }
    # Set default values.
    set defaults "
    -timestamp now
    -compare [S3::Configure -default-compare]
    -prefix {} -delete 0 -error continue -progress ::S3::ignore -blocking 1"
    foreach {key val} $defaults {
	if {![dict exists $myargs $key]} {dict set myargs $key $val}
    }
    # Pull out arguments for convenience
    foreach i {progress prefix directory bucket blocking} {
	set $i [dict get $myargs -$i]
    }
    set prefix [string trimright $prefix /]
    # We're readdy to roll here.
    uplevel 1 [list {*}$progress args $myargs]
    if {[catch {
	set local [S3::getLocal $directory 1]
    } caught]}  {
	error "Pull could not walk local directory - $caught" \
	    $errorInfo $errorCode
    }
    uplevel 1 [list {*}$progress local $local]
    if {[catch {
	set remote [S3::getRemote $bucket $prefix $blocking]
    } caught]} {
	error "Pull could not walk remote directory - $caught" \
	    $errorInfo $errorCode
    }
    uplevel 1 [list {*}$progress remote $remote]
    set result [dict create]
    set result0 [dict create \
	filescopied 0 bytescopied 0 compareskipped 0 \
	errorskipped 0 filesdeleted 0 filesnotdeleted 0]
    foreach suffix $remote {
	uplevel 1 [list {*}$progress copy $suffix start]
	set err [catch {
	    S3::makeDirs $directory $suffix
	    S3::Get -bucket $bucket -blocking $blocking \
	    -file [file join $directory $suffix] \
	    -resource $prefix/$suffix \
	    -timestamp [dict get $myargs -timestamp] \
	    -compare [dict get $myargs -compare]} caught]
	if {$err} {
	    uplevel 1 [list {*}$progress copy $suffix $errorCode]
	    dict incr result0 errorskipped
	    dict set result $suffix $errorCode
	    if {[dict get $myargs -error] eq "throw"} {
		error "Pull failed to Get - $caught" $errorInfo $errorCode
	    } elseif {[dict get $myargs -error] eq "break"} {
		break
	    }
	} else {
	    if {$caught} {
		uplevel 1 [list {*}$progress copy $suffix copied]
		dict incr result0 filescopied
		dict incr result0 bytescopied \
		    [file size [file join $directory $suffix]]
		dict set result $suffix copied
	    } else {
		uplevel 1 [list {*}$progress copy $suffix skipped]
		dict incr result0 compareskipped
		dict set result $suffix skipped
	    }
	}
    }
    # Now do deletes, if so desired
    if {[dict get $myargs -delete]} {
	foreach suffix [lsort -decreasing $local] {
	    # Note, decreasing because we delete empty dirs
	    if {[string match "*/" $suffix]} {
		set f [file join $directory $suffix]
		catch {file delete -- $f} 
		if {![file exists $f]} {
		    uplevel 1 [list {*}$progress delete $suffix {}]
		    dict set result $suffix deleted
		    dict incr result0 filesdeleted
		}
	    } elseif {$suffix ni $remote} {
		set err [catch {
		    file delete [file join $directory $suffix]
		} caught]
		if {$err} {
		    uplevel 1 [list {*}$progress delete $suffix $errorCode]
		    dict incr result0 filesnotdeleted
		    dict set result $suffix notdeleted
		} else {
		    uplevel 1 [list {*}$progress delete $suffix {}]
		    dict incr result0 filesdeleted
		    dict set result $suffix deleted
		}
	    }
	}
    }
    dict set result {} $result0
    uplevel 1 [list {*}$progress finished $result]
    return $result
}

# Public. Delete a collection of resources with the same prefix.
proc S3::Toss {args} {
    # This is waaaay to similar to Push for comfort.
    # Fold it up later.
    global errorCode errorInfo
    checkinit
    set myargs [S3::parseargs1 $args {
	-bucket -blocking -prefix 
	-error -progress
    }]
    if {![dict exists $myargs -bucket]} {
	dict set myargs -bucket [S3::Configure -default-bucket]
    }
    dict set myargs -bucket [string trim [dict get $myargs -bucket] "/ "]
    if {"" eq [dict get $myargs -bucket]} {
	error "Toss requires -bucket" "" [list S3 usage -bucket $args]
    }
    if {![dict exists $myargs -prefix]} {
	error "Toss requires -prefix" "" [list S3 usage -directory $args]
    }
    # Set default values.
    set defaults "-error continue -progress ::S3::ignore -blocking 1"
    foreach {key val} $defaults {
	if {![dict exists $myargs $key]} {dict set myargs $key $val}
    }
    # Pull out arguments for convenience
    foreach i {progress prefix bucket blocking} {
	set $i [dict get $myargs -$i]
    }
    set prefix [string trimright $prefix /]
    # We're readdy to roll here.
    uplevel 1 [list {*}$progress args $myargs]
    if {[catch {
	set remote [S3::getRemote $bucket $prefix $blocking]
    } caught]} {
	error "Toss could not walk remote bucket - $caught" \
	    $errorInfo $errorCode
    }
    uplevel 1 [list {*}$progress remote $remote]
    set result [dict create]
    set result0 [dict create \
	filescopied 0 bytescopied 0 compareskipped 0 \
	errorskipped 0 filesdeleted 0 filesnotdeleted 0]
    # Now do deletes
    foreach suffix $remote {
	set err [catch {
	    S3::Delete -bucket $bucket -blocking $blocking \
		-resource $prefix/$suffix } caught]
	if {$err} {
	    uplevel 1 [list {*}$progress delete $suffix $errorCode]
	    dict incr result0 filesnotdeleted
	    dict set result $suffix notdeleted
	} else {
	    uplevel 1 [list {*}$progress delete $suffix {}]
	    dict incr result0 filesdeleted
	    dict set result $suffix deleted
	}
    }
    dict set result {} $result0
    uplevel 1 [list {*}$progress finished $result]
    return $result
}


<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
















































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































Deleted scriptlibs/tcllib1.12/amazon-s3/pkgIndex.tcl.

1
2
3
4
5
6
7
8
9
# pkgIndex.tcl --
# Copyright (c) 2006 Darren New
# This is for the Amazon S3 web service packages.

if {![package vsatisfies [package provide Tcl] 8.5]} {return}

package ifneeded xsxp 1.0 [list source [file join $dir xsxp.tcl]]
package ifneeded S3 1.0.0 [list source [file join $dir S3.tcl]]

<
<
<
<
<
<
<
<
<


















Deleted scriptlibs/tcllib1.12/amazon-s3/xsxp.tcl.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
# xsxp.tcl --
#
###Abstract
# Extremely Simple XML Parser
#
# This is pretty lame, but I needed something like this for S3,
# and at the time, TclDOM would not work with the new 8.5 Tcl
# due to version number problems. 
# 
# In addition, this is a pure-value implementation. There is no
# garbage to clean up in the event of a thrown error, for example.
# This simplifies the code for sufficiently small XML documents,
# which is what Amazon's S3 guarantees.
#
###Copyright
# Copyright (c) 2006 Darren New.
# All Rights Reserved.
# NO WARRANTIES OF ANY TYPE ARE PROVIDED.
# COPYING OR USE INDEMNIFIES THE AUTHOR IN ALL WAYS.
# See the license terms in LICENSE.txt
#
###Revision String
# SCCS: %Z% %M% %I% %E% %U%

# xsxp::parse $xml 
# Returns a parsed XML, or PXML. A pxml is a list.
# The first element is the name of the tag.
# The second element is a list of name/value pairs of the
# associated attribues, if any.
# The third thru final values are recursively PXML values.
# If the first element (element zero, that is) is "%PCDATA",
# then the attributes will be emtpy and the third element
# will be the text of the element.

# xsxp::fetch $pxml $path ?$part?
# $pxml is a parsed XML, as returned from xsxp::parse.
# $path is a list of elements. Each element is the name of
# a child to look up, optionally followed by a hash ("#")
# and a string of digits. An emtpy list or an initial empty 
# element selects $pxml. If no hash sign is present, the
# behavior is as if "#0" had been appended to that element.
# An element of $path scans the children at the indicated 
# level for the n'th instance of a child whose tag matches
# the part of the element before the hash sign. If an element
# is simply "#" followed by digits, that indexed child is
# selected, regardless of the tags in the children. So
# an element of #3 will always select the fourth child
# of the node under consideration.
# $part defaults to %ALL. It can be one of the following:
# %ALL - returns the entire selected element.
# %TAGNAME - returns lindex 0 of the selected element.
# %ATTRIBUTES - returns lindex 1 of the selected element.
# %CHILDREN - returns lrange 2 through end of the selected element,
#   resulting in a list of elements being returned.
# %PCDATA - returns a concatenation of all the bodies of
#   direct children of this node whose tag is %PCDATA.
#   Throws an error if no such children are found. That
#   is, part=%PCDATA means return the textual content found
#   in that node but not its children nodes.
# %PCDATA? - like %PCDATA, but returns an empty string if
#   no PCDATA is found.

# xsxp::fetchall $pxml_list $path ?$part?
# Iterates over each PXML in $pxml_list, selecting the indicated
# path from it, building a new list with the selected data, and
# returning that new list. For example, $pxml_list might be
# the %CHILDREN of a particular element, and the $path and $part
# might select from each child a sub-element in which we're interested.

# xsxp::only $pxml $tagname
# Iterates over the direct children of $pxml and selects  only
# those with $tagname as their tag. Returns a list of matching
# elements.

# xsxp::prettyprint $pxml
# Outputs to stdout a nested-list notation of the parsed XML.

package require xml
package provide xsxp 1.0

namespace eval xsxp {

    variable Stack
    variable Cur

    proc Characterdatacommand {characterdata} {
	variable Cur
	# puts "characterdatacommand $characterdata"
	set x [list %PCDATA {} $characterdata]
	lappend Cur $x
    }

    proc Elementstartcommand {name attlist args} {
	# puts "elementstart $name {$attlist} $args"
	variable Stack
	variable Cur
	lappend Stack $Cur
	set Cur [list $name $attlist]
    }

    proc Elementendcommand {args} {
	# puts "elementend $args"
	variable Stack
	variable Cur
	set x [lindex $Stack end]
	lappend x $Cur
	set Cur $x
	set Stack [lrange $Stack 0 end-1]
    }

    proc parse {xml} {
	variable Cur
	variable Stack
	set Cur {}
	set Stack {}
	set parser [::xml::parser \
	    -characterdatacommand [namespace code Characterdatacommand] \
	    -elementstartcommand [namespace code Elementstartcommand] \
	    -elementendcommand [namespace code Elementendcommand] \
	    -ignorewhitespace 1 -final 1
        ]
	$parser parse $xml
	$parser free
	# The following line is needed because the close of the last element
	# appends the outermost element to the item on the top of the stack.
	# Since there's nothing on the top of the stack at the close of the
	# last element, we append the current element to an empty list.
	# In essence, since we don't really have a terminating condition
	# on the recursion, an empty stack is still treated like an element.
	set Cur [lindex $Cur 0]
        set Cur [Normalize $Cur]
        return $Cur
    }

    proc Normalize {pxml} {
	# This iterates over pxml recursively, finding entries that
	# start with multiple %PCDATA elements, and coalesces their 
	# content, so if an element contains only %PCDATA, it is 
	# guaranteed to have only one child.
	# Not really necessary, given definition of part=%PCDATA
	# However, it makes pretty-prints nicer (for AWS at least)
	# and ends up with smaller lists. I have no idea why they
	# would put quotes around an MD5 hash in hex, tho.
	set dupl 1
	while {$dupl} {
	    set first [lindex $pxml 2]
	    set second [lindex $pxml 3]
	    if {[lindex $first 0] eq "%PCDATA" && [lindex $second 0] eq "%PCDATA"} {
		set repl [list %PCDATA {} [lindex $first 2][lindex $second 2]]
		set pxml [lreplace $pxml 2 3 $repl]
	    } else {
		set dupl 0
		for {set i 2} {$i < [llength $pxml]} {incr i} {
		    set pxml [lreplace $pxml $i $i [Normalize [lindex $pxml $i]]]
		}
	    }
	}
	return $pxml
    }

    proc prettyprint {pxml {chan stdout} {indent 0}} {
	puts -nonewline $chan [string repeat "  " $indent]
	if {[lindex $pxml 0] eq "%PCDATA"} {
	    puts $chan "%PCDATA: [lindex $pxml 2]"
	    return
	}
	puts -nonewline $chan "[lindex $pxml 0]"
	foreach {name val} [lindex $pxml 1] {
	    puts -nonewline $chan " $name='$val'"
	}
	puts $chan ""
	foreach node [lrange $pxml 2 end] {
	    prettyprint $node $chan [expr $indent+1]
	}
    }

    proc fetch {pxml path {part %ALL}} {
	set path [string trim $path /]
	if {-1 != [string first / $path]} {
	    set path [split $path /]
	}
	foreach element $path {
	    if {$pxml eq ""} {return ""}
	    foreach {tag count} [split $element #] {
		if {$tag ne ""} {
		    if {$count eq ""} {set count 0}
		    set pxml [lrange $pxml 2 end]
		    while {0 <= $count && 0 != [llength $pxml]} {
			if {$tag eq [lindex $pxml 0 0]} {
			    incr count -1
			    if {$count < 0} {
				# We're done. Go on to next element.
				set pxml [lindex $pxml 0]
			    } else {
				# Not done yet. Throw this away.
				set pxml [lrange $pxml 1 end]
			    }
			} else {
			    # Not what we want.
			    set pxml [lrange $pxml 1 end]
			}
		    }
		} else { # tag eq ""
		    if {$count eq ""} {
			# Just select whole $pxml
		    } else {
			set pxml [lindex $pxml [expr {2+$count}]]
		    }
		}
		break
	    } ; # done the foreach [split] loop
	} ; # done all the elements.
	if {$part eq "%ALL"} {return $pxml}
	if {$part eq "%ATTRIBUTES"} {return [lindex $pxml 1]}
	if {$part eq "%TAGNAME"} {return [lindex $pxml 0]}
	if {$part eq "%CHILDREN"} {return [lrange $pxml 2 end]}
	if {$part eq "%PCDATA" || $part eq "%PCDATA?"} {
	    set res "" ; set found 0
	    foreach elem [lrange $pxml 2 end] {
		if {"%PCDATA" eq [lindex $elem 0]} {
		    append res [lindex $elem 2]
		    set found 1
		}
	    }
	    if {$found || $part eq "%PCDATA?"} {
		return $res
	    } else {
		error "xsxp::fetch did not find requested PCDATA"
	    }
	}
	return $pxml ; # Don't know what he's after
    }

    proc only {pxml tag} {
	set res {}
	foreach element [lrange $pxml 2 end] {
	    if {[lindex $element 0] eq $tag} {
		lappend res $element
	    }
	}
	return $res
    }

    proc fetchall {pxml_list path {part %ALL}} {
	set res [list]
	foreach pxml $pxml_list {
	    lappend res [fetch $pxml $path $part]
	}
	return $res
    }
}

namespace export xsxp parse prettyprint fetch

<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<




























































































































































































































































































































































































































































































































Deleted scriptlibs/tcllib1.12/asn/asn.tcl.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
1483
1484
1485
1486
1487
1488
1489
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
#-----------------------------------------------------------------------------
#   Copyright (C) 1999-2004 Jochen C. Loewer (loewerj@web.de)
#   Copyright (C) 2004-2007 Michael Schlenker (mic42@users.sourceforge.net)
#-----------------------------------------------------------------------------
#   
#   A partial ASN decoder/encoder implementation in plain Tcl. 
#
#   See ASN.1 (X.680) and BER (X.690).
#   See 'asn_ber_intro.txt' in this directory.
#
#   This software is copyrighted by Jochen C. Loewer (loewerj@web.de). The 
#   following terms apply to all files associated with the software unless 
#   explicitly disclaimed in individual files.
#
#   The authors hereby grant permission to use, copy, modify, distribute,
#   and license this software and its documentation for any purpose, provided
#   that existing copyright notices are retained in all copies and that this
#   notice is included verbatim in any distributions. No written agreement,
#   license, or royalty fee is required for any of the authorized uses.
#   Modifications to this software may be copyrighted by their authors
#   and need not follow the licensing terms described here, provided that
#   the new terms are clearly indicated on the first page of each file where
#   they apply.
#  
#   IN NO EVENT SHALL THE AUTHORS OR DISTRIBUTORS BE LIABLE TO ANY PARTY
#   FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES
#   ARISING OUT OF THE USE OF THIS SOFTWARE, ITS DOCUMENTATION, OR ANY
#   DERIVATIVES THEREOF, EVEN IF THE AUTHORS HAVE BEEN ADVISED OF THE
#   POSSIBILITY OF SUCH DAMAGE.
#
#   THE AUTHORS AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY WARRANTIES,
#   INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY,
#   FITNESS FOR A PARTICULAR PURPOSE, AND NON-INFRINGEMENT.  THIS SOFTWARE
#   IS PROVIDED ON AN "AS IS" BASIS, AND THE AUTHORS AND DISTRIBUTORS HAVE
#   NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR
#   MODIFICATIONS.
#
#   written by Jochen Loewer
#   3 June, 1999
#
#   $Id: asn.tcl,v 1.19 2008/03/09 21:00:22 mic42 Exp $
#
#-----------------------------------------------------------------------------

# needed for using wide()
package require Tcl 8.4

namespace eval asn {
    # Encoder commands
    namespace export \
        asnSequence \
	asnSequenceFromList \
        asnSet \
	asnSetFromList \
        asnApplicationConstr \
        asnApplication \
	asnContext\
	asnContextConstr\
        asnChoice \
        asnChoiceConstr \
        asnInteger \
        asnEnumeration \
        asnBoolean \
        asnOctetString \
        asnNull	   \
	asnUTCTime \
	asnNumericString \
        asnPrintableString \
        asnIA5String\
	asnBMPString\
	asnUTF8String\
        asnBitString \
        asnObjectIdentifer 
        
    # Decoder commands
    namespace export \
        asnGetResponse \
        asnGetInteger \
        asnGetEnumeration \
        asnGetOctetString \
        asnGetSequence \
        asnGetSet \
        asnGetApplication \
	asnGetNumericString \
        asnGetPrintableString \
        asnGetIA5String \
	asnGetBMPString \
	asnGetUTF8String \
        asnGetObjectIdentifier \
        asnGetBoolean \
        asnGetUTCTime \
        asnGetBitString \
        asnGetContext 
    
    # general BER utility commands    
    namespace export \
        asnPeekByte  \
        asnGetLength \
        asnRetag     \
	asnPeekTag   \
	asnTag	     
        
}

#-----------------------------------------------------------------------------
# Implementation notes:
#
# See the 'asn_ber_intro.txt' in this directory for an introduction
# into BER/DER encoding of ASN.1 information. Bibliography information
#
#   A Layman's Guide to a Subset of ASN.1, BER, and DER
#
#   An RSA Laboratories Technical Note
#   Burton S. Kaliski Jr.
#   Revised November 1, 1993
#
#   Supersedes June 3, 1991 version, which was also published as
#   NIST/OSI Implementors' Workshop document SEC-SIG-91-17.
#   PKCS documents are available by electronic mail to
#   <pkcs@rsa.com>.
#
#   Copyright (C) 1991-1993 RSA Laboratories, a division of RSA
#   Data Security, Inc. License to copy this document is granted
#   provided that it is identified as "RSA Data Security, Inc.
#   Public-Key Cryptography Standards (PKCS)" in all material
#   mentioning or referencing this document.
#   003-903015-110-000-000
#
#-----------------------------------------------------------------------------

#-----------------------------------------------------------------------------
# asnLength : Encode some length data. Helper command.
#-----------------------------------------------------------------------------

proc ::asn::asnLength {len} {
    
    if {$len < 0} {
        return -code error "Negative length octet requested"
    }
    if {$len < 128} {
        # short form: ISO X.690 8.1.3.4 
        return [binary format c $len]
    }
    # long form: ISO X.690 8.1.3.5
    # try to use a minimal encoding, 
    # even if not required by BER, but it is required by DER
    # take care for signed vs. unsigned issues
    if {$len < 256  } {
        return [binary format H2c 81 [expr {$len - 256}]]
    }
    if {$len < 32769} {
        # two octet signed value
        return [binary format H2S 82 $len]
    }
    if {$len < 65536} {
        return [binary format H2S 82 [expr {$len - 65536}]]
    }
    if {$len < 8388608} {
        # three octet signed value    
        return [binary format H2cS 83 [expr {$len >> 16}] [expr {($len & 0xFFFF) - 65536}]] 
    }    
    if {$len < 16777216} {
        # three octet signed value    
        return [binary format H2cS 83 [expr {($len >> 16) -256}] [expr {($len & 0xFFFF) -65536}]] 
    }
    if {$len < 2147483649} { 
        # four octet signed value
        return [binary format H2I 84 $len]
    }
    if {$len < 4294967296} {
        # four octet unsigned value
        return [binary format H2I 84 [expr {$len - 4294967296}]]
    }
    if {$len < 1099511627776} {
        # five octet unsigned value
        return [binary format H2 85][string range [binary format W $len] 3 end]  
    }
    if {$len < 281474976710656} {
        # six octet unsigned value
        return [binary format H2 86][string range [binary format W $len] 2 end]
    }
    if {$len < 72057594037927936} {
        # seven octet value
        return [binary format H2 87][string range [binary format W $len] 1 end]
    }
    
    # must be a 64-bit wide signed value
    return [binary format H2W 88 $len] 
}

#-----------------------------------------------------------------------------
# asnSequence : Assumes that the arguments are already ASN encoded.
#-----------------------------------------------------------------------------

proc ::asn::asnSequence {args} {
    asnSequenceFromList $args
}

proc ::asn::asnSequenceFromList {lst} {
    # The sequence tag is 0x30. The length is arbitrary and thus full
    # length coding is required. The arguments have to be BER encoded
    # already. Constructed value, definite-length encoding.

    set out ""
    foreach part $lst {
        append out $part
    }
    set len [string length $out]
    return [binary format H2a*a$len 30 [asnLength $len] $out]
}


#-----------------------------------------------------------------------------
# asnSet : Assumes that the arguments are already ASN encoded.
#-----------------------------------------------------------------------------

proc ::asn::asnSet {args} {
    asnSetFromList $args
}

proc ::asn::asnSetFromList {lst} {
    # The set tag is 0x31. The length is arbitrary and thus full
    # length coding is required. The arguments have to be BER encoded
    # already.

    set out ""
    foreach part $lst {
        append out $part
    }
    set len [string length $out]
    return [binary format H2a*a$len 31 [asnLength $len] $out]
}


#-----------------------------------------------------------------------------
# asnApplicationConstr
#-----------------------------------------------------------------------------

proc ::asn::asnApplicationConstr {appNumber args} {
    # Packs the arguments into a constructed value with application tag.

    set out ""
    foreach part $args {
        append out $part
    }
    set code [expr {0x060 + $appNumber}]
    set len  [string length $out]
    return [binary format ca*a$len $code [asnLength $len] $out]
}

#-----------------------------------------------------------------------------
# asnApplication
#-----------------------------------------------------------------------------

proc ::asn::asnApplication {appNumber data} {
    # Packs the arguments into a constructed value with application tag.

    set code [expr {0x040 + $appNumber}]
    set len  [string length $data]
    return [binary format ca*a$len $code [asnLength $len] $data]
}

#-----------------------------------------------------------------------------
# asnContextConstr
#-----------------------------------------------------------------------------

proc ::asn::asnContextConstr {contextNumber args} {
    # Packs the arguments into a constructed value with application tag.

    set out ""
    foreach part $args {
        append out $part
    }
    set code [expr {0x0A0 + $contextNumber}]
    set len  [string length $out]
    return [binary format ca*a$len $code [asnLength $len] $out]
}

#-----------------------------------------------------------------------------
# asnContext
#-----------------------------------------------------------------------------

proc ::asn::asnContext {contextNumber data} {
    # Packs the arguments into a constructed value with application tag.
    set code [expr {0x080 + $contextNumber}]
    set len  [string length $data]
    return [binary format ca*a$len $code [asnLength $len] $data]
}
#-----------------------------------------------------------------------------
# asnChoice
#-----------------------------------------------------------------------------

proc ::asn::asnChoice {appNumber args} {
    # Packs the arguments into a choice construction.

    set out ""
    foreach part $args {
        append out $part
    }
    set code [expr {0x080 + $appNumber}]
    set len  [string length $out]
    return [binary format ca*a$len $code [asnLength $len] $out]
}

#-----------------------------------------------------------------------------
# asnChoiceConstr
#-----------------------------------------------------------------------------

proc ::asn::asnChoiceConstr {appNumber args} {
    # Packs the arguments into a choice construction.

    set out ""
    foreach part $args {
        append out $part
    }
    set code [expr {0x0A0 + $appNumber}]
    set len  [string length $out]
    return [binary format ca*a$len $code [asnLength $len] $out]
}

#-----------------------------------------------------------------------------
# asnInteger : Encode integer value.
#-----------------------------------------------------------------------------

proc ::asn::asnInteger {number} {
    asnIntegerOrEnum 02 $number
}

#-----------------------------------------------------------------------------
# asnEnumeration : Encode enumeration value.
#-----------------------------------------------------------------------------

proc ::asn::asnEnumeration {number} {
    asnIntegerOrEnum 0a $number
}

#-----------------------------------------------------------------------------
# asnIntegerOrEnum : Common code for Integers and Enumerations
#                    No Bignum version, as we do not expect large Enums.
#-----------------------------------------------------------------------------

proc ::asn::asnIntegerOrEnum {tag number} {
    # The integer tag is 0x02 , the Enum Tag 0x0a otherwise identical. 
    # The length is 1, 2, 3, or 4, coded in a
    # single byte. This can be done directly, no need to go through
    # asnLength. The value itself is written in big-endian.

    # Known bug/issue: The command cannot handle very wide integers, i.e.
    # anything above 8 bytes length. Use asnBignumInteger for those.
    
    # check if we really have an int
    set num $number
    incr num
    
    if {($number >= -128) && ($number < 128)} {
        return [binary format H2H2c $tag 01 $number]
    }
    if {($number >= -32768) && ($number < 32768)} {
        return [binary format H2H2S $tag 02 $number]
    }
    if {($number >= -8388608) && ($number < 8388608)} {
        set numberb [expr {$number & 0xFFFF}]
        set numbera [expr {($number >> 16) & 0xFF}]
        return [binary format H2H2cS $tag 03 $numbera $numberb]
    }
    if {($number >= -2147483648) && ($number < 2147483648)} {
        return [binary format H2H2I $tag 04 $number]
    }
    if {($number >= -549755813888) && ($number < 549755813888)} {
        set numberb [expr {$number & 0xFFFFFFFF}]
        set numbera [expr {($number >> 32) & 0xFF}]
        return [binary format H2H2cI $tag 05 $numbera $numberb]
    }
    if {($number >= -140737488355328) && ($number < 140737488355328)} {
        set numberb [expr {$number & 0xFFFFFFFF}]
        set numbera [expr {($number >> 32) & 0xFFFF}]
        return [binary format H2H2SI $tag 06 $numbera $numberb]        
    }
    if {($number >= -36028797018963968) && ($number < 36028797018963968)} {
        set numberc [expr {$number & 0xFFFFFFFF}]
        set numberb [expr {($number >> 32) & 0xFFFF}]
        set numbera [expr {($number >> 48) & 0xFF}]
        return [binary format H2H2cSI $tag 07 $numbera $numberb $numberc]        
    }    
    if {($number >= -9223372036854775808) && ($number <= 9223372036854775807)} {
        return [binary format H2H2W $tag 08 $number]
    }
    return -code error "Integer value to large to encode, use asnBigInteger" 
}

#-----------------------------------------------------------------------------
# asnBigInteger : Encode a long integer value using math::bignum
#-----------------------------------------------------------------------------

proc ::asn::asnBigInteger {bignum} {
    # require math::bignum only if it is used
    package require math::bignum
    
    # this is a hack to check for bignum...
    if {[llength $bignum] < 2 || ([lindex $bignum 0] ne "bignum")} {
        return -code error "expected math::bignum value got \"$bignum\""
    }
    if {[math::bignum::sign $bignum]} {
        # generate two's complement form
        set bits [math::bignum::bits $bignum]
        set padding [expr {$bits % 8}]
        set len [expr {int(ceil($bits / 8.0))}]
        if {$padding == 0} {
            # we need a complete extra byte for the sign
            # unless this is a base 2 multiple
            set test [math::bignum::fromstr 0]
            math::bignum::setbit test [expr {$bits-1}]
            if {[math::bignum::ne [math::bignum::abs $bignum] $test]} {
                incr len
            }
        }
        set exp [math::bignum::pow \
		    [math::bignum::fromstr 256] \
		    [math::bignum::fromstr $len]]
        set bignum [math::bignum::add $bignum $exp]
        set hex [math::bignum::tostr $bignum 16]
    } else {
        set bits [math::bignum::bits $bignum]
        if {($bits % 8) == 0 && $bits > 0} {
            set pad "00"
        } else {
            set pad ""
        }
        set hex $pad[math::bignum::tostr $bignum 16]
    }
    if {[string length $hex]%2} {
        set hex "0$hex"
    }
    set octets [expr {(([string length $hex]+1)/2)}]
    return [binary format H2a*H* 02 [asnLength $octets] $hex]   
}


#-----------------------------------------------------------------------------
# asnBoolean : Encode a boolean value.
#-----------------------------------------------------------------------------

proc ::asn::asnBoolean {bool} {
    # The boolean tag is 0x01. The length is always 1, coded in
    # a single byte. This can be done directly, no need to go through
    # asnLength. The value itself is written in big-endian.

    return [binary format H2H2c 01 01 [expr {$bool ? 0x0FF : 0x0}]]
}

#-----------------------------------------------------------------------------
# asnOctetString : Encode a string of arbitrary bytes
#-----------------------------------------------------------------------------

proc ::asn::asnOctetString {string} {
    # The octet tag is 0x04. The length is arbitrary, so we need
    # 'asnLength' for full coding of the length.

    set len [string length $string]
    return [binary format H2a*a$len 04 [asnLength $len] $string]
}

#-----------------------------------------------------------------------------
# asnNull : Encode a null value
#-----------------------------------------------------------------------------

proc ::asn::asnNull {} {
    # Null has only one valid encoding
    return \x05\x00
}

#-----------------------------------------------------------------------------
# asnBitstring : Encode a Bit String value
#-----------------------------------------------------------------------------

proc ::asn::asnBitString {bitstring} {
    # The bit string tag is 0x03.
    # Bit strings can be either simple or constructed
    # we always use simple encoding
    
    set bitlen [string length $bitstring]
    set padding [expr {(8 - ($bitlen % 8)) % 8}]
    set len [expr {($bitlen / 8) + 1}]
    if {$padding != 0} { incr len }

    return [binary format H2a*cB* 03 [asnLength $len] $padding $bitstring]    
}

#-----------------------------------------------------------------------------
# asnUTCTime : Encode an UTC time string
#-----------------------------------------------------------------------------

proc ::asn::asnUTCTime {UTCtimestring} {
    # the utc time tag is 0x17.
    # 
    # BUG: we do not check the string for well formedness
    
    set ascii [encoding convertto ascii $UTCtimestring]
    set len [string length $ascii]
    return [binary format H2a*a* 17 [asnLength $len] $ascii]
}

#-----------------------------------------------------------------------------
# asnPrintableString : Encode a printable string
#-----------------------------------------------------------------------------
namespace eval asn {
    variable nonPrintableChars {[^ A-Za-z0-9'()+,.:/?=-]}
}	
proc ::asn::asnPrintableString {string} {
    # the printable string tag is 0x13
    variable nonPrintableChars
    # it is basically a restricted ascii string
    if {[regexp $nonPrintableChars $string ]} {
        return -code error "Illegal character in PrintableString."
    }
    
    # check characters
    set ascii [encoding convertto ascii $string]
    return [asnEncodeString 13 $ascii]
}

#-----------------------------------------------------------------------------
# asnIA5String : Encode an Ascii String
#-----------------------------------------------------------------------------
proc ::asn::asnIA5String {string} {
    # the IA5 string tag is 0x16
    # check for extended charachers
    if {[string length $string]!=[string bytelength $string]} {
	return -code error "Illegal character in IA5String"
    }
    set ascii [encoding convertto ascii $string]
    return [asnEncodeString 16 $ascii]
}

#-----------------------------------------------------------------------------
# asnNumericString : Encode a Numeric String type
#-----------------------------------------------------------------------------
namespace eval asn {
    variable nonNumericChars {[^0-9 ]}
}
proc ::asn::asnNumericString {string} {
    # the Numeric String type has tag 0x12
    variable nonNumericChars
    if {[regexp $nonNumericChars $string]} {
        return -code error "Illegal character in Numeric String."
    }
    
    return [asnEncodeString 12 $string]
}
#----------------------------------------------------------------------
# asnBMPString: Encode a Tcl string as Basic Multinligval (UCS2) string
#-----------------------------------------------------------------------
proc asn::asnBMPString  {string} {
    if {$::tcl_platform(byteOrder) eq "littleEndian"} {
	set bytes ""
	foreach {lo hi} [split [encoding convertto unicode $string] ""] {
	    append bytes $hi $lo
	}	
    } else {
	set bytes [encoding convertto unicode $string]
    }
    return [asnEncodeString 1e $bytes]
}	
#---------------------------------------------------------------------------
# asnUTF8String: encode tcl string as UTF8 String
#----------------------------------------------------------------------------
proc asn::asnUTF8String {string} {
    return [asnEncodeString 0c [encoding convertto utf-8 $string]]
}
#-----------------------------------------------------------------------------
# asnEncodeString : Encode an RestrictedCharacter String
#-----------------------------------------------------------------------------
proc ::asn::asnEncodeString {tag string} {
    set len [string length $string]
    return [binary format H2a*a$len $tag [asnLength $len] $string]    
}

#-----------------------------------------------------------------------------
# asnObjectIdentifier : Encode an Object Identifier value
#-----------------------------------------------------------------------------
proc ::asn::asnObjectIdentifier {oid} {
    # the object identifier tag is 0x06
    
    if {[llength $oid] < 2} {
        return -code error "OID must have at least two subidentifiers."
    }
    
    # basic check that it is valid
    foreach identifier $oid {
        if {$identifier < 0} {
            return -code error \
		"Malformed OID. Identifiers must be positive Integers."
        }
    }
    
    if {[lindex $oid 0] > 2} {
            return -code error "First subidentifier must be 0,1 or 2"
    }
    if {[lindex $oid 1] > 39} {
            return -code error \
		"Second subidentifier must be between 0 and 39"
    }
    
    # handle the special cases directly
    switch [llength $oid] {
        2  {  return [binary format H2H2c 06 01 \
		[expr {[lindex $oid 0]*40+[lindex $oid 1]}]] }
        default {
              # This can probably be written much shorter. 
              # Just a first try that works...
              #
              set octets [binary format c \
		[expr {[lindex $oid 0]*40+[lindex $oid 1]}]]
              foreach identifier [lrange $oid 2 end] {
                  set d 128
                  if {$identifier < 128} {
                    set subidentifier [list $identifier]
                  } else {  
                    set subidentifier [list]
                    # find the largest divisor
                    
                    while {($identifier / $d) >= 128} { 
			set d [expr {$d * 128}] 
		    }
                    # and construct the subidentifiers
                    set remainder $identifier
                    while {$d >= 128} {
                        set coefficient [expr {($remainder / $d) | 0x80}]
                        set remainder [expr {$remainder % $d}]
                        set d [expr {$d / 128}]
                        lappend subidentifier $coefficient
                    }
                    lappend subidentifier $remainder
                  }
                  append octets [binary format c* $subidentifier]
              }
              return [binary format H2a*a* 06 \
		      [asnLength [string length $octets]] $octets]
        }
    }

}

#-----------------------------------------------------------------------------
# asnGetResponse : Read a ASN response from a channel.
#-----------------------------------------------------------------------------

proc ::asn::asnGetResponse {sock data_var} {
    upvar 1 $data_var data

    # We expect a sequence here (tag 0x30). The code below is an
    # inlined replica of 'asnGetSequence', modified for reading from a
    # channel instead of a string.

    set tag [read $sock 1]

    if {$tag == "\x30"} {
    # The following code is a replica of 'asnGetLength', modified
    # for reading the bytes from the channel instead of a string.

        set len1 [read $sock 1]
        binary scan $len1 c num
        set length [expr {($num + 0x100) % 0x100}]

        if {$length  >= 0x080} {
        # The byte the read is not the length, but a prefix, and
        # the lower nibble tells us how many bytes follow.

            set len_length  [expr {$length & 0x7f}]

        # BUG: We should not perform the value extraction for an
        # BUG: improper length. It wastes cycles, and here it can
        # BUG: cause us trouble, reading more data than there is
        # BUG: on the channel. Depending on the channel
        # BUG: configuration an attacker can induce us to block,
        # BUG: causing a denial of service.
            set lengthBytes [read $sock $len_length]

            switch $len_length {
                1 {
            binary scan $lengthBytes     c length 
            set length [expr {($length + 0x100) % 0x100}]
                }
                2 { binary scan $lengthBytes     S length }
                3 { binary scan \x00$lengthBytes I length }
                4 { binary scan $lengthBytes     I length }
                default {
                    return -code error \
			"length information too long ($len_length)"
                }
            }
        }

    # Now that the length is known we get the remainder,
    # i.e. payload, and construct proper in-memory BER encoded
    # sequence.

        set rest [read $sock $length]
        set data [binary format aa*a$length $tag [asnLength $length] $rest]
    }  else {
    # Generate an error message if the data is not a sequence as
    # we expected.

        set tag_hex ""
        binary scan $tag H2 tag_hex
        return -code error "unknown start tag [string length $tag] $tag_hex"
    }
}

if {[package vsatisfies [package present Tcl] 8.5.0]} {
##############################################################################
# Code for 8.5
##############################################################################
#-----------------------------------------------------------------------------
# asnGetByte (8.5 version) : Retrieve a single byte from the data (unsigned)
#-----------------------------------------------------------------------------

proc ::asn::asnGetByte {data_var byte_var} {
    upvar 1 $data_var data $byte_var byte
    
    binary scan [string index $data 0] cu byte
    set data [string range $data 1 end]

    return
}

#-----------------------------------------------------------------------------
# asnPeekByte (8.5 version) : Retrieve a single byte from the data (unsigned) 
#               without removing it.
#-----------------------------------------------------------------------------

proc ::asn::asnPeekByte {data_var byte_var {offset 0}} {
    upvar 1 $data_var data $byte_var byte
    
    binary scan [string index $data $offset] cu byte

    return
}

#-----------------------------------------------------------------------------
# asnGetLength (8.5 version) : Decode an ASN length value (See notes)
#-----------------------------------------------------------------------------

proc ::asn::asnGetLength {data_var length_var} {
    upvar 1 $data_var data  $length_var length

    asnGetByte data length
    if {$length == 0x080} {
        return -code error "Indefinite length BER encoding not yet supported"
    }
    if {$length > 0x080} {
    # The retrieved byte is a prefix value, and the integer in the
    # lower nibble tells us how many bytes were used to encode the
    # length data following immediately after this prefix.

        set len_length [expr {$length & 0x7f}]
        
        if {[string length $data] < $len_length} {
            return -code error \
		"length information invalid, not enough octets left" 
        }
        
        asnGetBytes data $len_length lengthBytes

        switch $len_length {
            1 { binary scan $lengthBytes     cu length }
            2 { binary scan $lengthBytes     Su length }
            3 { binary scan \x00$lengthBytes Iu length }
            4 { binary scan $lengthBytes     Iu length }
            default {                
                binary scan $lengthBytes H* hexstr
		scan $hexstr %llx length
            }
        }
    }
    return
}

} else {
##############################################################################
# Code for Tcl 8.4
##############################################################################
#-----------------------------------------------------------------------------
# asnGetByte : Retrieve a single byte from the data (unsigned)
#-----------------------------------------------------------------------------

proc ::asn::asnGetByte {data_var byte_var} {
    upvar 1 $data_var data $byte_var byte
    
    binary scan [string index $data 0] c byte
    set byte [expr {($byte + 0x100) % 0x100}]  
    set data [string range $data 1 end]

    return
}

#-----------------------------------------------------------------------------
# asnPeekByte : Retrieve a single byte from the data (unsigned) 
#               without removing it.
#-----------------------------------------------------------------------------

proc ::asn::asnPeekByte {data_var byte_var {offset 0}} {
    upvar 1 $data_var data $byte_var byte
    
    binary scan [string index $data $offset] c byte
    set byte [expr {($byte + 0x100) % 0x100}]  

    return
}

#-----------------------------------------------------------------------------
# asnGetLength : Decode an ASN length value (See notes)
#-----------------------------------------------------------------------------

proc ::asn::asnGetLength {data_var length_var} {
    upvar 1 $data_var data  $length_var length

    asnGetByte data length
    if {$length == 0x080} {
        return -code error "Indefinite length BER encoding not yet supported"
    }
    if {$length > 0x080} {
    # The retrieved byte is a prefix value, and the integer in the
    # lower nibble tells us how many bytes were used to encode the
    # length data following immediately after this prefix.

        set len_length [expr {$length & 0x7f}]
        
        if {[string length $data] < $len_length} {
            return -code error \
		"length information invalid, not enough octets left" 
        }
        
        asnGetBytes data $len_length lengthBytes

        switch $len_length {
            1 {
        # Efficiently coded data will not go through this
        # path, as small length values can be coded directly,
        # without a prefix.

            binary scan $lengthBytes     c length 
            set length [expr {($length + 0x100) % 0x100}]
            }
            2 { binary scan $lengthBytes     S length 
            set length [expr {($length + 0x10000) % 0x10000}]
            }
            3 { binary scan \x00$lengthBytes I length 
            set length [expr {($length + 0x1000000) % 0x1000000}]
            }
            4 { binary scan $lengthBytes     I length 
            set length [expr {(wide($length) + 0x100000000) % 0x100000000}]
            }
            default {                
                binary scan $lengthBytes H* hexstr
                # skip leading zeros which are allowed by BER
                set hexlen [string trimleft $hexstr 0] 
                # check if it fits into a 64-bit signed integer
                if {[string length $hexlen] > 16} {
                    return -code error -errorcode {ARITH IOVERFLOW 
                            {Length value too large for normal use, try asnGetBigLength}} \
			    "Length value to large"
                } elseif {  [string length $hexlen] == 16 \
			&& ([string index $hexlen 0] & 0x8)} { 
                    # check most significant bit, if set we need bignum
                    return -code error -errorcode {ARITH IOVERFLOW 
                            {Length value too large for normal use, try asnGetBigLength}} \
			    "Length value to large"
                } else {
                    scan $hexstr "%lx" length
                }
            }
        }
    }
    return
}

} 

#-----------------------------------------------------------------------------
# asnRetag: Remove an explicit tag with the real newTag
#
#-----------------------------------------------------------------------------
proc ::asn::asnRetag {data_var newTag} {
    upvar 1 $data_var data 
    set tag ""
    set type ""
    set len [asnPeekTag data tag type dummy]	
    asnGetBytes data $len tagbytes
    set data [binary format c* $newTag]$data
}

#-----------------------------------------------------------------------------
# asnGetBytes : Retrieve a block of 'length' bytes from the data.
#-----------------------------------------------------------------------------

proc ::asn::asnGetBytes {data_var length bytes_var} {
    upvar 1 $data_var data  $bytes_var bytes

    incr length -1
    set bytes [string range $data 0 $length]
    incr length
    set data [string range $data $length end]

    return
}

#-----------------------------------------------------------------------------
# asnPeekTag : Decode the tag value
#-----------------------------------------------------------------------------

proc ::asn::asnPeekTag {data_var tag_var tagtype_var constr_var} {
    upvar 1 $data_var data $tag_var tag $tagtype_var tagtype $constr_var constr
    
    set type 0	
    set offset 0
    asnPeekByte data type $offset
    # check if we have a simple tag, < 31, which fits in one byte
     
    set tval [expr {$type & 0x1f}]
    if {$tval == 0x1f} {
	# long tag, max 64-bit with Tcl 8.4, unlimited with 8.5 bignum
	asnPeekByte data tagbyte [incr offset]
	set tval [expr {wide($tagbyte & 0x7f)}]
	while {($tagbyte & 0x80)} {
	    asnPeekByte data tagbyte [incr offset] 
	    set tval [expr {($tval << 7) + ($tagbyte & 0x7f)}]
	}
    } 

    set tagtype [lindex {UNIVERSAL APPLICATION CONTEXT PRIVATE} \
	[expr {($type & 0xc0) >>6}]]
    set tag $tval
    set constr [expr {($type & 0x20) > 0}]

    return [incr offset]	
}

#-----------------------------------------------------------------------------
# asnTag : Build a tag value
#-----------------------------------------------------------------------------

proc ::asn::asnTag {tagnumber {class UNIVERSAL} {tagstyle P}} {
    set first 0
    if {$tagnumber < 31} {
	# encode everything in one byte
	set first $tagnumber	
	set bytes [list]
    } else {
	# multi-byte tag
	set first 31
	set bytes [list [expr {$tagnumber & 0x7f}]]
	set tagnumber [expr {$tagnumber >> 7}]
	while {$tagnumber > 0} {
	    lappend bytes [expr {($tagnumber & 0x7f)+0x80}]
	    set tagnumber [expr {$tagnumber >>7}]	
	}

    }
    
    if {$tagstyle eq "C" || $tagstyle == 1 } {incr first 32}
    switch -glob -- $class {
	U* {		    ;# UNIVERSAL } 
	A* { incr first 64  ;# APPLICATION }
	C* { incr first 128 ;# CONTEXT }
	P* { incr first 192 ;# PRIVATE }
	default {
	    return -code error "Unknown tag class \"$class\""
	}	
    }
    if {[llength $bytes] > 0} {
	# long tag
	set rbytes [list]
	for {set i [expr {[llength $bytes]-1}]} {$i >= 0} {incr i -1} {
	    lappend rbytes [lindex $bytes $i]
	}
	return [binary format cc* $first $rbytes ]
    } 
    return [binary format c $first]
}



#-----------------------------------------------------------------------------
# asnGetBigLength : Retrieve a length that can not be represented in 63-bit
#-----------------------------------------------------------------------------

proc ::asn::asnGetBigLength {data_var biglength_var} {

    # Does any real world code really need this? 
    # If we encounter this, we are doomed to fail anyway, 
    # (there would be an Exabyte inside the data_var, )
    #
    # So i implement it just for completness.
    # 
    package require math::bignum
    
    upvar 1 $data_var data  $biglength_var length

    asnGetByte data length
    if {$length == 0x080} {
        return -code error "Indefinite length BER encoding not yet supported"
    }
    if {$length > 0x080} {
    # The retrieved byte is a prefix value, and the integer in the
    # lower nibble tells us how many bytes were used to encode the
    # length data following immediately after this prefix.

        set len_length [expr {$length & 0x7f}]
        
        if {[string length $data] < $len_length} {
            return -code error \
		"length information invalid, not enough octets left" 
        }
        
        asnGetBytes data $len_length lengthBytes
        binary scan $lengthBytes H* hexlen
        set length [math::bignum::fromstr $hexlen 16]
    }
    return
}

#-----------------------------------------------------------------------------
# asnGetInteger : Retrieve integer.
#-----------------------------------------------------------------------------

proc ::asn::asnGetInteger {data_var int_var} {
    # Tag is 0x02. 

    upvar 1 $data_var data $int_var int

    asnGetByte   data tag

    if {$tag != 0x02} {
        return -code error \
            [format "Expected Integer (0x02), but got %02x" $tag]
    }

    asnGetLength data len
    asnGetBytes  data $len integerBytes

    set int ?

    switch $len {
        1 { binary scan $integerBytes     c int }
        2 { binary scan $integerBytes     S int }
        3 { 
            # check for negative int and pad 
            scan [string index $integerBytes 0] %c byte
            if {$byte & 128} {
                binary scan \xff$integerBytes I int
            } else {
                binary scan \x00$integerBytes I int 
            }
          }
        4 { binary scan $integerBytes     I int }
        5 -
        6 -
        7 -
        8 {
            # check for negative int and pad
            scan [string index $integerBytes 0] %c byte
            if {$byte & 128} {
                set pad [string repeat \xff [expr {8-$len}]]
            } else {
                set pad [string repeat \x00 [expr {8-$len}]]
            }
            binary scan $pad$integerBytes W int 
        }
        default {
        # Too long, or prefix coding was used.
            return -code error "length information too long"
        }
    }
    return
}

#-----------------------------------------------------------------------------
# asnGetBigInteger : Retrieve a big integer.
#-----------------------------------------------------------------------------

proc ::asn::asnGetBigInteger {data_var bignum_var} {
    # require math::bignum only if it is used
    package require math::bignum

    # Tag is 0x02. We expect that the length of the integer is coded with
    # maximal efficiency, i.e. without a prefix 0x81 prefix. If a prefix
    # is used this decoder will fail.

    upvar 1 $data_var data $bignum_var bignum

    asnGetByte   data tag

    if {$tag != 0x02} {
        return -code error \
            [format "Expected Integer (0x02), but got %02x" $tag]
    }

    asnGetLength data len
    asnGetBytes  data $len integerBytes
    
    binary scan $integerBytes H* hex
    set bignum [math::bignum::fromstr $hex 16]
    set bits [math::bignum::bits $bignum]
    set exp [math::bignum::pow \
		[math::bignum::fromstr 2] \
		[math::bignum::fromstr $bits]]
    set big [math::bignum::sub $bignum $exp]
    set bignum $big
    
    return    
}



#-----------------------------------------------------------------------------
# asnGetEnumeration : Retrieve an enumeration id
#-----------------------------------------------------------------------------

proc ::asn::asnGetEnumeration {data_var enum_var} {
    # This is like 'asnGetInteger', except for a different tag.

    upvar 1 $data_var data $enum_var enum

    asnGetByte   data tag

    if {$tag != 0x0a} {
        return -code error \
            [format "Expected Enumeration (0x0a), but got %02x" $tag]
    }

    asnGetLength data len
    asnGetBytes  data $len integerBytes
    set enum ?

    switch $len {
        1 { binary scan $integerBytes     c enum }
        2 { binary scan $integerBytes     S enum }
        3 { binary scan \x00$integerBytes I enum }
        4 { binary scan $integerBytes     I enum }
        default {
            return -code error "length information too long"
        }
    }
    return
}

#-----------------------------------------------------------------------------
# asnGetOctetString : Retrieve arbitrary string.
#-----------------------------------------------------------------------------

proc ::asn::asnGetOctetString {data_var string_var} {
    # Here we need the full decoder for length data.

    upvar 1 $data_var data $string_var string
    
    asnGetByte data tag
    if {$tag != 0x04} { 
        return -code error \
            [format "Expected Octet String (0x04), but got %02x" $tag]
    }
    asnGetLength data length
    asnGetBytes  data $length temp
    set string $temp
    return
}

#-----------------------------------------------------------------------------
# asnGetSequence : Retrieve Sequence data for further decoding.
#-----------------------------------------------------------------------------

proc ::asn::asnGetSequence {data_var sequence_var} {
    # Here we need the full decoder for length data.

    upvar 1 $data_var data $sequence_var sequence

    asnGetByte data tag
    if {$tag != 0x030} { 
        return -code error \
            [format "Expected Sequence (0x30), but got %02x" $tag]
    }    
    asnGetLength data length
    asnGetBytes  data $length temp
    set sequence $temp
    return
}

#-----------------------------------------------------------------------------
# asnGetSet : Retrieve Set data for further decoding.
#-----------------------------------------------------------------------------

proc ::asn::asnGetSet {data_var set_var} {
    # Here we need the full decoder for length data.

    upvar 1 $data_var data $set_var set

    asnGetByte data tag
    if {$tag != 0x031} { 
        return -code error \
            [format "Expected Set (0x31), but got %02x" $tag]
    }    
    asnGetLength data length
    asnGetBytes  data $length temp
    set set $temp
    return
}

#-----------------------------------------------------------------------------
# asnGetApplication
#-----------------------------------------------------------------------------

proc ::asn::asnGetApplication {data_var appNumber_var {content_var {}} {encodingType_var {}} } {
    upvar 1 $data_var data $appNumber_var appNumber

    asnGetByte   data tag
    asnGetLength data length

    if {($tag & 0xC0) != 0x40} {
        return -code error \
            [format "Expected Application, but got %02x" $tag]
    }    
    if {$encodingType_var != {}} {
	upvar 1 $encodingType_var encodingType
	set encodingType [expr {($tag & 0x20) > 0}]
    }
    set appNumber [expr {$tag & 0x1F}]
	if {[string length $content_var]} {
		upvar 1 $content_var content
		asnGetBytes data $length content
	}	
    return
}

#-----------------------------------------------------------------------------
# asnGetBoolean: decode a boolean value
#-----------------------------------------------------------------------------

proc asn::asnGetBoolean {data_var bool_var} {
    upvar 1 $data_var data $bool_var bool

    asnGetByte data tag
    if {$tag != 0x01} {
        return -code error \
            [format "Expected Boolean (0x01), but got %02x" $tag]
    }

    asnGetLength data length
    asnGetByte data byte
    set bool [expr {$byte == 0 ? 0 : 1}]    
    return
}

#-----------------------------------------------------------------------------
# asnGetUTCTime: Extract an UTC Time string from the data. Returns a string
#                representing an UTC Time.
#
#-----------------------------------------------------------------------------

proc asn::asnGetUTCTime {data_var utc_var} {
    upvar 1 $data_var data $utc_var utc

    asnGetByte data tag
    if {$tag != 0x17} {
        return -code error \
            [format "Expected UTCTime (0x17), but got %02x" $tag]
    }

    asnGetLength data length
    asnGetBytes data $length bytes
    
    # this should be ascii, make it explicit
    set bytes [encoding convertfrom ascii $bytes]
    binary scan $bytes a* utc
    
    return
}


#-----------------------------------------------------------------------------
# asnGetBitString: Extract a Bit String value (a string of 0/1s) from the
#                  ASN.1 data.
#
#-----------------------------------------------------------------------------

proc asn::asnGetBitString {data_var bitstring_var} {
    upvar 1 $data_var data $bitstring_var bitstring

    asnGetByte data tag
    if {$tag != 0x03} {
        return -code error \
            [format "Expected Bit String (0x03), but got %02x" $tag]
    }
    
    asnGetLength data length
    # get the number of padding bits used at the end
    asnGetByte data padding
    incr length -1
    asnGetBytes data $length bytes
    binary scan $bytes B* bits
    
    # cut off the padding bits
    set bits [string range $bits 0 end-$padding]
    set bitstring $bits
}

#-----------------------------------------------------------------------------
# asnGetObjectIdentifier: Decode an ASN.1 Object Identifier (OID) into
#                         a Tcl list of integers.
#-----------------------------------------------------------------------------

proc asn::asnGetObjectIdentifier {data_var oid_var} {
      upvar 1 $data_var data $oid_var oid

      asnGetByte data tag
      if {$tag != 0x06} {
        return -code error \
            [format "Expected Object Identifier (0x06), but got %02x" $tag]  
      }
      asnGetLength data length
      
      # the first byte encodes the OID parts in position 0 and 1
      asnGetByte data val
      set oid [expr {$val / 40}]
      lappend oid [expr {$val % 40}]
      incr length -1
      
      # the next bytes encode the remaining parts of the OID
      set bytes [list]
      set incomplete 0
      while {$length} {
        asnGetByte data octet
        incr length -1
        if {$octet < 128} {
            set oidval $octet
            set mult 128
            foreach byte $bytes {
                if {$byte != {}} {
                incr oidval [expr {$mult*$byte}]    
                set mult [expr {$mult*128}]
                }
            }
            lappend oid $oidval
            set bytes [list]
            set incomplete 0
        } else {
            set byte [expr {$octet-128}]
            set bytes [concat [list $byte] $bytes]
            set incomplete 1
        }                      
      }
      if {$incomplete} {
        return -code error "OID Data is incomplete, not enough octets."
      }
      return
}

#-----------------------------------------------------------------------------
# asnGetContext: Decode an explicit context tag 
#
#-----------------------------------------------------------------------------

proc ::asn::asnGetContext {data_var contextNumber_var {content_var {}} {encodingType_var {}}} {
    upvar 1 $data_var data $contextNumber_var contextNumber 
    
    asnGetByte   data tag
    asnGetLength data length

    if {($tag & 0xC0) != 0x80} {
        return -code error \
            [format "Expected Context, but got %02x" $tag]
    }    
    if {$encodingType_var != {}} { 
	upvar 1 $encodingType_var encodingType 
	set encodingType [expr {($tag & 0x20) > 0}]
    }
    set contextNumber [expr {$tag & 0x1F}]
	if {[string length $content_var]} {
		upvar 1 $content_var content
		asnGetBytes data $length content
	}	
    return
}


#-----------------------------------------------------------------------------
# asnGetNumericString: Decode a Numeric String from the data
#-----------------------------------------------------------------------------

proc ::asn::asnGetNumericString {data_var print_var} {
    upvar 1 $data_var data $print_var print

    asnGetByte data tag
    if {$tag != 0x12} {
        return -code error \
            [format "Expected Numeric String (0x12), but got %02x" $tag]  
    }
    asnGetLength data length 
    asnGetBytes data $length string
    set print [encoding convertfrom ascii $string]
    return
}

#-----------------------------------------------------------------------------
# asnGetPrintableString: Decode a Printable String from the data
#-----------------------------------------------------------------------------

proc ::asn::asnGetPrintableString {data_var print_var} {
    upvar 1 $data_var data $print_var print

    asnGetByte data tag
    if {$tag != 0x13} {
        return -code error \
            [format "Expected Printable String (0x13), but got %02x" $tag]  
    }
    asnGetLength data length 
    asnGetBytes data $length string
    set print [encoding convertfrom ascii $string]
    return
}

#-----------------------------------------------------------------------------
# asnGetIA5String: Decode a IA5(ASCII) String from the data
#-----------------------------------------------------------------------------

proc ::asn::asnGetIA5String {data_var print_var} {
    upvar 1 $data_var data $print_var print

    asnGetByte data tag
    if {$tag != 0x16} {
        return -code error \
            [format "Expected IA5 String (0x16), but got %02x" $tag]  
    }
    asnGetLength data length 
    asnGetBytes data $length string
    set print [encoding convertfrom ascii $string]
    return
}
#------------------------------------------------------------------------
# asnGetBMPString: Decode Basic Multiningval (UCS2 string) from data
#------------------------------------------------------------------------
proc asn::asnGetBMPString {data_var print_var} {
    upvar 1 $data_var data $print_var print
    asnGetByte data tag
    if {$tag != 0x1e} {
        return -code error \
            [format "Expected BMP String (0x1e), but got %02x" $tag]  
    }
    asnGetLength data length 
	asnGetBytes data $length string
	if {$::tcl_platform(byteOrder) eq "littleEndian"} {
		set str2 ""
		foreach {hi lo} [split $string ""] {
			append str2 $lo $hi
		}
	} else {
		set str2 $string
	}
	set print [encoding convertfrom unicode $str2]
	return
}	
#------------------------------------------------------------------------
# asnGetUTF8String: Decode UTF8 string from data
#------------------------------------------------------------------------
proc asn::asnGetUTF8String {data_var print_var} {
    upvar 1 $data_var data $print_var print
    asnGetByte data tag
    if {$tag != 0x0c} {
        return -code error \
            [format "Expected UTF8 String (0x0c), but got %02x" $tag]  
    }
    asnGetLength data length 
	asnGetBytes data $length string
	#there should be some error checking to see if input is
	#properly-formatted utf8
	set print [encoding convertfrom utf-8 $string]
	
	return
}	
#-----------------------------------------------------------------------------
# asnGetNull: decode a NULL value
#-----------------------------------------------------------------------------

proc ::asn::asnGetNull {data_var} {
    upvar 1 $data_var data 

    asnGetByte data tag
    if {$tag != 0x05} {
        return -code error \
            [format "Expected NULL (0x05), but got %02x" $tag]
    }

    asnGetLength data length
    asnGetBytes data $length bytes
    
    # we do not check the null data, all bytes must be 0x00
    
    return
}

#----------------------------------------------------------------------------
# MultiType string routines
#----------------------------------------------------------------------------

namespace eval asn {
	variable stringTypes
	array set stringTypes {
		12 NumericString 
		13 PrintableString 
		16 IA5String 
		1e BMPString 
		0c UTF8String 
		14 T61String
		15 VideotexString
		1a VisibleString
		1b GeneralString
		1c UniversalString
	}	
	variable defaultStringType UTF8
}	
#---------------------------------------------------------------------------
# asnGetString - get readable string automatically detecting its type
#---------------------------------------------------------------------------
proc ::asn::asnGetString {data_var print_var {type_var {}}} {
	variable stringTypes
	upvar 1 $data_var data $print_var print
	asnPeekByte data tag
	set tag [format %02x $tag]
	if {![info exists stringTypes($tag)]} {
		return -code error "Expected one of string types, but got $tag"
	}
	asnGet$stringTypes($tag) data print
	if {[string length $type_var]} {
		upvar $type_var type
		set type $stringTypes($tag)
	}	
}
#---------------------------------------------------------------------
# defaultStringType - set or query default type for unrestricted strings
#---------------------------------------------------------------------
proc ::asn::defaultStringType {{type {}}} {
	variable defaultStringType
	if {![string length $type]} {
		return $defaultStringType
	}
	if {$type ne "BMP" && $type ne "UTF8"} {
		return -code error "Invalid default string type. Should be one of BMP, UTF8"
	}
	set defaultStringType $type
	return
}	

#---------------------------------------------------------------------------
# asnString - encode readable string into most restricted type possible
#---------------------------------------------------------------------------

proc ::asn::asnString {string} {
	variable nonPrintableChars
	variable nonNumericChars
	if {[string length $string]!=[string bytelength $string]} {
	# There are non-ascii character
		variable defaultStringType
		return [asn${defaultStringType}String $string]
	} elseif {![regexp $nonNumericChars $string]} {
		return [asnNumericString $string]
	} elseif {![regexp $nonPrintableChars $string]} {
		return [asnPrintableString $string]
	} else {
		return [asnIA5String $string]
	}	
}

#-----------------------------------------------------------------------------
package provide asn 0.8.3

<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<












































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































Deleted scriptlibs/tcllib1.12/asn/pkgIndex.tcl.

1
2
3
4
# Tcl package index file, version 1.1

if {![package vsatisfies [package provide Tcl] 8.4]} {return}
package ifneeded asn 0.8.3 [list source [file join $dir asn.tcl]]
<
<
<
<








Deleted scriptlibs/tcllib1.12/base32/base32.tcl.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
# -*- tcl -*-
# This code is hereby put into the public domain.
# ### ### ### ######### ######### #########
## Overview
# Base32 encoding and decoding of small strings.
#
# Management code for switching between Tcl and C accelerated
# implementations.
#
# RCS: @(#) $Id: base32.tcl,v 1.2 2006/10/13 05:39:49 andreas_kupries Exp $

# @mdgen EXCLUDE: base32_c.tcl

package require Tcl 8.4

namespace eval ::base32 {}

# ### ### ### ######### ######### #########
## Management of base32 std implementations.

# ::base32::LoadAccelerator --
#
#	Loads a named implementation, if possible.
#
# Arguments:
#	key	Name of the implementation to load.
#
# Results:
#	A boolean flag. True if the implementation
#	was successfully loaded; and False otherwise.

proc ::base32::LoadAccelerator {key} {
    variable accel
    set isok 0
    switch -exact -- $key {
	critcl {
	    # Critcl implementation of base32 requires Tcl 8.4.
	    if {![package vsatisfies [package provide Tcl] 8.4]} {return 0}
	    if {[catch {package require tcllibc}]} {return 0}
	    set isok [llength [info commands ::base32::critcl_encode]]
	}
	tcl {
	    variable selfdir
	    if {[catch {source [file join $selfdir base32_tcl.tcl]}]} {return 0}
	    set isok [llength [info commands ::base32::tcl_encode]]
	}
        default {
            return -code error "invalid accelerator $key:\
                must be one of [join [KnownImplementations] {, }]"
        }
    }
    set accel($key) $isok
    return $isok
}

# ::base32::SwitchTo --
#
#	Activates a loaded named implementation.
#
# Arguments:
#	key	Name of the implementation to activate.
#
# Results:
#	None.

proc ::base32::SwitchTo {key} {
    variable accel
    variable loaded

    if {[string equal $key $loaded]} {
	# No change, nothing to do.
	return
    } elseif {![string equal $key ""]} {
	# Validate the target implementation of the switch.

	if {![info exists accel($key)]} {
	    return -code error "Unable to activate unknown implementation \"$key\""
	} elseif {![info exists accel($key)] || !$accel($key)} {
	    return -code error "Unable to activate missing implementation \"$key\""
	}
    }

    # Deactivate the previous implementation, if there was any.

    if {![string equal $loaded ""]} {
	foreach c {encode decode} {
	    rename ::base32::$c ::base32::${loaded}_$c
	}
    }

    # Activate the new implementation, if there is any.

    if {![string equal $key ""]} {
	foreach c {encode decode} {
	    rename ::base32::${key}_$c ::base32::$c
	}
    }

    # Remember the active implementation, for deactivation by future
    # switches.

    set loaded $key
    return
}

# ::base32::Implementations --
#
#	Determines which implementations are
#	present, i.e. loaded.
#
# Arguments:
#	None.
#
# Results:
#	A list of implementation keys.

proc ::base32::Implementations {} {
    variable accel
    set res {}
    foreach n [array names accel] {
	if {!$accel($n)} continue
	lappend res $n
    }
    return $res
}

# ::base32::KnownImplementations --
#
#	Determines which implementations are known
#	as possible implementations.
#
# Arguments:
#	None.
#
# Results:
#	A list of implementation keys. In the order
#	of preference, most prefered first.

proc ::base32::KnownImplementations {} {
    return {critcl tcl}
}

proc ::base32::Names {} {
    return {
	critcl {tcllibc based}
	tcl    {pure Tcl}
    }
}

# ### ### ### ######### ######### #########
## Initialization: Data structures.

namespace eval ::base32 {
    variable  selfdir [file dirname [info script]]
    variable  loaded  {}

    variable  accel
    array set accel   {tcl 0 critcl 0}
}

# ### ### ### ######### ######### #########
## Initialization: Choose an implementation,
## most prefered first. Loads only one of the
## possible implementations. And activates it.

namespace eval ::base32 {
    variable e
    foreach e [KnownImplementations] {
	if {[LoadAccelerator $e]} {
	    SwitchTo $e
	    break
	}
    }
    unset e

    namespace export encode decode
}

# ### ### ### ######### ######### #########
## Ready

package provide base32 0.1
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<












































































































































































































































































































































































Deleted scriptlibs/tcllib1.12/base32/base32_c.tcl.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
# base32c.tcl --
#
#       Implementation of a base32 (std) de/encoder for Tcl.
#
# Public domain
#
# RCS: @(#) $Id: base32_c.tcl,v 1.3 2008/01/28 22:58:18 andreas_kupries Exp $

package require critcl
package require Tcl 8.4

namespace eval ::base32 {
    # Supporting code for the main command.
    catch {
	#critcl::cheaders -g
	#critcl::debug memory symbols
    }

    # Main commands, encoder & decoder

    critcl::ccommand critcl_encode {dummy interp objc objv} {
      /* Syntax -*- c -*-
       * critcl_encode string
       */

      unsigned char* buf;
      int           nbuf;

      unsigned char* out;
      unsigned char* at;
      int           nout;

      /*
       * The array used for encoding
       */                     /* 123456789 123456789 123456789 12 */
      static const char map[] = "ABCDEFGHIJKLMNOPQRSTUVWXYZ234567";

#define USAGEE "bitstring"

      if (objc != 2) {
        Tcl_WrongNumArgs (interp, 1, objv, USAGEE);
        return TCL_ERROR;
      }

      buf  = Tcl_GetByteArrayFromObj (objv[1], &nbuf);
      nout = ((nbuf+4)/5)*8;
      out  = (unsigned char*) Tcl_Alloc (nout*sizeof(char));

      for (at = out; nbuf >= 5; nbuf -= 5, buf += 5) {
	*(at++) = map [         (buf[0]>>3)                ];
	*(at++) = map [ 0x1f & ((buf[0]<<2) | (buf[1]>>6)) ];
	*(at++) = map [ 0x1f &  (buf[1]>>1)                ];
	*(at++) = map [ 0x1f & ((buf[1]<<4) | (buf[2]>>4)) ];
	*(at++) = map [ 0x1f & ((buf[2]<<1) | (buf[3]>>7)) ];
	*(at++) = map [ 0x1f &  (buf[3]>>2)                ];
	*(at++) = map [ 0x1f & ((buf[3]<<3) | (buf[4]>>5)) ];
	*(at++) = map [ 0x1f &  (buf[4])                   ];
      }
      if (nbuf > 0) {
	/* Process partials at end. */
	switch (nbuf) {
	case 1:
	  /* |01234567|		 2, padding 6
	   *  xxxxx
	   *       xxx 00
	   */

	  *(at++) = map [        (buf[0]>>3) ];
	  *(at++) = map [ 0x1f & (buf[0]<<2) ];
	  *(at++) = '=';
	  *(at++) = '=';
	  *(at++) = '=';
	  *(at++) = '=';
	  *(at++) = '=';
	  *(at++) = '=';
	  break;
	case 2: /* x3/=4 */
	  /* |01234567|01234567|	 4, padding 4
	   *  xxxxx
	   *       xxx xx
	   *             xxxxx
	   *                  x 0000
	   */

	  *(at++) = map [         (buf[0]>>3)                ];
	  *(at++) = map [ 0x1f & ((buf[0]<<2) | (buf[1]>>6)) ];
	  *(at++) = map [ 0x1f &  (buf[1]>>1)                ];
	  *(at++) = map [ 0x1f &  (buf[1]<<4)                ];
	  *(at++) = '=';
	  *(at++) = '=';
	  *(at++) = '=';
	  *(at++) = '=';
	  break;
	case 3:
	  /* |01234567|01234567|01234567|	 5, padding 3
	   *  xxxxx
	   *       xxx xx
	   *             xxxxx
	   *                  x xxxx
	   *                        xxxx 0
	   */

	  *(at++) = map [         (buf[0]>>3)                ];
	  *(at++) = map [ 0x1f & ((buf[0]<<2) | (buf[1]>>6)) ];
	  *(at++) = map [ 0x1f &  (buf[1]>>1)                ];
	  *(at++) = map [ 0x1f & ((buf[1]<<4) | (buf[2]>>4)) ];
	  *(at++) = map [ 0x1f &  (buf[2]<<1)                ];
	  *(at++) = '=';
	  *(at++) = '=';
	  *(at++) = '=';
	  break;
	case 4:
	  /* |01234567|01234567|01234567|012334567|	 7, padding 1
	   *  xxxxx
	   *       xxx xx
	   *             xxxxx
	   *                  x xxxx
	   *                        xxxx
	   *                             xxxxx
	   *                                  xxxx 0
	   */

	  *(at++) = map [         (buf[0]>>3)                ];
	  *(at++) = map [ 0x1f & ((buf[0]<<2) | (buf[1]>>6)) ];
	  *(at++) = map [ 0x1f &  (buf[1]>>1)                ];
	  *(at++) = map [ 0x1f & ((buf[1]<<4) | (buf[2]>>4)) ];
	  *(at++) = map [ 0x1f & ((buf[2]<<1) | (buf[3]>>7)) ];
	  *(at++) = map [ 0x1f &  (buf[3]>>2)                ];
	  *(at++) = map [ 0x1f &  (buf[3]<<3)                ];
	  *(at++) = '=';
	  break;
	}
      }

      Tcl_SetObjResult (interp, Tcl_NewStringObj (out, nout));
      Tcl_Free ((char*) out);
      return TCL_OK;
    }


    critcl::ccommand critcl_decode {dummy interp objc objv} {
      /* Syntax -*- c -*-
       * critcl_decode estring
       */

      unsigned char* buf;
      int           nbuf;

      unsigned char* out;
      unsigned char* at;
      unsigned char  x [8];
      int           nout;

      int i, j, a, pad, nx;

      /*
       * An array for translating single base-32 characters into a value.
       * Disallowed input characters have a value of 64.  Upper and lower
       * case is the same. Only 128 chars, as everything above char(127)
       * is 64.
       */
      static const char map [] = {
	/* \00 */ 64, 64, 64, 64, 64, 64, 64, 64,  64, 64, 64, 64, 64, 64, 64, 64, 
	/* DLE */ 64, 64, 64, 64, 64, 64, 64, 64,  64, 64, 64, 64, 64, 64, 64, 64, 
	/* SPC */ 64, 64, 64, 64, 64, 64, 64, 64,  64, 64, 64, 64, 64, 64, 64, 64, 
	/* '0' */ 64, 64, 26, 27, 28, 29, 30, 31,  64, 64, 64, 64, 64, 64, 64, 64, 
	/* '@' */ 64,  0,  1,  2,  3,  4,  5,  6,   7,  8,  9, 10, 11, 12, 13, 14,
	/* 'P' */ 15, 16, 17, 18, 19, 20, 21, 22,  23, 24, 25, 64, 64, 64, 64, 64,
	/* '`' */ 64,  0,  1,  2,  3,  4,  5,  6,   7,  8,  9, 10, 11, 12, 13, 14,
	/* 'p' */ 15, 16, 17, 18, 19, 20, 21, 22,  23, 24, 25, 64, 64, 64, 64, 64
      };

#define USAGED "estring"

      if (objc != 2) {
        Tcl_WrongNumArgs (interp, 1, objv, USAGED);
        return TCL_ERROR;
      }

      buf = Tcl_GetStringFromObj (objv[1], &nbuf);

      if (nbuf % 8) {
	Tcl_SetObjResult (interp, Tcl_NewStringObj ("Length is not a multiple of 8", -1));
        return TCL_ERROR;
      }

      nout = (nbuf/8)*5 *TCL_UTF_MAX;
      out  = (unsigned char*) Tcl_Alloc (nout*sizeof(char));

#define HIGH(x) (((x) & 0x80) != 0)
#define BADC(x) ((x) == 64)
#define BADCHAR(a,j) (HIGH ((a)) || BADC (x [(j)] = map [(a)]))

      for (pad = 0, i=0, at = out; i < nbuf; i += 8, buf += 8){
	for (j=0; j < 8; j++){
	  a = buf [j];

	  if (a == '=') {
	    x[j] = 0;
	    pad++;
	    continue;
	  } else if (pad) {
	    char     msg [120];
	    sprintf (msg,
		     "Invalid character at index %d: \"=\" (padding found in the middle of the input)",
		     j-1);
	    Tcl_Free ((char*) out);
	    Tcl_SetObjResult (interp, Tcl_NewStringObj (msg, -1));
	    return TCL_ERROR;
	  }

	  if (BADCHAR (a,j)) {
	    char     msg [100];
	    sprintf (msg,"Invalid character at index %d: \"%c\"",j,a);
	    Tcl_Free ((char*) out);
	    Tcl_SetObjResult (interp, Tcl_NewStringObj (msg, -1));
	    return TCL_ERROR;
	  }
	}

	*(at++) = (x[0]<<3) | (x[1]>>2)            ;
	*(at++) = (x[1]<<6) | (x[2]<<1) | (x[3]>>4);
	*(at++) = (x[3]<<4) | (x[4]>>1)            ;
	*(at++) = (x[4]<<7) | (x[5]<<2) | (x[6]>>3);
	*(at++) = (x[6]<<5) | x[7]                 ;
      }

      if (pad) {
	if (pad == 1) {
	  at -= 1;
	} else if (pad == 3) {
	  at -= 2;
	} else if (pad == 4) {
	  at -= 3;
	} else if (pad == 6) {
	  at -= 4;
	} else {
	  char     msg [100];
	  sprintf (msg,"Invalid padding of length %d",pad);
	  Tcl_Free ((char*) out);
	  Tcl_SetObjResult (interp, Tcl_NewStringObj (msg, -1));
	  return TCL_ERROR;
	}
      }

      Tcl_SetObjResult (interp, Tcl_NewByteArrayObj (out, at-out));
      Tcl_Free ((char*) out);
      return TCL_OK;
    }
}

# ### ### ### ######### ######### #########
## Ready
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<


























































































































































































































































































































































































































































































































Deleted scriptlibs/tcllib1.12/base32/base32_tcl.tcl.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
# -*- tcl -*-
# This code is hereby put into the public domain.
# ### ### ### ######### ######### #########
## Overview
# Base32 encoding and decoding of small strings.

# ### ### ### ######### ######### #########
## Notes

# A binary string is split into groups of 5 bits (2^5 == 32), and each
# group is converted into a printable character as is specified in RFC
# 3548.

# ### ### ### ######### ######### #########
## Requisites

package require  base32::core
namespace eval ::base32 {}

# ### ### ### ######### ######### #########
## API & Implementation

proc ::base32::tcl_encode {bitstring} {
    variable forward

    binary scan $bitstring B* bits
    set len [string length $bits]
    set rem [expr {$len % 5}]
    if {$rem} {append bits =/$rem}
    #puts "($bitstring) => <$bits>"

    return [string map $forward $bits]
}

proc ::base32::tcl_decode {estring} {
    variable backward
    variable invalid

    if {![core::valid $estring $invalid msg]} {
	return -code error $msg
    }
    #puts "I<$estring>"
    #puts "M<[string map $backward $estring]>"

    return [binary format B* [string map $backward [string toupper $estring]]]
}

# ### ### ### ######### ######### #########
## Data structures

namespace eval ::base32 {
    # Initialize the maps
    variable forward
    variable backward
    variable invalid

    core::define {
	0 A    9 J   18 S   27 3
	1 B   10 K   19 T   28 4
	2 C   11 L   20 U   29 5
	3 D   12 M   21 V   30 6
	4 E   13 N   22 W   31 7
	5 F   14 O   23 X
	6 G   15 P   24 Y
	7 H   16 Q   25 Z
	8 I   17 R   26 2
    } forward backward invalid ; # {}
    # puts ///$forward///
    # puts ///$backward///
}

# ### ### ### ######### ######### #########
## Ok
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<


















































































































































Deleted scriptlibs/tcllib1.12/base32/base32core.tcl.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
# -*- tcl -*-
# This code is hereby put into the public domain.
# ### ### ### ######### ######### #########
#= Overview

# Fundamental handling of base32 conversion tables. Expansion of a
# basic mapping into a full mapping and its inverse mapping.

# ### ### ### ######### ######### #########
#= Requisites

namespace eval ::base32::core {}

# ### ### ### ######### ######### #########
#= API & Implementation

proc ::base32::core::define {map fv bv iv} {
    variable bits
    upvar 1 $fv forward $bv backward $iv invalid

    # bytes - bits - padding  - tail       | bits - padding  - tail
    # 0     -  0   - ""       - "xxxxxxxx" | 0    - ""       - ""
    # 1     -  8   - "======" - "xx======" | 3    - "======" - "x======"
    # 2     - 16   - "===="   - "xxxx====" | 1    - "===="   - "x===="
    # 3     - 24   - "==="    - "xxxxx===" | 4    - "==="    - "x==="
    # 4     - 32   - "="      - "xxxxxxx=" | 2    - "="      - "x="

    array set _ $bits

    set invalid  "\[^="
    set forward  {}
    set btmp     {}

    foreach {code char} $map {
	set b $_($code)

	append invalid [string tolower $char][string toupper $char]

	# 5 bit remainder
	lappend forward    $b $char
	lappend btmp [list $char $b]

	# 4 bit remainder
	if {$code%2} continue
	set b [string range $b 0 end-1]
	lappend forward    ${b}=/4    ${char}===
	lappend btmp [list ${char}=== $b]

	# 3 bit remainder
	if {$code%4} continue
	set b [string range $b 0 end-1]
	lappend forward    ${b}=/3       ${char}======
	lappend btmp [list ${char}====== $b]

	# 2 bit remainder
	if {$code%8} continue
	set b [string range $b 0 end-1]
	lappend forward    ${b}=/2  ${char}=
	lappend btmp [list ${char}= $b]

	# 1 bit remainder
	if {$code%16} continue
	set b [string range $b 0 end-1]
	lappend forward    ${b}=/1     ${char}====
	lappend btmp [list ${char}==== $b]
    }

    set backward {}
    foreach item [lsort -index 0 -decreasing $btmp] {
	foreach {c b} $item break
	lappend backward $c $b
    }

    append invalid "\]"
    return
}

proc ::base32::core::valid {estring pattern mv} {
    upvar 1 $mv message

    if {[string length $estring] % 8} {
	set message "Length is not a multiple of 8"
	return 0
    } elseif {[regexp -indices $pattern $estring where]} {
	foreach {s e} $where break
	set message "Invalid character at index $s: \"[string index $estring $s]\""
	return 0
    } elseif {[regexp {(=+)$} $estring -> pad]} {
	set padlen [string length $pad]
	if {
	    ($padlen != 6) &&
	    ($padlen != 4) &&
	    ($padlen != 3) &&
	    ($padlen != 1)
	} {
	    set message "Invalid padding of length $padlen"
	    return 0
	}
    }

    # Remove the brackets and ^= from the pattern, to construct the
    # class of valid characters which must not follow the padding.

    set badp "=\[[string range $pattern 3 end-1]\]"
    if {[regexp -indices $badp $estring where]} {
	foreach {s e} $where break
	set message "Invalid character at index $s: \"[string index $estring $s]\" (padding found in the middle of the input)"
	return 0
    }
    return 1
}

# ### ### ### ######### ######### #########
## Data structures

namespace eval ::base32::core {
    namespace export define valid

    variable bits {
	 0 00000	 1 00001	 2 00010	 3 00011
	 4 00100	 5 00101	 6 00110	 7 00111
	 8 01000	 9 01001	10 01010	11 01011
	12 01100	13 01101	14 01110	15 01111
	16 10000	17 10001	18 10010	19 10011
	20 10100	21 10101	22 10110	23 10111
	24 11000	25 11001	26 11010	27 11011
	28 11100	29 11101	30 11110	31 11111
    }
}

# ### ### ### ######### ######### #########
#= Registration

package provide base32::core 0.1
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<












































































































































































































































































Deleted scriptlibs/tcllib1.12/base32/base32hex.tcl.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
# -*- tcl -*-
# This code is hereby put into the public domain.
# ### ### ### ######### ######### #########
## Overview
# Base32 encoding and decoding of small strings.
#
# Management code for switching between Tcl and C accelerated
# implementations.
#
# RCS: @(#) $Id: base32hex.tcl,v 1.3 2008/03/22 23:46:42 andreas_kupries Exp $

# @mdgen EXCLUDE: base32hex_c.tcl

package require Tcl 8.4

namespace eval ::base32::hex {}

# ### ### ### ######### ######### #########
## Management of base32 std implementations.

# ::base32::hex::LoadAccelerator --
#
#	Loads a named implementation, if possible.
#
# Arguments:
#	key	Name of the implementation to load.
#
# Results:
#	A boolean flag. True if the implementation
#	was successfully loaded; and False otherwise.

proc ::base32::hex::LoadAccelerator {key} {
    variable accel
    set isok 0
    switch -exact -- $key {
	critcl {
	    # Critcl implementation of base32 requires Tcl 8.4.
	    if {![package vsatisfies [package provide Tcl] 8.4]} {return 0}
	    if {[catch {package require tcllibc}]} {return 0}
	    set isok [llength [info commands ::base32::hex::critcl_encode]]
	}
	tcl {
	    variable selfdir
	    if {[catch {source [file join $selfdir base32hex_tcl.tcl]}]} {return 0}
	    set isok [llength [info commands ::base32::hex::tcl_encode]]
	}
        default {
            return -code error "invalid accelerator $key:\
                must be one of [join [KnownImplementations] {, }]"
        }
    }
    set accel($key) $isok
    return $isok
}

# ::base32::hex::SwitchTo --
#
#	Activates a loaded named implementation.
#
# Arguments:
#	key	Name of the implementation to activate.
#
# Results:
#	None.

proc ::base32::hex::SwitchTo {key} {
    variable accel
    variable loaded

    if {[string equal $key $loaded]} {
	# No change, nothing to do.
	return
    } elseif {![string equal $key ""]} {
	# Validate the target implementation of the switch.

	if {![info exists accel($key)]} {
	    return -code error "Unable to activate unknown implementation \"$key\""
	} elseif {![info exists accel($key)] || !$accel($key)} {
	    return -code error "Unable to activate missing implementation \"$key\""
	}
    }

    # Deactivate the previous implementation, if there was any.

    if {![string equal $loaded ""]} {
	foreach c {encode decode} {
	    rename ::base32::hex::$c ::base32::hex::${loaded}_$c
	}
    }

    # Activate the new implementation, if there is any.

    if {![string equal $key ""]} {
	foreach c {encode decode} {
	    rename ::base32::hex::${key}_$c ::base32::hex::$c
	}
    }

    # Remember the active implementation, for deactivation by future
    # switches.

    set loaded $key
    return
}

# ::base32::hex::Implementations --
#
#	Determines which implementations are
#	present, i.e. loaded.
#
# Arguments:
#	None.
#
# Results:
#	A list of implementation keys.

proc ::base32::hex::Implementations {} {
    variable accel
    set res {}
    foreach n [array names accel] {
	if {!$accel($n)} continue
	lappend res $n
    }
    return $res
}

# ::base32::hex::KnownImplementations --
#
#	Determines which implementations are known
#	as possible implementations.
#
# Arguments:
#	None.
#
# Results:
#	A list of implementation keys. In the order
#	of preference, most prefered first.

proc ::base32::hex::KnownImplementations {} {
    return {critcl tcl}
}

proc ::base32::hex::Names {} {
    return {
	critcl {tcllibc based}
	tcl    {pure Tcl}
    }
}

# ### ### ### ######### ######### #########
## Initialization: Data structures.

namespace eval ::base32::hex {
    variable  selfdir [file dirname [info script]]
    variable  loaded  {}

    variable  accel
    array set accel   {tcl 0 critcl 0}
}

# ### ### ### ######### ######### #########
## Initialization: Choose an implementation,
## most prefered first. Loads only one of the
## possible implementations. And activates it.

namespace eval ::base32::hex {
    variable e
    foreach e [KnownImplementations] {
	if {[LoadAccelerator $e]} {
	    SwitchTo $e
	    break
	}
    }
    unset e

    namespace export encode decode
}

# ### ### ### ######### ######### #########
## Ready

package provide base32::hex 0.1
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<












































































































































































































































































































































































Deleted scriptlibs/tcllib1.12/base32/base32hex_c.tcl.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
# base32hexc.tcl --
#
#       Implementation of a base32 (extended hex) de/encoder for Tcl.
#
# Public domain
#
# RCS: @(#) $Id: base32hex_c.tcl,v 1.3 2008/01/28 22:58:18 andreas_kupries Exp $

package require critcl
package require Tcl 8.4

namespace eval ::base32::hex {
    # Supporting code for the main command.
    catch {
	#critcl::cheaders -g
	#critcl::debug memory symbols
    }

    # Main commands, encoder & decoder

    critcl::ccommand critcl_encode {dummy interp objc objv} {
      /* Syntax -*- c -*-
       * critcl_encode string
       */

      unsigned char* buf;
      int           nbuf;

      unsigned char* out;
      unsigned char* at;
      int           nout;

      /*
       * The array used for encoding
       */                     /* 123456789 123456789 123456789 12 */
      static const char map[] = "0123456789ABCDEFGHIJKLMNOPQRSTUV";

#define USAGEE "bitstring"

      if (objc != 2) {
        Tcl_WrongNumArgs (interp, 1, objv, USAGEE);
        return TCL_ERROR;
      }

      buf  = Tcl_GetByteArrayFromObj (objv[1], &nbuf);
      nout = ((nbuf+4)/5)*8;
      out  = (unsigned char*) Tcl_Alloc (nout*sizeof(char));

      for (at = out; nbuf >= 5; nbuf -= 5, buf += 5) {
	*(at++) = map [         (buf[0]>>3)                ];
	*(at++) = map [ 0x1f & ((buf[0]<<2) | (buf[1]>>6)) ];
	*(at++) = map [ 0x1f &  (buf[1]>>1)                ];
	*(at++) = map [ 0x1f & ((buf[1]<<4) | (buf[2]>>4)) ];
	*(at++) = map [ 0x1f & ((buf[2]<<1) | (buf[3]>>7)) ];
	*(at++) = map [ 0x1f &  (buf[3]>>2)                ];
	*(at++) = map [ 0x1f & ((buf[3]<<3) | (buf[4]>>5)) ];
	*(at++) = map [ 0x1f &  (buf[4])                   ];
      }
      if (nbuf > 0) {
	/* Process partials at end. */
	switch (nbuf) {
	case 1:
	  /* |01234567|		 2, padding 6
	   *  xxxxx
	   *       xxx 00
	   */

	  *(at++) = map [        (buf[0]>>3) ];
	  *(at++) = map [ 0x1f & (buf[0]<<2) ];
	  *(at++) = '=';
	  *(at++) = '=';
	  *(at++) = '=';
	  *(at++) = '=';
	  *(at++) = '=';
	  *(at++) = '=';
	  break;
	case 2: /* x3/=4 */
	  /* |01234567|01234567|	 4, padding 4
	   *  xxxxx
	   *       xxx xx
	   *             xxxxx
	   *                  x 0000
	   */

	  *(at++) = map [         (buf[0]>>3)                ];
	  *(at++) = map [ 0x1f & ((buf[0]<<2) | (buf[1]>>6)) ];
	  *(at++) = map [ 0x1f &  (buf[1]>>1)                ];
	  *(at++) = map [ 0x1f &  (buf[1]<<4)                ];
	  *(at++) = '=';
	  *(at++) = '=';
	  *(at++) = '=';
	  *(at++) = '=';
	  break;
	case 3:
	  /* |01234567|01234567|01234567|	 5, padding 3
	   *  xxxxx
	   *       xxx xx
	   *             xxxxx
	   *                  x xxxx
	   *                        xxxx 0
	   */

	  *(at++) = map [         (buf[0]>>3)                ];
	  *(at++) = map [ 0x1f & ((buf[0]<<2) | (buf[1]>>6)) ];
	  *(at++) = map [ 0x1f &  (buf[1]>>1)                ];
	  *(at++) = map [ 0x1f & ((buf[1]<<4) | (buf[2]>>4)) ];
	  *(at++) = map [ 0x1f &  (buf[2]<<1)                ];
	  *(at++) = '=';
	  *(at++) = '=';
	  *(at++) = '=';
	  break;
	case 4:
	  /* |01234567|01234567|01234567|012334567|	 7, padding 1
	   *  xxxxx
	   *       xxx xx
	   *             xxxxx
	   *                  x xxxx
	   *                        xxxx
	   *                             xxxxx
	   *                                  xxxx 0
	   */

	  *(at++) = map [         (buf[0]>>3)                ];
	  *(at++) = map [ 0x1f & ((buf[0]<<2) | (buf[1]>>6)) ];
	  *(at++) = map [ 0x1f &  (buf[1]>>1)                ];
	  *(at++) = map [ 0x1f & ((buf[1]<<4) | (buf[2]>>4)) ];
	  *(at++) = map [ 0x1f & ((buf[2]<<1) | (buf[3]>>7)) ];
	  *(at++) = map [ 0x1f &  (buf[3]>>2)                ];
	  *(at++) = map [ 0x1f &  (buf[3]<<3)                ];
	  *(at++) = '=';
	  break;
	}
      }

      Tcl_SetObjResult (interp, Tcl_NewStringObj (out, nout));
      Tcl_Free ((char*) out);
      return TCL_OK;
    }


    critcl::ccommand critcl_decode {dummy interp objc objv} {
      /* Syntax -*- c -*-
       * critcl_decode estring
       */

      unsigned char* buf;
      int           nbuf;

      unsigned char* out;
      unsigned char* at;
      unsigned char  x [8];
      int           nout;

      int i, j, a, pad, nx;

      /*
       * An array for translating single base-32 characters into a value.
       * Disallowed input characters have a value of 64.  Upper and lower
       * case is the same. Only 128 chars, as everything above char(127)
       * is 64.
       */
      static const char map [] = {
	/* \00 */ 64, 64, 64, 64, 64, 64, 64, 64,  64, 64, 64, 64, 64, 64, 64, 64, 
	/* DLE */ 64, 64, 64, 64, 64, 64, 64, 64,  64, 64, 64, 64, 64, 64, 64, 64, 
	/* SPC */ 64, 64, 64, 64, 64, 64, 64, 64,  64, 64, 64, 64, 64, 64, 64, 64, 
	/* '0' */  0,  1,  2,  3,  4,  5,  6,  7,   8,  9, 64, 64, 64, 64, 64, 64, 
	/* '@' */ 64, 10, 11, 12, 13, 14, 15, 16,  17, 18, 19, 20, 21, 22, 23, 24,
	/* 'P' */ 25, 26, 27, 28, 29, 30, 31, 64,  64, 64, 64, 64, 64, 64, 64, 64,
	/* '`' */ 64, 10, 11, 12, 13, 14, 15, 16,  17, 18, 19, 20, 21, 22, 23, 24,
	/* 'p' */ 25, 26, 27, 28, 29, 30, 31, 64,  64, 64, 64, 64, 64, 64, 64, 64
      };

#define USAGED "estring"

      if (objc != 2) {
        Tcl_WrongNumArgs (interp, 1, objv, USAGED);
        return TCL_ERROR;
      }

      buf = Tcl_GetStringFromObj (objv[1], &nbuf);

      if (nbuf % 8) {
	Tcl_SetObjResult (interp, Tcl_NewStringObj ("Length is not a multiple of 8", -1));
        return TCL_ERROR;
      }

      nout = (nbuf/8)*5 *TCL_UTF_MAX;
      out  = (unsigned char*) Tcl_Alloc (nout*sizeof(char));

#define HIGH(x) (((x) & 0x80) != 0)
#define BADC(x) ((x) == 64)
#define BADCHAR(a,j) (HIGH ((a)) || BADC (x [(j)] = map [(a)]))

      for (pad = 0, i=0, at = out; i < nbuf; i += 8, buf += 8){
	for (j=0; j < 8; j++){
	  a = buf [j];

	  if (a == '=') {
	    x[j] = 0;
	    pad++;
	    continue;
	  } else if (pad) {
	    char     msg [120];
	    sprintf (msg,
		     "Invalid character at index %d: \"=\" (padding found in the middle of the input)",
		     j-1);
	    Tcl_Free ((char*) out);
	    Tcl_SetObjResult (interp, Tcl_NewStringObj (msg, -1));
	    return TCL_ERROR;
	  }

	  if (BADCHAR (a,j)) {
	    char     msg [100];
	    sprintf (msg,"Invalid character at index %d: \"%c\"",j,a);
	    Tcl_Free ((char*) out);
	    Tcl_SetObjResult (interp, Tcl_NewStringObj (msg, -1));
	    return TCL_ERROR;
	  }
	}

	*(at++) = (x[0]<<3) | (x[1]>>2)            ;
	*(at++) = (x[1]<<6) | (x[2]<<1) | (x[3]>>4);
	*(at++) = (x[3]<<4) | (x[4]>>1)            ;
	*(at++) = (x[4]<<7) | (x[5]<<2) | (x[6]>>3);
	*(at++) = (x[6]<<5) | x[7]                 ;
      }

      if (pad) {
	if (pad == 1) {
	  at -= 1;
	} else if (pad == 3) {
	  at -= 2;
	} else if (pad == 4) {
	  at -= 3;
	} else if (pad == 6) {
	  at -= 4;
	} else {
	  char     msg [100];
	  sprintf (msg,"Invalid padding of length %d",pad);
	  Tcl_Free ((char*) out);
	  Tcl_SetObjResult (interp, Tcl_NewStringObj (msg, -1));
	  return TCL_ERROR;
	}
      }

      Tcl_SetObjResult (interp, Tcl_NewByteArrayObj (out, at-out));
      Tcl_Free ((char*) out);
      return TCL_OK;
    }
}

# ### ### ### ######### ######### #########
## Ready
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<


























































































































































































































































































































































































































































































































Deleted scriptlibs/tcllib1.12/base32/base32hex_tcl.tcl.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
# -*- tcl -*-
# This code is hereby put into the public domain.
# ### ### ### ######### ######### #########
## Overview
# Base32 encoding and decoding of small strings.

# ### ### ### ######### ######### #########
## Notes

# A binary string is split into groups of 5 bits (2^5 == 32), and each
# group is converted into a printable character as is specified in RFC
# 3548 for the extended hex encoding.

# ### ### ### ######### ######### #########
## Requisites

package require  base32::core
namespace eval ::base32::hex {}

# ### ### ### ######### ######### #########
## API & Implementation

proc ::base32::hex::tcl_encode {bitstring} {
    variable forward

    binary scan $bitstring B* bits
    set len [string length $bits]
    set rem [expr {$len % 5}]
    if {$rem} {append bits =/$rem}
    #puts "($bitstring) => <$bits>"

    return [string map $forward $bits]
}

proc ::base32::hex::tcl_decode {estring} {
    variable backward
    variable invalid

    if {![core::valid $estring $invalid msg]} {
	return -code error $msg
    }
    #puts "I<$estring>"
    #puts "M<[string map $backward $estring]>"

    return [binary format B* [string map $backward [string toupper $estring]]]
}

# ### ### ### ######### ######### #########
## Data structures

namespace eval ::base32::hex {
    namespace eval core {
	namespace import ::base32::core::define
	namespace import ::base32::core::valid
    }

    namespace export encode decode
    # Initialize the maps
    variable forward
    variable backward
    variable invalid

    core::define {
	0 0    9 9        18 I   27 R
	1 1   10 A        19 J   28 S
	2 2   11 B        20 K   29 T
	3 3   12 C        21 L   30 U
	4 4   13 D        22 M   31 V
	5 5   14 E        23 N
	6 6   15 F        24 O
	7 7        16 G   25 P
	8 8        17 H   26 Q
    } forward backward invalid ; # {}
    # puts ///$forward///
    # puts ///$backward///
}

# ### ### ### ######### ######### #########
## Ok
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<






























































































































































Deleted scriptlibs/tcllib1.12/base32/pkgIndex.tcl.

1
2
3
4
if {![package vsatisfies [package provide Tcl] 8.4]} return
package ifneeded base32       0.1 [list source [file join $dir base32.tcl]]
package ifneeded base32::hex  0.1 [list source [file join $dir base32hex.tcl]]
package ifneeded base32::core 0.1 [list source [file join $dir base32core.tcl]]
<
<
<
<








Deleted scriptlibs/tcllib1.12/base64/base64.tcl.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
# base64.tcl --
#
# Encode/Decode base64 for a string
# Stephen Uhler / Brent Welch (c) 1997 Sun Microsystems
# The decoder was done for exmh by Chris Garrigues
#
# Copyright (c) 1998-2000 by Ajuba Solutions.
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# 
# RCS: @(#) $Id: base64.tcl,v 1.31 2009/01/29 04:30:47 andreas_kupries Exp $

# Version 1.0   implemented Base64_Encode, Base64_Decode
# Version 2.0   uses the base64 namespace
# Version 2.1   fixes various decode bugs and adds options to encode
# Version 2.2   is much faster, Tcl8.0 compatible
# Version 2.2.1 bugfixes
# Version 2.2.2 bugfixes
# Version 2.3   bugfixes and extended to support Trf

# @mdgen EXCLUDE: base64c.tcl

package require Tcl 8.2
namespace eval ::base64 {
    namespace export encode decode
}

if {![catch {package require Trf 2.0}]} {
    # Trf is available, so implement the functionality provided here
    # in terms of calls to Trf for speed.

    # ::base64::encode --
    #
    #	Base64 encode a given string.
    #
    # Arguments:
    #	args	?-maxlen maxlen? ?-wrapchar wrapchar? string
    #	
    #		If maxlen is 0, the output is not wrapped.
    #
    # Results:
    #	A Base64 encoded version of $string, wrapped at $maxlen characters
    #	by $wrapchar.
    
    proc ::base64::encode {args} {
	# Set the default wrapchar and maximum line length to match
	# the settings for MIME encoding (RFC 3548, RFC 2045). These
	# are the settings used by Trf as well. Various RFCs allow for
	# different wrapping characters and wraplengths, so these may
	# be overridden by command line options.
	set wrapchar "\n"
	set maxlen 76

	if { [llength $args] == 0 } {
	    error "wrong # args: should be \"[lindex [info level 0] 0]\
		    ?-maxlen maxlen? ?-wrapchar wrapchar? string\""
	}

	set optionStrings [list "-maxlen" "-wrapchar"]
	for {set i 0} {$i < [llength $args] - 1} {incr i} {
	    set arg [lindex $args $i]
	    set index [lsearch -glob $optionStrings "${arg}*"]
	    if { $index == -1 } {
		error "unknown option \"$arg\": must be -maxlen or -wrapchar"
	    }
	    incr i
	    if { $i >= [llength $args] - 1 } {
		error "value for \"$arg\" missing"
	    }
	    set val [lindex $args $i]

	    # The name of the variable to assign the value to is extracted
	    # from the list of known options, all of which have an
	    # associated variable of the same name as the option without
	    # a leading "-". The [string range] command is used to strip
	    # of the leading "-" from the name of the option.
	    #
	    # FRINK: nocheck
	    set [string range [lindex $optionStrings $index] 1 end] $val
	}
    
	# [string is] requires Tcl8.2; this works with 8.0 too
	if {[catch {expr {$maxlen % 2}}]} {
	    return -code error "expected integer but got \"$maxlen\""
	} elseif {$maxlen < 0} {
	    return -code error "expected positive integer but got \"$maxlen\""
	}

	set string [lindex $args end]
	set result [::base64 -mode encode -- $string]

	# Trf's encoder implicitly uses the settings -maxlen 76,
	# -wrapchar \n for its output. We may have to reflow this for
	# the settings chosen by the user. A second difference is that
	# Trf closes the output with the wrap char sequence,
	# always. The code here doesn't. Therefore 'trimright' is
	# needed in the fast cases.

	if {($maxlen == 76) && [string equal $wrapchar \n]} {
	    # Both maxlen and wrapchar are identical to Trf's
	    # settings. This is the super-fast case, because nearly
	    # nothing has to be done. Only thing to do is strip a
	    # terminating wrapchar.
	    set result [string trimright $result]
	} elseif {$maxlen == 76} {
	    # wrapchar has to be different here, length is the
	    # same. We can use 'string map' to transform the wrap
	    # information.
	    set result [string map [list \n $wrapchar] \
			    [string trimright $result]]
	} elseif {$maxlen == 0} {
	    # Have to reflow the output to no wrapping. Another fast
	    # case using only 'string map'. 'trimright' is not needed
	    # here.

	    set result [string map [list \n ""] $result]
	} else {
	    # Have to reflow the output from 76 to the chosen maxlen,
	    # and possibly change the wrap sequence as well.

	    # Note: After getting rid of the old wrap sequence we
	    # extract the relevant segments from the string without
	    # modifying the string. Modification, i.e. removal of the
	    # processed part, means 'shifting down characters in
	    # memory', making the algorithm O(n^2). By avoiding the
	    # modification we stay in O(n).
	    
	    set result [string map [list \n ""] $result]
	    set l [expr {[string length $result]-$maxlen}]
	    for {set off 0} {$off < $l} {incr off $maxlen} {
		append res [string range $result $off [expr {$off+$maxlen-1}]] $wrapchar
	    }
	    append res [string range $result $off end]
	    set result $res
	}

	return $result
    }

    # ::base64::decode --
    #
    #	Base64 decode a given string.
    #
    # Arguments:
    #	string	The string to decode.  Characters not in the base64
    #		alphabet are ignored (e.g., newlines)
    #
    # Results:
    #	The decoded value.

    proc ::base64::decode {string} {
	regsub -all {\s} $string {} string
	::base64 -mode decode -- $string
    }

} else {
    # Without Trf use a pure tcl implementation

    namespace eval base64 {
	variable base64 {}
	variable base64_en {}

	# We create the auxiliary array base64_tmp, it will be unset later.
	variable base64_tmp
	variable i

	set i 0
	foreach char {A B C D E F G H I J K L M N O P Q R S T U V W X Y Z \
		a b c d e f g h i j k l m n o p q r s t u v w x y z \
		0 1 2 3 4 5 6 7 8 9 + /} {
	    set base64_tmp($char) $i
	    lappend base64_en $char
	    incr i
	}

	#
	# Create base64 as list: to code for instance C<->3, specify
	# that [lindex $base64 67] be 3 (C is 67 in ascii); non-coded
	# ascii chars get a {}. we later use the fact that lindex on a
	# non-existing index returns {}, and that [expr {} < 0] is true
	#

	# the last ascii char is 'z'
	variable char
	variable len
	variable val

	scan z %c len
	for {set i 0} {$i <= $len} {incr i} {
	    set char [format %c $i]
	    set val {}
	    if {[info exists base64_tmp($char)]} {
		set val $base64_tmp($char)
	    } else {
		set val {}
	    }
	    lappend base64 $val
	}

	# code the character "=" as -1; used to signal end of message
	scan = %c i
	set base64 [lreplace $base64 $i $i -1]

	# remove unneeded variables
	unset base64_tmp i char len val

	namespace export encode decode
    }

    # ::base64::encode --
    #
    #	Base64 encode a given string.
    #
    # Arguments:
    #	args	?-maxlen maxlen? ?-wrapchar wrapchar? string
    #	
    #		If maxlen is 0, the output is not wrapped.
    #
    # Results:
    #	A Base64 encoded version of $string, wrapped at $maxlen characters
    #	by $wrapchar.
    
    proc ::base64::encode {args} {
	set base64_en $::base64::base64_en
	
	# Set the default wrapchar and maximum line length to match
	# the settings for MIME encoding (RFC 3548, RFC 2045). These
	# are the settings used by Trf as well. Various RFCs allow for
	# different wrapping characters and wraplengths, so these may
	# be overridden by command line options.
	set wrapchar "\n"
	set maxlen 76

	if { [llength $args] == 0 } {
	    error "wrong # args: should be \"[lindex [info level 0] 0]\
		    ?-maxlen maxlen? ?-wrapchar wrapchar? string\""
	}

	set optionStrings [list "-maxlen" "-wrapchar"]
	for {set i 0} {$i < [llength $args] - 1} {incr i} {
	    set arg [lindex $args $i]
	    set index [lsearch -glob $optionStrings "${arg}*"]
	    if { $index == -1 } {
		error "unknown option \"$arg\": must be -maxlen or -wrapchar"
	    }
	    incr i
	    if { $i >= [llength $args] - 1 } {
		error "value for \"$arg\" missing"
	    }
	    set val [lindex $args $i]

	    # The name of the variable to assign the value to is extracted
	    # from the list of known options, all of which have an
	    # associated variable of the same name as the option without
	    # a leading "-". The [string range] command is used to strip
	    # of the leading "-" from the name of the option.
	    #
	    # FRINK: nocheck
	    set [string range [lindex $optionStrings $index] 1 end] $val
	}
    
	# [string is] requires Tcl8.2; this works with 8.0 too
	if {[catch {expr {$maxlen % 2}}]} {
	    return -code error "expected integer but got \"$maxlen\""
	} elseif {$maxlen < 0} {
	    return -code error "expected positive integer but got \"$maxlen\""
	}

	set string [lindex $args end]

	set result {}
	set state 0
	set length 0


	# Process the input bytes 3-by-3

	binary scan $string c* X

	foreach {x y z} $X {
	    ADD [lindex $base64_en [expr {($x >>2) & 0x3F}]]
	    if {$y != {}} {
		ADD [lindex $base64_en [expr {(($x << 4) & 0x30) | (($y >> 4) & 0xF)}]]
		if {$z != {}} {
		    ADD [lindex $base64_en [expr {(($y << 2) & 0x3C) | (($z >> 6) & 0x3)}]]
		    ADD [lindex $base64_en [expr {($z & 0x3F)}]]
		} else {
		    set state 2
		    break
		}
	    } else {
		set state 1
		break
	    }
	}
	if {$state == 1} {
	    ADD [lindex $base64_en [expr {(($x << 4) & 0x30)}]]
	    ADD =
	    ADD =
	} elseif {$state == 2} {
	    ADD [lindex $base64_en [expr {(($y << 2) & 0x3C)}]]
	    ADD =
	}
	return $result
    }

    proc ::base64::ADD {x} {
	# The line length check is always done before appending so
	# that we don't get an extra newline if the output is a
	# multiple of $maxlen chars long.

	upvar 1 maxlen maxlen length length result result wrapchar wrapchar
	if {$maxlen && $length >= $maxlen} {
	    append result $wrapchar
	    set length 0
	}
	append result $x
	incr length
	return
    }

    # ::base64::decode --
    #
    #	Base64 decode a given string.
    #
    # Arguments:
    #	string	The string to decode.  Characters not in the base64
    #		alphabet are ignored (e.g., newlines)
    #
    # Results:
    #	The decoded value.

    proc ::base64::decode {string} {
	if {[string length $string] == 0} {return ""}

	set base64 $::base64::base64
	set output "" ; # Fix for [Bug 821126]

	binary scan $string c* X
	foreach x $X {
	    set bits [lindex $base64 $x]
	    if {$bits >= 0} {
		if {[llength [lappend nums $bits]] == 4} {
		    foreach {v w z y} $nums break
		    set a [expr {($v << 2) | ($w >> 4)}]
		    set b [expr {(($w & 0xF) << 4) | ($z >> 2)}]
		    set c [expr {(($z & 0x3) << 6) | $y}]
		    append output [binary format ccc $a $b $c]
		    set nums {}
		}		
	    } elseif {$bits == -1} {
		# = indicates end of data.  Output whatever chars are left.
		# The encoding algorithm dictates that we can only have 1 or 2
		# padding characters.  If x=={}, we have 12 bits of input 
		# (enough for 1 8-bit output).  If x!={}, we have 18 bits of
		# input (enough for 2 8-bit outputs).
		
		foreach {v w z} $nums break
		set a [expr {($v << 2) | (($w & 0x30) >> 4)}]
		if {$z == {}} {
		    append output [binary format c $a ]
		} else {
		    set b [expr {(($w & 0xF) << 4) | (($z & 0x3C) >> 2)}]
		    append output [binary format cc $a $b]
		}		
		break
	    } else {
		# RFC 2045 says that line breaks and other characters not part
		# of the Base64 alphabet must be ignored, and that the decoder
		# can optionally emit a warning or reject the message.  We opt
		# not to do so, but to just ignore the character. 
		continue
	    }
	}
	return $output
    }
}

package provide base64 2.4.1
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<






















































































































































































































































































































































































































































































































































































































































































































































































Deleted scriptlibs/tcllib1.12/base64/base64c.tcl.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
# base64c - Copyright (C) 2003 Pat Thoyts <patthoyts@users.sourceforge.net>
#
# This package is a place-holder for the critcl enhanced code present in
# the tcllib base64 module.
#
# Normally this code will become part of the tcllibc library.
#

# @sak notprovided base64c
package require critcl
package provide base64c 0.1.0

namespace eval ::base64c {
    variable base64c_rcsid {$Id: base64c.tcl,v 1.5 2008/03/25 07:15:35 andreas_kupries Exp $}

    critcl::ccode {
        /* no code required in this file */
    }
}
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<






































Deleted scriptlibs/tcllib1.12/base64/pkgIndex.tcl.

1
2
3
4
if {![package vsatisfies [package provide Tcl] 8.2]} {return}
package ifneeded base64   2.4.1 [list source [file join $dir base64.tcl]]
package ifneeded uuencode 1.1.5 [list source [file join $dir uuencode.tcl]]
package ifneeded yencode  1.1.3 [list source [file join $dir yencode.tcl]]
<
<
<
<








Deleted scriptlibs/tcllib1.12/base64/uuencode.tcl.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
# uuencode - Copyright (C) 2002 Pat Thoyts <patthoyts@users.sourceforge.net>
#
# Provide a Tcl only implementation of uuencode and uudecode.
#
# -------------------------------------------------------------------------
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# -------------------------------------------------------------------------
# @(#)$Id: uuencode.tcl,v 1.22 2009/05/07 01:10:37 patthoyts Exp $

package require Tcl 8.2;                # tcl minimum version

# Try and get some compiled helper package.
if {[catch {package require tcllibc}]} {
    catch {package require Trf}
}

namespace eval ::uuencode {
    variable version 1.1.5

    namespace export encode decode uuencode uudecode
}

proc ::uuencode::Enc {c} {
    return [format %c [expr {($c != 0) ? (($c & 0x3f) + 0x20) : 0x60}]]
}

proc ::uuencode::Encode {s} {
    set r {}
    binary scan $s c* d
    foreach {c1 c2 c3} $d {
        if {$c1 == {}} {set c1 0}
        if {$c2 == {}} {set c2 0}
        if {$c3 == {}} {set c3 0}
        append r [Enc [expr {$c1 >> 2}]]
        append r [Enc [expr {(($c1 << 4) & 060) | (($c2 >> 4) & 017)}]]
        append r [Enc [expr {(($c2 << 2) & 074) | (($c3 >> 6) & 003)}]]
        append r [Enc [expr {($c3 & 077)}]]
    }
    return $r
}


proc ::uuencode::Decode {s} {
    if {[string length $s] == 0} {return ""}
    set r {}
    binary scan [pad $s] c* d
        
    foreach {c0 c1 c2 c3} $d {
        append r [format %c [expr {((($c0-0x20)&0x3F) << 2) & 0xFF
                                   | ((($c1-0x20)&0x3F) >> 4) & 0xFF}]]
        append r [format %c [expr {((($c1-0x20)&0x3F) << 4) & 0xFF
                                   | ((($c2-0x20)&0x3F) >> 2) & 0xFF}]]
        append r [format %c [expr {((($c2-0x20)&0x3F) << 6) & 0xFF
                                   | (($c3-0x20)&0x3F) & 0xFF}]]
    }
    return $r
}

# -------------------------------------------------------------------------
# C coded version of the Encode/Decode functions for base64c package.
# -------------------------------------------------------------------------
if {[package provide critcl] != {}} {
    namespace eval ::uuencode {
        critcl::ccode {
            #include <string.h>
            static unsigned char Enc(unsigned char c) {
                return (c != 0) ? ((c & 0x3f) + 0x20) : 0x60;
            }
        }
        critcl::ccommand CEncode {dummy interp objc objv} {
            Tcl_Obj *inputPtr, *resultPtr;
            int len, rlen, xtra;
            unsigned char *input, *p, *r;
            
            if (objc !=  2) {
                Tcl_WrongNumArgs(interp, 1, objv, "data");
                return TCL_ERROR;
            }
            
            inputPtr = objv[1];
            input = Tcl_GetByteArrayFromObj(inputPtr, &len);
            if ((xtra = (3 - (len % 3))) != 3) {
                if (Tcl_IsShared(inputPtr))
                    inputPtr = Tcl_DuplicateObj(inputPtr);
                input = Tcl_SetByteArrayLength(inputPtr, len + xtra);
                memset(input + len, 0, xtra);
                len += xtra;
            }

            rlen = (len / 3) * 4;
            resultPtr = Tcl_NewObj();
            r = Tcl_SetByteArrayLength(resultPtr, rlen);
            memset(r, 0, rlen);
            
            for (p = input; p < input + len; p += 3) {
                char a, b, c;
                a = *p; b = *(p+1), c = *(p+2);
                *r++ = Enc(a >> 2);
                *r++ = Enc(((a << 4) & 060) | ((b >> 4) & 017));
                *r++ = Enc(((b << 2) & 074) | ((c >> 6) & 003));
                *r++ = Enc(c & 077);
            }
            Tcl_SetObjResult(interp, resultPtr);
            return TCL_OK;
        }

        critcl::ccommand CDecode {dummy interp objc objv} {
            Tcl_Obj *inputPtr, *resultPtr;
            int len, rlen, xtra;
            unsigned char *input, *p, *r;
            
            if (objc !=  2) {
                Tcl_WrongNumArgs(interp, 1, objv, "data");
                return TCL_ERROR;
            }
            
            /* if input is not mod 4, extend it with nuls */
            inputPtr = objv[1];
            input = Tcl_GetByteArrayFromObj(inputPtr, &len);
            if ((xtra = (4 - (len % 4))) != 4) {
                if (Tcl_IsShared(inputPtr))
                    inputPtr = Tcl_DuplicateObj(inputPtr);
                input = Tcl_SetByteArrayLength(inputPtr, len + xtra);
                memset(input + len, 0, xtra);
                len += xtra;
            }

            /* output will be 1/3 smaller than input and a multiple of 3 */
            rlen = (len / 4) * 3;
            resultPtr = Tcl_NewObj();
            r = Tcl_SetByteArrayLength(resultPtr, rlen);
            memset(r, 0, rlen);
            
            for (p = input; p < input + len; p += 4) {
                char a, b, c, d;
                a = *p; b = *(p+1), c = *(p+2), d = *(p+3);
                *r++ = (((a - 0x20) & 0x3f) << 2) | (((b - 0x20) & 0x3f) >> 4);
                *r++ = (((b - 0x20) & 0x3f) << 4) | (((c - 0x20) & 0x3f) >> 2);
                *r++ = (((c - 0x20) & 0x3f) << 6) | (((d - 0x20) & 0x3f) );
            }
            Tcl_SetObjResult(interp, resultPtr);
            return TCL_OK;
        }
    }
}

# -------------------------------------------------------------------------

# Description:
#  Permit more tolerant decoding of invalid input strings by padding to
#  a multiple of 4 bytes with nulls.
# Result:
#  Returns the input string - possibly padded with uuencoded null chars.
#
proc ::uuencode::pad {s} {
    if {[set mod [expr {[string length $s] % 4}]] != 0} {
        append s [string repeat "`" [expr {4 - $mod}]]
    }
    return $s
}

# -------------------------------------------------------------------------

# If the Trf package is available then we shall use this by default but the
# Tcllib implementations are always visible if needed (ie: for testing)
if {[info command ::uuencode::CDecode] != {}} {    
    # tcllib critcl package
    interp alias {} ::uuencode::encode {} ::uuencode::CEncode
    interp alias {} ::uuencode::decode {} ::uuencode::CDecode
} elseif {[package provide Trf] != {}} {
    proc ::uuencode::encode {s} {
        return [::uuencode -mode encode -- $s]
    }
    proc ::uuencode::decode {s} {
        return [::uuencode -mode decode -- [pad $s]]
    }
} else {
    # pure-tcl then
    interp alias {} ::uuencode::encode {} ::uuencode::Encode
    interp alias {} ::uuencode::decode {} ::uuencode::Decode
}

# -------------------------------------------------------------------------

proc ::uuencode::uuencode {args} {
    array set opts {mode 0644 filename {} name {}}
    set wrongargs "wrong \# args: should be\
            \"uuencode ?-name string? ?-mode octal?\
            (-file filename | ?--? string)\""
    while {[string match -* [lindex $args 0]]} {
        switch -glob -- [lindex $args 0] {
            -f* {
                if {[llength $args] < 2} {
                    return -code error $wrongargs
                }
                set opts(filename) [lindex $args 1]
                set args [lreplace $args 0 0]
            }
            -m* {
                if {[llength $args] < 2} {
                    return -code error $wrongargs
                }
                set opts(mode) [lindex $args 1]
                set args [lreplace $args 0 0]
            }
            -n* {
                if {[llength $args] < 2} {
                    return -code error $wrongargs
                }
                set opts(name) [lindex $args 1]
                set args [lreplace $args 0 0]
            }
            -- {
                set args [lreplace $args 0 0]
                break
            }
            default {
                return -code error "bad option [lindex $args 0]:\
                      must be -file, -mode, or -name"
            }
        }
        set args [lreplace $args 0 0]
    }

    if {$opts(name) == {}} {
        set opts(name) $opts(filename)
    }
    if {$opts(name) == {}} {
        set opts(name) "data.dat"
    }

    if {$opts(filename) != {}} {
        set f [open $opts(filename) r]
        fconfigure $f -translation binary
        set data [read $f]
        close $f
    } else {
        if {[llength $args] != 1} {
            return -code error $wrongargs
        }
        set data [lindex $args 0]
    }

    set r {}
    append r [format "begin %o %s" $opts(mode) $opts(name)] "\n"
    for {set n 0} {$n < [string length $data]} {incr n 45} {
        set s [string range $data $n [expr {$n + 44}]]
        append r [Enc [string length $s]]
        append r [encode $s] "\n"
    }
    append r "`\nend"
    return $r
}

# -------------------------------------------------------------------------
# Description:
#  Perform uudecoding of a file or data. A file may contain more than one
#  encoded data section so the result is a list where each element is a 
#  three element list of the provided filename, the suggested mode and the 
#  data itself.
#
proc ::uuencode::uudecode {args} {
    array set opts {mode 0644 filename {}}
    set wrongargs "wrong \# args: should be \"uudecode (-file filename | ?--? string)\""
    while {[string match -* [lindex $args 0]]} {
        switch -glob -- [lindex $args 0] {
            -f* {
                if {[llength $args] < 2} {
                    return -code error $wrongargs
                }
                set opts(filename) [lindex $args 1]
                set args [lreplace $args 0 0]
            }
            -- {
                set args [lreplace $args 0 0]
                break
            }
            default {
                return -code error "bad option [lindex $args 0]:\
                      must be -file"
            }
        }
        set args [lreplace $args 0 0]
    }

    if {$opts(filename) != {}} {
        set f [open $opts(filename) r]
        set data [read $f]
        close $f
    } else {
        if {[llength $args] != 1} {
            return -code error $wrongargs
        }
        set data [lindex $args 0]
    }

    set state false
    set result {}

    foreach {line} [split $data "\n"] {
        switch -exact -- $state {
            false {
                if {[regexp {^begin ([0-7]+) ([^\s]*)} $line \
                         -> opts(mode) opts(name)]} {
                    set state true
                    set r {}
                }
            }

            true {
                if {[string match "end" $line]} {
                    set state false
                    lappend result [list $opts(name) $opts(mode) $r]
                } else {
                    scan $line %c c
                    set n [expr {($c - 0x21)}]
                    append r [string range \
                                  [decode [string range $line 1 end]] 0 $n]
                }
            }
        }
    }

    return $result
}

# -------------------------------------------------------------------------

package provide uuencode $::uuencode::version

# -------------------------------------------------------------------------
#
# Local variables:
#   mode: tcl
#   indent-tabs-mode: nil
# End:

<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<




































































































































































































































































































































































































































































































































































































































































































Deleted scriptlibs/tcllib1.12/base64/yencode.tcl.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
# yencode.tcl - Copyright (C) 2002 Pat Thoyts <patthoyts@users.sourceforge.net>
#
# Provide a Tcl only implementation of yEnc encoding algorithm
#
# -------------------------------------------------------------------------
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# -------------------------------------------------------------------------
# @(#)$Id: yencode.tcl,v 1.13 2009/05/07 01:10:37 patthoyts Exp $

# FUTURE: Rework to allow switching between the tcl/critcl implementations.

package require Tcl 8.2;                # tcl minimum version
catch {package require crc32};          # tcllib 1.1
catch {package require tcllibc};        # critcl enhancements for tcllib

namespace eval ::yencode {
    variable version 1.1.3
    namespace export encode decode yencode ydecode
}

# -------------------------------------------------------------------------

proc ::yencode::Encode {s} {
    set r {}
    binary scan $s c* d
    foreach {c} $d {
        set v [expr {($c + 42) % 256}]
        if {$v == 0x00 || $v == 0x09 || $v == 0x0A 
            || $v == 0x0D || $v == 0x3D} {
            append r "="
            set v [expr {($v + 64) % 256}]
        }
        append r [format %c $v]
    }
    return $r
}

proc ::yencode::Decode {s} {
    if {[string length $s] == 0} {return ""}
    set r {}
    set esc 0
    binary scan $s c* d
    foreach c $d {
        if {$c == 61 && $esc == 0} {
            set esc 1
            continue
        }
        set v [expr {($c - 42) % 256}]
        if {$esc} {
            set v [expr {($v - 64) % 256}]
            set esc 0
        }
        append r [format %c $v]
    }
    return $r
}

# -------------------------------------------------------------------------
# C coded versions for critcl built base64c package
# -------------------------------------------------------------------------

if {[package provide critcl] != {}} {
    namespace eval ::yencode {
        critcl::ccode {
            #include <string.h>
        }
        critcl::ccommand CEncode {dummy interp objc objv} {
            Tcl_Obj *inputPtr, *resultPtr;
            int len, rlen, xtra;
            unsigned char *input, *p, *r, v;
            
            if (objc !=  2) {
                Tcl_WrongNumArgs(interp, 1, objv, "data");
                return TCL_ERROR;
            }
            
            /* fetch the input data */
            inputPtr = objv[1];
            input = Tcl_GetByteArrayFromObj(inputPtr, &len);

            /* calculate the length of the encoded result */
            rlen = len;
            for (p = input; p < input + len; p++) {
                v = (*p + 42) % 256;
                if (v == 0 || v == 9 || v == 0x0A || v == 0x0D || v == 0x3D)
                   rlen++;
            }
            
            /* allocate the output buffer */
            resultPtr = Tcl_NewObj();
            r = Tcl_SetByteArrayLength(resultPtr, rlen);
            
            /* encode the input */
            for (p = input; p < input + len; p++) {
                v = (*p + 42) % 256;
                if (v == 0 || v == 9 || v == 0x0A || v == 0x0D || v == 0x3D) {
                    *r++ = '=';
                    v = (v + 64) % 256;
                }
                *r++ = v;
            }
            Tcl_SetObjResult(interp, resultPtr);
            return TCL_OK;
        }

        critcl::ccommand CDecode {dummy interp objc objv} {
            Tcl_Obj *inputPtr, *resultPtr;
            int len, rlen, esc;
            unsigned char *input, *p, *r, v;
            
            if (objc !=  2) {
                Tcl_WrongNumArgs(interp, 1, objv, "data");
                return TCL_ERROR;
            }
            
            /* fetch the input data */
            inputPtr = objv[1];
            input = Tcl_GetByteArrayFromObj(inputPtr, &len);

            /* allocate the output buffer */
            resultPtr = Tcl_NewObj();
            r = Tcl_SetByteArrayLength(resultPtr, len);
            
            /* encode the input */
            for (p = input, esc = 0, rlen = 0; p < input + len; p++) {
                if (*p == 61 && esc == 0) {
                    esc = 1;
                    continue;
                }
                v = (*p - 42) % 256;
                if (esc) {
                    v = (v - 64) % 256;
                    esc = 0;
                }
                *r++ = v;
                rlen++;
            }
            Tcl_SetByteArrayLength(resultPtr, rlen);
            Tcl_SetObjResult(interp, resultPtr);
            return TCL_OK;
        }
    }
}

if {[info command ::yencode::CEncode] != {}} {
    interp alias {} ::yencode::encode {} ::yencode::CEncode
    interp alias {} ::yencode::decode {} ::yencode::CDecode
} else {
    interp alias {} ::yencode::encode {} ::yencode::Encode
    interp alias {} ::yencode::decode {} ::yencode::Decode
}

# -------------------------------------------------------------------------
# Description:
#  Pop the nth element off a list. Used in options processing.
#
proc ::yencode::Pop {varname {nth 0}} {
    upvar $varname args
    set r [lindex $args $nth]
    set args [lreplace $args $nth $nth]
    return $r
}

# -------------------------------------------------------------------------

proc ::yencode::yencode {args} {
    array set opts {mode 0644 filename {} name {} line 128 crc32 1}
    while {[string match -* [lindex $args 0]]} {
        switch -glob -- [lindex $args 0] {
            -f* { set opts(filename) [Pop args 1] }
            -m* { set opts(mode) [Pop args 1] }
            -n* { set opts(name) [Pop args 1] }
            -l* { set opts(line) [Pop args 1] }
            -c* { set opts(crc32) [Pop args 1] }
            --  { Pop args ; break }
            default {
                set options [join [lsort [array names opts]] ", -"]
                return -code error "bad option [lindex $args 0]:\
                      must be -$options"
            }
        }
        Pop args
    }

    if {$opts(name) == {}} {
        set opts(name) $opts(filename)
    }
    if {$opts(name) == {}} {
        set opts(name) "data.dat"
    }
    if {! [string is boolean $opts(crc32)]} {
        return -code error "bad option -crc32: argument must be true or false"
    }

    if {$opts(filename) != {}} {
        set f [open $opts(filename) r]
        fconfigure $f -translation binary
        set data [read $f]
        close $f
    } else {
        if {[llength $args] != 1} {
            return -code error "wrong \# args: should be\
                  \"yencode ?options? -file name | data\""
        }
        set data [lindex $args 0]
    }
    
    set opts(size) [string length $data]
    
    set r {}
    append r [format "=ybegin line=%d size=%d name=%s" \
                  $opts(line) $opts(size) $opts(name)] "\n"

    set ndx 0
    while {$ndx < $opts(size)} {
        set pln [string range $data $ndx [expr {$ndx + $opts(line) - 1}]]
        set enc [encode $pln]
        incr ndx [string length $pln]
        append r $enc "\r\n"
    }

    append r [format "=yend size=%d" $ndx]
    if {$opts(crc32)} {
        append r " crc32=" [crc::crc32 -format %x $data]
    }
    return $r
}

# -------------------------------------------------------------------------
# Description:
#  Perform ydecoding of a file or data. A file may contain more than one
#  encoded data section so the result is a list where each element is a 
#  three element list of the provided filename, the file size and the 
#  data itself.
#
proc ::yencode::ydecode {args} {
    array set opts {mode 0644 filename {} name default.bin}
    while {[string match -* [lindex $args 0]]} {
        switch -glob -- [lindex $args 0] {
            -f* { set opts(filename) [Pop args 1] }
            -- { Pop args ; break; }
            default {
                set options [join [lsort [array names opts]] ", -"]
                return -code error "bad option [lindex $args 0]:\
                      must be -$opts"
            }
        }
        Pop args
    }

    if {$opts(filename) != {}} {
        set f [open $opts(filename) r]
        set data [read $f]
        close $f
    } else {
        if {[llength $args] != 1} {
            return -code error "wrong \# args: should be\
                  \"ydecode ?options? -file name | data\""
        }
        set data [lindex $args 0]
    }

    set state false
    set result {}

    foreach {line} [split $data "\n"] {
        set line [string trimright $line "\r\n"]
        switch -exact -- $state {
            false {
                if {[string match "=ybegin*" $line]} {
                    regexp {line=(\d+)} $line -> opts(line)
                    regexp {size=(\d+)} $line -> opts(size)
                    regexp {name=(\d+)} $line -> opts(name)

                    if {$opts(name) == {}} {
                        set opts(name) default.bin
                    }

                    set state true
                    set r {}
                }
            }

            true {
                if {[string match "=yend*" $line]} {
                    set state false
                    lappend result [list $opts(name) $opts(size) $r]
                } else {
                    append r [decode $line]
                }
            }
        }
    }

    return $result
}

# -------------------------------------------------------------------------

package provide yencode $::yencode::version

# -------------------------------------------------------------------------
#
# Local variables:
#   mode: tcl
#   indent-tabs-mode: nil
# End:

<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<










































































































































































































































































































































































































































































































































































































































Deleted scriptlibs/tcllib1.12/bee/bee.tcl.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
# bee.tcl --
#
#	BitTorrent Bee de- and encoder.
#
# Copyright (c) 2004 by Andreas Kupries <andreas_kupries@users.sourceforge.net>
# See the file license.terms.

package require Tcl 8.4

namespace eval ::bee {
    # Encoder commands
    namespace export \
	    encodeString encodeNumber \
	    encodeListArgs encodeList \
	    encodeDictArgs encodeDict

    # Decoder commands.
    namespace export \
	    decode \
	    decodeChannel \
	    decodeCancel \
	    decodePush

    # Channel decoders, reference to state information, keyed by
    # channel handle.

    variable  bee
    array set bee {}

    # Counter for generation of names for the state variables.

    variable count 0

    # State information for the channel decoders.

    # stateN, with N an integer number counting from 0 on up.
    # ...(chan)   Handle of channel the decoder is for.
    # ...(cmd)    Command prefix, completion callback
    # ...(exact)  Boolean flag, set for exact processing.
    # ...(read)   Buffer for new characters to process.
    # ...(type)   Type of current value (integer, string, list, dict)
    # ...(value)  Buffer for assembling the current value.
    # ...(pend)   Stack of pending 'value' buffers, for nested
    #             containers.
    # ...(state)  Current state of the decoding state machine.

    # States of the finite automaton ...
    # intro  - One char, type of value, or 'e' as stop of container.
    # signum - sign or digit, for integer.
    # idigit - digit, for integer, or 'e' as stop
    # ldigit - digit, for length of string, or :
    # data   - string data, 'get' characters.
    # Containers via 'pend'.

    #Debugging help, nesting level
    #variable X 0
}


# ::bee::encodeString --
#
#	Encode a string to bee-format.
#
# Arguments:
#	string	The string to encode.
#
# Results:
#	The bee-encoded form of the string.

proc ::bee::encodeString {string} {
    return "[string length $string]:$string"
}


# ::bee::encodeNumber --
#
#	Encode an integer number to bee-format.
#
# Arguments:
#	num	The integer number to encode.
#
# Results:
#	The bee-encoded form of the integer number.

proc ::bee::encodeNumber {num} {
    if {![string is integer -strict $num]} {
	return -code error "Expected integer number, got \"$num\""
    }

    # The reformatting deals with hex, octal and other tcl
    # representation of the value. In other words we normalize the
    # string representation of the input value.

    set num [format %d $num]
    return "i${num}e"
}


# ::bee::encodeList --
#
#	Encode a list of bee-coded values to bee-format.
#
# Arguments:
#	list	The list to encode.
#
# Results:
#	The bee-encoded form of the list.

proc ::bee::encodeList {list} {
    return "l[join $list ""]e"
}


# ::bee::encodeListArgs --
#
#	Encode a variable list of bee-coded values to bee-format.
#
# Arguments:
#	args	The values to encode.
#
# Results:
#	The bee-encoded form of the list of values.

proc ::bee::encodeListArgs {args} {
    return [encodeList $args]
}


# ::bee::encodeDict --
#
#	Encode a dictionary of keys and bee-coded values to bee-format.
#
# Arguments:
#	dict	The dictionary to encode.
#
# Results:
#	The bee-encoded form of the dictionary.

proc ::bee::encodeDict {dict} {
    if {([llength $dict] % 2) == 1} {
	return -code error "Expected even number of elements, got \"[llength $dict]\""
    }
    set temp [list]
    foreach {k v} $dict {
	lappend temp [list $k $v]
    }
    set res "d"
    foreach item [lsort -index 0 $temp] {
	foreach {k v} $item break
	append res [encodeString $k]$v
    }
    append res "e"
    return $res
}


# ::bee::encodeDictArgs --
#
#	Encode a variable dictionary of keys and bee-coded values to bee-format.
#
# Arguments:
#	args	The keys and values to encode.
#
# Results:
#	The bee-encoded form of the dictionary.

proc ::bee::encodeDictArgs {args} {
    return [encodeDict $args]
}


# ::bee::decode --
#
#	Decode a bee-encoded value and returns the embedded tcl
#	value. For containers this recurses into the contained value.
#
# Arguments:
#	value	The string containing the bee-encoded value to decode.
#	evar	Optional. If set the name of the variable to store the
#		index of the first character after the decoded value to.
#	start	Optional. If set the index of the first character of the
#		value to decode. Defaults to 0, i.e. the beginning of the
#		string.
#
# Results:
#	The tcl value embedded in the encoded string.

proc ::bee::decode {value {evar {}} {start 0}} {
    #variable X
    #puts -nonewline "[string repeat "    " $X]decode @$start" ; flush stdout

    if {$evar ne ""} {upvar 1 $evar end} else {set end _}

    if {[string length $value] < ($start+2)} {
	# This checked that the 'start' index is still in the string,
	# and the end of the value most likely as well. Note that each
	# encoded value consists of at least two characters (the
	# bracketing characters for integer, list, and dict, and for
	# string at least one digit length and the colon).

	#puts \t[string length $value]\ <\ ($start+2)
	return -code error "String not large enough for value"
    }

    set type [string index $value $start]

    #puts -nonewline " $type=" ; flush stdout

    if {$type eq "i"} {
	# Extract integer
	#puts -nonewline integer ; flush stdout

	incr start ; # Skip over intro 'i'.
	set end [string first e $value $start]
	if {$end < 0} {
	    return -code error "End of integer number not found"
	}
	incr end -1 ; # Get last character before closing 'e'.
	set num [string range $value $start $end]
	if {
	    [regexp {^-0+$} $num] ||
	    ![string is integer -strict $num] ||
	    (([string length $num] > 1) && [string match 0* $num])
	} {
	    return -code error "Expected integer number, got \"$num\""
	}
	incr end 2 ; # Step after closing 'e' to the beginning of
	# ........ ; # the next bee-value behind the current one.

	#puts " ($num) @$end"
	return $num

    } elseif {($type eq "l") || ($type eq "d")} {
	#puts -nonewline $type\n ; flush stdout

	# Extract list or dictionary, recursively each contained
	# element. From the perspective of the decoder this is the
	# same, the tcl representation of both is a list, and for a
	# dictionary keys and values are also already in the correct
	# order.

	set result [list]
	incr start ; # Step over intro 'e' to beginning of the first
	# ........ ; # contained value, or behind the container (if
	# ........ ; # empty).

	set end $start
	#incr X
	while {[string index $value $start] ne "e"} {
	    lappend result [decode $value end $start]
	    set start $end
	}
	#incr X -1
	incr end

	#puts "[string repeat "    " $X]($result) @$end"

	if {$type eq "d" && ([llength $result] % 2 == 1)} {
	    return -code error "Dictionary has to be of even length"
	}
	return $result

    } elseif {[string match {[0-9]} $type]} {
	#puts -nonewline string ; flush stdout

	# Extract string. First the length, bounded by a colon, then
	# the appropriate number of characters.

	set end [string first : $value $start]
	if {$end < 0} {
	    return -code error "End of string length not found"
	}
	incr end -1
	set length [string range $value $start $end]
	incr end 2 ;# Skip to beginning of the string after the colon

	if {![string is integer -strict $length]} {
	    return -code error "Expected integer number for string length, got \"$length\""
	} elseif {$length < 0} {
	    # This cannot happen. To happen "-" has to be first character,
	    # and this is caught as unknown bee-type.
	    return -code error "Illegal negative string length"
	} elseif {($end + $length) > [string length $value]} {
	    return -code error "String not large enough for value"
	}

	#puts -nonewline \[$length\] ; flush stdout
	if {$length > 0} {
	    set  start $end
	    incr end $length
	    incr end -1
	    set result [string range $value $start $end]
	    incr end
	} else {
	    set result ""
	}

	#puts " ($result) @$end"
	return $result

    } else {
	return -code error "Unknown bee-type \"$type\""
    }
}

# ::bee::decodeIndices --
#
#	Similar to 'decode', but does not return the decoded tcl values,
#	but a structure containing the start- and end-indices for all
#	values in the structure.
#
# Arguments:
#	value	The string containing the bee-encoded value to decode.
#	evar	Optional. If set the name of the variable to store the
#		index of the first character after the decoded value to.
#	start	Optional. If set the index of the first character of the
#		value to decode. Defaults to 0, i.e. the beginning of the
#		string.
#
# Results:
#	The structure of the value, with indices and types for all
#	contained elements.

proc ::bee::decodeIndices {value {evar {}} {start 0}} {
    #variable X
    #puts -nonewline "[string repeat "    " $X]decode @$start" ; flush stdout

    if {$evar ne ""} {upvar 1 $evar end} else {set end _}

    if {[string length $value] < ($start+2)} {
	# This checked that the 'start' index is still in the string,
	# and the end of the value most likely as well. Note that each
	# encoded value consists of at least two characters (the
	# bracketing characters for integer, list, and dict, and for
	# string at least one digit length and the colon).

	#puts \t[string length $value]\ <\ ($start+2)
	return -code error "String not large enough for value"
    }

    set type [string index $value $start]

    #puts -nonewline " $type=" ; flush stdout

    if {$type eq "i"} {
	# Extract integer
	#puts -nonewline integer ; flush stdout

	set begin $start

	incr start ; # Skip over intro 'i'.
	set end [string first e $value $start]
	if {$end < 0} {
	    return -code error "End of integer number not found"
	}
	incr end -1 ; # Get last character before closing 'e'.
	set num [string range $value $start $end]
	if {
	    [regexp {^-0+$} $num] ||
	    ![string is integer -strict $num] ||
	    (([string length $num] > 1) && [string match 0* $num])
	} {
	    return -code error "Expected integer number, got \"$num\""
	}
	incr end
	set stop $end
	incr end 1 ; # Step after closing 'e' to the beginning of
	# ........ ; # the next bee-value behind the current one.

	#puts " ($num) @$end"
	return [list integer $begin $stop]

    } elseif {$type eq "l"} {
	#puts -nonewline $type\n ; flush stdout

	# Extract list, recursively each contained element.

	set result [list]

	lappend result list $start @

	incr start ; # Step over intro 'e' to beginning of the first
	# ........ ; # contained value, or behind the container (if
	# ........ ; # empty).

	set end $start
	#incr X

	set contained [list]
	while {[string index $value $start] ne "e"} {
	    lappend contained [decodeIndices $value end $start]
	    set start $end
	}
	lappend result $contained
	#incr X -1
	set stop $end
	incr end

	#puts "[string repeat "    " $X]($result) @$end"

	return [lreplace $result 2 2 $stop]

    } elseif {($type eq "l") || ($type eq "d")} {
	#puts -nonewline $type\n ; flush stdout

	# Extract dictionary, recursively each contained element.

	set result [list]

	lappend result dict $start @

	incr start ; # Step over intro 'e' to beginning of the first
	# ........ ; # contained value, or behind the container (if
	# ........ ; # empty).

	set end $start
	set atkey 1
	#incr X

	set contained [list]
	set val       [list]
	while {[string index $value $start] ne "e"} {
	    if {$atkey} {
		lappend contained [decode $value {} $start]
		lappend val       [decodeIndices $value end $start]
		set atkey 0
	    } else {
		lappend val       [decodeIndices $value end $start]
		lappend contained $val
		set val [list]
		set atkey 1
	    }
	    set start $end
	}
	lappend result $contained
	#incr X -1
	set stop $end
	incr end

	#puts "[string repeat "    " $X]($result) @$end"

	if {[llength $result] % 2 == 1} {
	    return -code error "Dictionary has to be of even length"
	}
	return [lreplace $result 2 2 $stop]

    } elseif {[string match {[0-9]} $type]} {
	#puts -nonewline string ; flush stdout

	# Extract string. First the length, bounded by a colon, then
	# the appropriate number of characters.

	set end [string first : $value $start]
	if {$end < 0} {
	    return -code error "End of string length not found"
	}
	incr end -1
	set length [string range $value $start $end]
	incr end 2 ;# Skip to beginning of the string after the colon

	if {![string is integer -strict $length]} {
	    return -code error "Expected integer number for string length, got \"$length\""
	} elseif {$length < 0} {
	    # This cannot happen. To happen "-" has to be first character,
	    # and this is caught as unknown bee-type.
	    return -code error "Illegal negative string length"
	} elseif {($end + $length) > [string length $value]} {
	    return -code error "String not large enough for value"
	}

	#puts -nonewline \[$length\] ; flush stdout
	incr end -1
	if {$length > 0} {
	    incr end $length
	    set stop $end
	} else {
	    set stop $end
	}
	incr end

	#puts " ($result) @$end"
	return [list string $start $stop]

    } else {
	return -code error "Unknown bee-type \"$type\""
    }
}


# ::bee::decodeChannel --
#
#	Attach decoder for a bee-value to a channel. See the
#	documentation for details.
#
# Arguments:
#	chan			Channel to attach to.
#	-command cmdprefix	Completion callback. Required.
#	-exact			Keep running after completion.
#	-prefix data		Seed for decode buffer.
#
# Results:
#	A token to use when referring to the decoder.
#	For example when canceling it.

proc ::bee::decodeChannel {chan args} {
    variable bee
    if {[info exists bee($chan)]} {
	return -code error "bee-Decoder already active for channel"
    }

    # Create state and token.

    variable  count
    variable  [set st state$count]
    array set $st {}
    set       bee($chan) $st
    upvar 0  $st state
    incr count

    # Initialize the decoder state, process the options. When
    # encountering errors here destroy the half-baked state before
    # throwing the message.

    set       state(chan) $chan
    array set state {
	exact  0
	type   ?
	read   {}
	value  {}
	pend   {}
	state  intro
	get    1
    }

    while {[llength $args]} {
	set option [lindex $args 0]
	set args [lrange $args 1 end]
	if {$option eq "-command"} {
	    if {![llength $args]} {
		unset bee($chan)
		unset state
		return -code error "Missing value for option -command."
	    }
	    set state(cmd) [lindex $args 0]
	    set args       [lrange $args 1 end]

	} elseif {$option eq "-prefix"} {
	    if {![llength $args]} {
		unset bee($chan)
		unset state
		return -code error "Missing value for option -prefix."
	    }
	    set state(read) [lindex $args 0]
	    set args        [lrange $args 1 end]

	} elseif {$option eq "-exact"} {
	    set state(exact) 1
	} else {
	    unset bee($chan)
	    unset state
	    return -code error "Illegal option \"$option\",\
		    expected \"-command\", \"-prefix\", or \"-keep\""
	}
    }

    if {![info exists state(cmd)]} {
	unset bee($chan)
	unset state
	return -code error "Missing required completion callback."
    }

    # Set up the processing of incoming data.

    fileevent $chan readable [list ::bee::Process $chan $bee($chan)]

    # Return the name of the state array as token.
    return $bee($chan)
}

# ::bee::Parse --
#
#	Internal helper. Fileevent handler for a decoder.
#	Parses input and handles both error and eof conditions.
#
# Arguments:
#	token	The decoder to run on its input.
#
# Results:
#	None.

proc ::bee::Process {chan token} {
    if {[catch {Parse $token} msg]} {
	# Something failed. Destroy and report.
	Command $token error $msg
	return
    }

    if {[eof $chan]} {
	# Having data waiting, either in the input queue, or in the
	# output stack (of nested containers) is a failure. Report
	# this instead of the eof.

	variable $token
	upvar 0  $token state

	if {
	    [string length $state(read)] ||
	    [llength       $state(pend)] ||
	    [string length $state(value)] ||
	    ($state(state) ne "intro")
	} {
	    Command $token error "Incomplete value at end of channel"
	} else {
	    Command $token eof
	}
    }
    return
}

# ::bee::Parse --
#
#	Internal helper. Reading from the channel and parsing the input.
#	Uses a hardwired state machine.
#
# Arguments:
#	token	The decoder to run on its input.
#
# Results:
#	None.

proc ::bee::Parse {token} {
    variable $token
    upvar 0  $token state
    upvar 0  state(state) current
    upvar 0  state(read)  input
    upvar 0  state(type)  type
    upvar 0  state(value) value
    upvar 0  state(pend)  pend
    upvar 0  state(exact) exact
    upvar 0  state(get)   get
    set chan $state(chan)

    #puts Parse/$current

    if {!$exact} {
	# Add all waiting characters to the buffer so that we can process as
	# much as is possible in one go.
	append input [read $chan]
    } else {
	# Exact reading. Usually one character, but when in the data
	# section for a string value we know for how many characters
	# we are looking for.

	append input [read $chan $get]
    }

    # We got nothing, do nothing.
    if {![string length $input]} return


    if {$current eq "data"} {
	# String data, this can be done faster, as we read longer
	# sequences of characters for this.
	set l [string length $input]
	if {$l < $get} {
	    # Not enough, wait for more.
	    append value $input
	    incr get -$l
	    return
	} elseif {$l == $get} {
	    # Got all, exactly. Prepare state machine for next value.

	    if {[Complete $token $value$input]} return

	    set current intro
	    set get 1
	    set value ""
	    set input ""

	    return
	} else {
	    # Got more than required (only for !exact).

	    incr get -1
	    if {[Complete $token $value[string range $input 0 $get]]} {return}

	    incr get
	    set input [string range $input $get end]
	    set get 1
	    set value ""
	    set current intro
	    # This now falls into the loop below.
	}
    }

    set where 0
    set n [string length $input]

    #puts Parse/$n

    while {$where < $n} {
	# Hardwired state machine. Get current character.
	set ch [string index $input $where]

	#puts Parse/@$where/$current/$ch/
	if {$current eq "intro"} {
	    # First character of a value.

	    if {$ch eq "i"} {
		# Begin reading integer.
		set type    integer
		set current signum
	    } elseif {$ch eq "l"} {
		# Begin a list.
		set type list
		lappend pend list {}
		#set current intro

	    } elseif {$ch eq "d"} {
		# Begin a dictionary.
		set type dict
		lappend pend dict {}
		#set current intro

	    } elseif {$ch eq "e"} {
		# Close a container. Throw an error if there is no
		# container to close.

		if {![llength $pend]} {
		    return -code error "End of container outside of container."
		}

		set v    [lindex $pend end]
		set t    [lindex $pend end-1]
		set pend [lrange $pend 0 end-2]

		if {$t eq "dict" && ([llength $v] % 2 == 1)} {
		    return -code error "Dictionary has to be of even length"
		}

		if {[Complete $token $v]} {return}
		set current intro

	    } elseif {[string match {[0-9]} $ch]} {
		# Begin reading a string, length section first.
		set type    string
		set current ldigit
		set value   $ch

	    } else {
		# Unknown type. Throw error.
		return -code error "Unknown bee-type \"$ch\""
	    }

	    # To next character.
	    incr where
	} elseif {$current eq "signum"} {
	    # Integer number, a minus sign, or a digit.
	    if {[string match {[-0-9]} $ch]} {
		append value $ch
		set current idigit
	    } else {
		return -code error "Syntax error in integer,\
			expected sign or digit, got \"$ch\""
	    }
	    incr where

	} elseif {$current eq "idigit"} {
	    # Integer number, digit or closing 'e'.

	    if {[string match {[-0-9]} $ch]} {
		append value $ch
	    } elseif {$ch eq "e"} {
		# Integer closes. Validate and report.
		#puts validate
		if {
		    [regexp {^-0+$} $value] ||
		    ![string is integer -strict $value] ||
		    (([string length $value] > 1) && [string match 0* $value])
		} {
		    return -code error "Expected integer number, got \"$value\""
		}

		if {[Complete $token $value]} {return}
		set value ""
		set current intro
	    } else {
		return -code error "Syntax error in integer,\
			expected digit, or 'e', got \"$ch\""
	    }
	    incr where

	} elseif {$current eq "ldigit"} {
	    # String, length section, digit, or :

	    if {[string match {[-0-9]} $ch]} {
		append value $ch

	    } elseif {$ch eq ":"} {
		# Length section closes, validate,
		# then perform data processing.

		set num $value
		if {
		    [regexp {^-0+$} $num] ||
		    ![string is integer -strict $num] ||
		    (([string length $num] > 1) && [string match 0* $num])
		} {
		    return -code error "Expected integer number as string length, got \"$num\""
		}

		set value ""

		# We may have already part of the data in
		# memory. Process that piece before looking for more.

		incr where
		set have [expr {$n - $where}]
		if {$num < $have} {
		    # More than enough in the buffer.

		    set  end $where
		    incr end $num
		    incr end -1

		    if {[Complete $token [string range $input $where $end]]} {return}

		    set where   $end ;# Further processing behind the string.
		    set current intro

		} elseif {$num == $have} {
		    # Just enough. 

		    if {[Complete $token [string range $input $where end]]} {return}

		    set where   $n
		    set current intro
		} else {
		    # Not enough. Initialize value with the data we
		    # have (after the colon) and stop processing for
		    # now.

		    set value   [string range $input $where end]
		    set current data
		    set get     $num
		    set input   ""
		    return
		}
	    } else {
		return -code error "Syntax error in string length,\
			expected digit, or ':', got \"$ch\""
	    }
	    incr where
	} else {
	    # unknown state = internal error
	    return -code error "Unknown decoder state \"$current\", internal error"
	}
    }

    set input ""
    return
}

# ::bee::Command --
#
#	Internal helper. Runs the decoder command callback.
#
# Arguments:
#	token	The decoder invoking its callback
#	how	Which method to invoke (value, error, eof)
#	args	Arguments for the method.
#
# Results:
#	A boolean flag. Set if further processing has to stop.

proc ::bee::Command {token how args} {
    variable $token
    upvar 0  $token state

    #puts Report/$token/$how/$args/

    set cmd  $state(cmd)
    set chan $state(chan)

    # We catch the fileevents because they will fail when this is
    # called from the 'Close'. The channel will already be gone in
    # that case.

    set stop 0
    if {($how eq "error") || ($how eq "eof")} {
	variable bee

	set stop 1
	fileevent $chan readable {}
	unset bee($chan)
	unset state

	if {$how eq "eof"} {
	    #puts \tclosing/$chan
	    close $chan
	}
    }

    lappend cmd $how $token
    foreach a $args {lappend cmd $a}
    uplevel #0 $cmd

    if {![info exists state]} {
	# The decoder token was killed by the callback, stop
	# processing.
	set stop 1
    }

    #puts /$stop/[file channels]
    return $stop
}

# ::bee::Complete --
#
#	Internal helper. Reports a completed value.
#
# Arguments:
#	token	The decoder reporting the value.
#	value	The value to report.
#
# Results:
#	A boolean flag. Set if further processing has to stop.

proc ::bee::Complete {token value} {
    variable $token
    upvar 0  $token state
    upvar 0   state(pend) pend

    if {[llength $pend]} {
	# The value is part of a container. Add the value to its end
	# and keep processing.

	set pend [lreplace $pend end end \
		[linsert [lindex $pend end] end \
		$value]]

	# Don't stop.
	return 0
    }

    # The value is at the top, report it. The callback determines if
    # we keep processing.

    return [Command $token value $value]
}

# ::bee::decodeCancel --
#
#	Destroys the decoder referenced by the token.
#
# Arguments:
#	token	The decoder to destroy.
#
# Results:
#	None.

proc ::bee::decodeCancel {token} {
    variable bee
    variable $token
    upvar 0  $token state
    unset bee($state(chan))
    unset state
    return
}

# ::bee::decodePush --
#
#	Push data into the decoder input buffer.
#
# Arguments:
#	token	The decoder to extend.
#	string	The characters to add.
#
# Results:
#	None.

proc ::bee::decodePush {token string} {
    variable $token
    upvar 0  $token state
    append state(read) $string
    return
}


package provide bee 0.1
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<




























































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































Deleted scriptlibs/tcllib1.12/bee/pkgIndex.tcl.

1
2
3
4
# Tcl package index file, version 1.1

if {![package vsatisfies [package provide Tcl] 8.4]} {return}
package ifneeded bee 0.1 [list source [file join $dir bee.tcl]]
<
<
<
<








Deleted scriptlibs/tcllib1.12/bench/bench.tcl.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
# bench.tcl --
#
#	Management of benchmarks.
#
# Copyright (c) 2005-2008 by Andreas Kupries <andreas_kupries@users.sourceforge.net>
# library derived from runbench.tcl application (C) Jeff Hobbs.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: bench.tcl,v 1.14 2008/10/08 03:30:48 andreas_kupries Exp $

# ### ### ### ######### ######### ######### ###########################
## Requisites - Packages and namespace for the commands and data.

package require Tcl 8.2
package require logger
package require csv
package require struct::matrix
package require report

namespace eval ::bench      {}
namespace eval ::bench::out {}

# @mdgen OWNER: libbench.tcl

# ### ### ### ######### ######### ######### ###########################
## Public API - Benchmark execution

# ::bench::run --
#
#	Run a series of benchmarks.
#
# Arguments:
#	...
#
# Results:
#	Dictionary.

proc ::bench::run {args} {
    log::debug [linsert $args 0 ::bench::run]

    # -errors  0|1         default 1, propagate errors in benchmarks
    # -threads <num>       default 0, no threads, #threads to use
    # -match  <pattern>    only run tests matching this pattern
    # -rmatch <pattern>    only run tests matching this pattern
    # -iters  <num>        default 1000, max#iterations for any benchmark
    # -pkgdir <dir>        Defaults to nothing, regular bench invokation.

    # interps - dict (path -> version)
    # files   - list (of files)

    # Process arguments ......................................
    # Defaults first, then overides by the user

    set errors  1    ; # Propagate errors
    set threads 0    ; # Do not use threads
    set match   {}   ; # Do not exclude benchmarks based on glob pattern
    set rmatch  {}   ; # Do not exclude benchmarks based on regex pattern
    set iters   1000 ; # Limit #iterations for any benchmark
    set pkgdirs {}   ; # List of dirs to put in front of auto_path in the
                       # bench interpreters. Default: nothing.

    while {[string match "-*" [set opt [lindex $args 0]]]} {
	set val [lindex $args 1]
	switch -exact -- $opt {
	    -errors {
		if {![string is boolean -strict $val]} {
		    return -code error "Expected boolean, got \"$val\""
		}
		set errors $val
	    }
	    -threads {
		if {![string is int -strict $val] || ($val < 0)} {
		    return -code error "Expected int >= 0, got \"$val\""
		}
		set threads [lindex $args 1]
	    }
	    -match {
		set match [lindex $args 1]
	    }
	    -rmatch {
		set rmatch [lindex $args 1]
	    }
	    -iters {
		if {![string is int -strict $val] || ($val <= 0)} {
		    return -code error "Expected int > 0, got \"$val\""
		}
		set iters   [lindex $args 1]
	    }
	    -pkgdir {
		CheckPkgDirArg  $val
		lappend pkgdirs $val
	    }
	    default {
		return -code error "Unknown option \"$opt\", should -errors, -threads, -match, -rmatch, or -iters"
	    }
	}
	set args [lrange $args 2 end]
    }
    if {[llength $args] != 2} {
	return -code error "wrong\#args, should be: ?options? interp files"
    }
    foreach {interps files} $args break

    # Run the benchmarks .....................................

    array set DATA {}

    if {![llength $pkgdirs]} {
	# No user specified package directories => Simple run.
	foreach {ip ver} $interps {
	    Invoke $ip $ver {} ;# DATA etc passed via upvar.
	}
    } else {
	# User specified package directories.
	foreach {ip ver} $interps {
	    foreach pkgdir $pkgdirs {
		Invoke $ip $ver $pkgdir ;# DATA etc passed via upvar.
	    }
	}
    }

    # Benchmark data ... Structure, dict (key -> value)
    #
    # Key          || Value
    # ============ ++ =========================================
    # interp IP    -> Version. Shell IP was used to run benchmarks. IP is
    #                 the path to the shell.
    #
    # desc DESC    -> "". DESC is description of an executed benchmark.
    #
    # usec DESC IP -> Result. Result of benchmark DESC when run by the
    #                 shell IP. Usually time in microseconds, but can be
    #                 a special code as well (ERR, BAD_RES).
    # ============ ++ =========================================

    return [array get DATA]
}

# ::bench::locate --
#
#	Locate interpreters on the pathlist, based on a pattern.
#
# Arguments:
#	...
#
# Results:
#	List of paths.

proc ::bench::locate {pattern paths} {
    # Cache of executables already found.
    array set var {}
    set res {}

    foreach path $paths {
	foreach ip [glob -nocomplain [file join $path $pattern]] {
	    if {[package vsatisfies [package provide Tcl] 8.4]} {
		set ip [file normalize $ip]
	    }

	    # Follow soft-links to the actual executable.
	    while {[string equal link [file type $ip]]} {
		set link [file readlink $ip]
		if {[string match relative [file pathtype $link]]} {
		    set ip [file join [file dirname $ip] $link]
		} else {
		    set ip $link
		}
	    }

	    if {
		[file executable $ip] && ![info exists var($ip)]
	    } {
		if {[catch {exec $ip << "exit"} dummy]} {
		    log::debug "$ip: $dummy"
		    continue
		}
		set var($ip) .
		lappend res $ip
	    }
	}
    }

    return $res
}

# ::bench::versions --
#
#	Take list of interpreters, find their versions.
#	Removes all interps for which it cannot do so.
#
# Arguments:
#	List of interpreters (paths)
#
# Results:
#	dictionary: interpreter -> version.

proc ::bench::versions {interps} {
    set res {}
    foreach ip $interps {
	if {[catch {
	    exec $ip << {puts [info patchlevel] ; exit}
	} patchlevel]} {
	    log::debug "$ip: $patchlevel"
	    continue
	}

	lappend res [list $patchlevel $ip]
    }

    # -uniq 8.4-ism, replaced with use of array.
    array set tmp {}
    set resx {}
    foreach item [lsort -dictionary -decreasing -index 0 $res] {
	foreach {p ip} $item break
	if {[info exists tmp($p)]} continue
	set tmp($p) .
	lappend resx $ip $p
    }

    return $resx
}

# ::bench::merge --
#
#	Take the data of several benchmark runs and merge them into
#	one data set.
#
# Arguments:
#	One or more data sets to merge
#
# Results:
#	The merged data set.

proc ::bench::merge {args} {
    if {[llength $args] == 1} {
	return [lindex $args 0]
    }

    array set DATA {}
    foreach data $args {
	array set DATA $data
    }
    return [array get DATA]
}

# ::bench::norm --
#
#	Normalize the time data in the dataset, using one of the
#	columns as reference.
#
# Arguments:
#	Data to normalize
#	Index of reference column
#
# Results:
#	The normalized data set.

proc ::bench::norm {data col} {

    if {![string is integer -strict $col]} {
	return -code error "Ref.column: Expected integer, but got \"$col\""
    }
    if {$col < 1} {
	return -code error "Ref.column out of bounds"
    }

    array set DATA $data
    set ipkeys [array names DATA interp*]

    if {$col > [llength $ipkeys]} {
	return -code error "Ref.column out of bounds"
    }
    incr col -1
    set refip [lindex [lindex [lsort -dict $ipkeys] $col] 1]

    foreach key [array names DATA] {
	if {[string match "desc*"   $key]} continue
	if {[string match "interp*" $key]} continue

	foreach {_ desc ip} $key break
	if {[string equal $ip $refip]}      continue

	set v $DATA($key)
	if {![string is double -strict $v]} continue

	if {![info exists DATA([list usec $desc $refip])]} {
	    # We cannot normalize, we do not keep the time value.
	    # The row will be shown, empty.
	    set DATA($key) ""
	    continue
	}
	set vref $DATA([list usec $desc $refip])

	if {![string is double -strict $vref]} continue

	set DATA($key) [expr {$v/double($vref)}]
    }

    foreach key [array names DATA [list * $refip]] {
	if {![string is double -strict $DATA($key)]} continue
	set DATA($key) 1
    }

    return [array get DATA]
}

# ::bench::edit --
#
#	Change the 'path' of an interp to a user-defined value.
#
# Arguments:
#	Data to edit
#	Index of column to change
#	The value replacing the current path
#
# Results:
#	The changed data set.

proc ::bench::edit {data col new} {

    if {![string is integer -strict $col]} {
	return -code error "Ref.column: Expected integer, but got \"$col\""
    }
    if {$col < 1} {
	return -code error "Ref.column out of bounds"
    }

    array set DATA $data
    set ipkeys [array names DATA interp*]

    if {$col > [llength $ipkeys]} {
	return -code error "Ref.column out of bounds"
    }
    incr col -1
    set refip [lindex [lindex [lsort -dict $ipkeys] $col] 1]

    if {[string equal $new $refip]} {
	# No change, quick return
	return $data
    }

    set refkey [list interp $refip]
    set DATA([list interp $new]) $DATA($refkey)
    unset                         DATA($refkey)

    foreach key [array names DATA [list * $refip]] {
	if {![string equal [lindex $key 0] "usec"]} continue
	foreach {__ desc ip} $key break
	set DATA([list usec $desc $new]) $DATA($key)
	unset                             DATA($key)
    }

    return [array get DATA]
}

# ::bench::del --
#
#	Remove the data for an interp.
#
# Arguments:
#	Data to edit
#	Index of column to remove
#
# Results:
#	The changed data set.

proc ::bench::del {data col} {

    if {![string is integer -strict $col]} {
	return -code error "Ref.column: Expected integer, but got \"$col\""
    }
    if {$col < 1} {
	return -code error "Ref.column out of bounds"
    }

    array set DATA $data
    set ipkeys [array names DATA interp*]

    if {$col > [llength $ipkeys]} {
	return -code error "Ref.column out of bounds"
    }
    incr col -1
    set refip [lindex [lindex [lsort -dict $ipkeys] $col] 1]

    unset DATA([list interp $refip])

    # Do not use 'array unset'. Keep 8.2 clean.
    foreach key [array names DATA [list * $refip]] {
	if {![string equal [lindex $key 0] "usec"]} continue
	unset DATA($key)
    }

    return [array get DATA]
}

# ### ### ### ######### ######### ######### ###########################
## Public API - Result formatting.

# ::bench::out::raw --
#
#	Format the result of a benchmark run.
#	Style: Raw data.
#
# Arguments:
#	DATA dict
#
# Results:
#	String containing the formatted DATA.

proc ::bench::out::raw {data} {
    return $data
}

# ### ### ### ######### ######### ######### ###########################
## Internal commands

proc ::bench::CheckPkgDirArg {path {expected {}}} {
    # Allow empty string, special.
    if {![string length $path]} return

    if {![file isdirectory $path]} {
	return -code error \
	    "The path \"$path\" is not a directory."
    }
    if {![file readable $path]} {
	return -code error \
	    "The path \"$path\" is not readable."
    }
}

proc ::bench::Invoke {ip ver pkgdir} {
    variable self
    # Import remainder of the current configuration/settings.

    upvar 1 DATA DATA match match rmatch rmatch \
	iters iters errors errors threads threads \
	files files

    if {[string length $pkgdir]} {
	log::info "Benchmark $ver ($pkgdir) $ip"
	set idstr "$ip ($pkgdir)"
    } else {
	log::info "Benchmark $ver $ip"
	set idstr $ip
    }

    set DATA([list interp $idstr]) $ver

    set cmd [list $ip [file join $self libbench.tcl] \
		 -match   $match   \
		 -rmatch  $rmatch  \
		 -iters   $iters   \
		 -interp  $ip      \
		 -errors  $errors  \
		 -threads $threads \
		 -pkgdir  $pkgdir  \
		]

    # Determine elapsed time per file, logged.
    set start [clock seconds]

    array set tmp {}

    if {$threads} {
	foreach f $files { lappend cmd $f }
	if {[catch {
	    close [Process [open |$cmd r+]]
	} output]} {
	    if {$errors} {
		error $::errorInfo
	    }
	}
    } else {
	foreach file $files {
	    log::info [file tail $file]
	    if {[catch {
		close [Process [open |[linsert $cmd end $file] r+]]
	    } output]} {
		if {$errors} {
		    error $::errorInfo
		} else {
		    continue
		}
	    }
	}
    }

    foreach desc [array names tmp] {
	set DATA([list desc $desc]) {}
	set DATA([list usec $desc $idstr]) $tmp($desc)
    }

    unset tmp
    set elapsed [expr {[clock seconds] - $start}]

    set hour [expr {$elapsed / 3600}]
    set min  [expr {$elapsed / 60}]
    set sec  [expr {$elapsed % 60}]
    log::info " [format %.2d:%.2d:%.2d $hour $min $sec] elapsed"
    return
}


proc ::bench::Process {pipe} {
    while {1} {
	if {[eof  $pipe]} break
	if {[gets $pipe line] < 0} break
	# AK: FUTURE: Log all lines?!
	#puts |$line|
	set line [string trim $line]
	if {[string equal $line ""]} continue

	Result
	Feedback
	# Unknown lines are printed. Future: Callback?!
	log::info $line
    }
    return $pipe
}

proc ::bench::Result {} {
    upvar 1 line line
    if {[lindex $line 0] ne "RESULT"} return
    upvar 2 tmp tmp
    foreach {_ desc result} $line break
    set tmp($desc) $result
    return -code continue
}

proc ::bench::Feedback {} {
    upvar 1 line line
    if {[lindex $line 0] ne "LOG"} return
    # AK: Future - Run through callback?!
    log::info [lindex $line 1]
    return -code continue
}

# ### ### ### ######### ######### ######### ###########################
## Initialize internal data structures.

namespace eval ::bench {
    variable self [file join [pwd] [file dirname [info script]]]

    logger::init bench
    logger::import -force -all -namespace log bench
}

# ### ### ### ######### ######### ######### ###########################
## Ready to run

package provide bench 0.4
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<


















































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































Deleted scriptlibs/tcllib1.12/bench/bench_read.tcl.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
# bench_read.tcl --
#
#	Management of benchmarks, reading results in various formats.
#
# Copyright (c) 2005 by Andreas Kupries <andreas_kupries@users.sourceforge.net>
# library derived from runbench.tcl application (C) Jeff Hobbs.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# 
# RCS: @(#) $Id: bench_read.tcl,v 1.3 2006/06/13 23:20:30 andreas_kupries Exp $

# ### ### ### ######### ######### ######### ###########################
## Requisites - Packages and namespace for the commands and data.

package require Tcl 8.2
package require csv

namespace eval ::bench::in {}

# ### ### ### ######### ######### ######### ###########################
## Public API - Result reading

# ::bench::in::read --
#
#	Read a bench result in any of the raw/csv/text formats
#
# Arguments:
#	path to file to read
#
# Results:
#	DATA dictionary, internal representation of the bench results.

proc ::bench::in::read {file} {

    set f [open $file r]
    set head [gets $f]

    if {![string match "# -\\*- tcl -\\*- bench/*" $head]} {
	return -code error "Bad file format, not a benchmark file"
    } else {
	regexp {bench/(.*)$} $head -> format

	switch -exact -- $format {
	    raw - csv - text {
		set res [RD$format $f]
	    }
	    default {
		return -code error "Bad format \"$val\", expected text, csv, or raw"
	    }
	}
    }
    close $f
    return $res
}

# ### ### ### ######### ######### ######### ###########################
## Internal commands

proc ::bench::in::RDraw {chan} {
    return [string trimright [::read $chan]]
}

proc ::bench::in::RDcsv {chan} {
    # Lines                                     Format
    # First line is number of interpreters #n.  int
    # Next to 1+n is interpreter data.          id,ver,path
    # Beyond is benchmark results.              id,desc,res1,...,res#n

    array set DATA {}

    # #Interp ...

    set nip [lindex [csv::split [gets $chan]] 0]

    # Interp data ...

    set iplist {}
    for {set i 0} {$i < $nip} {incr i} {
	foreach {__ ver ip} [csv::split [gets $chan]] break

	set DATA([list interp $ip]) $ver
	lappend iplist $ip
    }

    # Benchmark data ...

    while {[gets $chan line] >= 0} {
	set line [string trim $line]
	if {$line == {}} break
	set line [csv::split $line]
	set desc [lindex $line 1]

	set DATA([list desc $desc]) {}
	foreach val [lrange $line 2 end] ip $iplist {
	    if {$val == {}} continue
	    set DATA([list usec $desc $ip]) $val
	}
    }

    return [array get DATA]
}

proc ::bench::in::RDtext {chan} {
    array set DATA {}

    # Interp data ...

    # Empty line     - ignore
    # "id: ver path" - interp data.
    # Empty line     - separator before benchmark data.

    set n 0
    set iplist {}
    while {[gets $chan line] >= 0} {
	set line [string trim $line]
	if {$line == {}} {
	    incr n
	    if {$n == 2} break
	    continue
	}

	regexp {[^:]+: ([^ ]+) (.*)$} $line -> ver ip
	set DATA([list interp $ip]) $ver
	lappend iplist $ip
    }

    # Benchmark data ...

    # '---' -> Ignore.
    # '|' column separators. Remove spaces around it. Then treat line
    # as CSV data with a particular separator.
    # Ignore the INTERP line.

    while {[gets $chan line] >= 0} {
	set line [string trim $line]
	if {$line == {}}                     continue
	if {[string match "+---*"    $line]} continue
	if {[string match "*INTERP*" $line]} continue

	regsub -all "\\| +" $line {|} line
	regsub -all " +\\|" $line {|} line
	set line [csv::split [string trim $line |] |]
	set desc [lindex $line 1]

	set DATA([list desc $desc]) {}
	foreach val [lrange $line 2 end] ip $iplist {
	    if {$val == {}} continue
	    set DATA([list usec $desc $ip]) $val
	}
    }

    return [array get DATA]
}

# ### ### ### ######### ######### ######### ###########################
## Initialize internal data structures.

# ### ### ### ######### ######### ######### ###########################
## Ready to run

package provide bench::in 0.1
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<




































































































































































































































































































































Deleted scriptlibs/tcllib1.12/bench/bench_wcsv.tcl.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
# bench_wtext.tcl --
#
#	Management of benchmarks, formatted text.
#
# Copyright (c) 2005 by Andreas Kupries <andreas_kupries@users.sourceforge.net>
# library derived from runbench.tcl application (C) Jeff Hobbs.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# 
# RCS: @(#) $Id: bench_wcsv.tcl,v 1.4 2007/01/21 23:29:06 andreas_kupries Exp $

# ### ### ### ######### ######### ######### ###########################
## Requisites - Packages and namespace for the commands and data.

package require Tcl 8.2
package require csv

namespace eval ::bench::out {}

# ### ### ### ######### ######### ######### ###########################
## Public API - Benchmark execution

# ### ### ### ######### ######### ######### ###########################
## Public API - Result formatting.

# ::bench::out::csv --
#
#	Format the result of a benchmark run.
#	Style: CSV
#
# Arguments:
#	DATA dict
#
# Results:
#	String containing the formatted DATA.

proc ::bench::out::csv {data} {
    array set DATA $data
    set CSV {}

    # 1st record:              #shells
    # 2nd record to #shells+1: Interpreter data (id, version, path)
    # #shells+2 to end:        Benchmark data (id,desc,result1,...,result#shells)

    # --- --- ----
    # #interpreters used

    set ipkeys [array names DATA interp*]
    lappend CSV [csv::join [list [llength $ipkeys]]]

    # --- --- ----
    # Table 1: Interpreter information.

    set n 1
    set iplist {}
    foreach key [lsort -dict $ipkeys] {
	set ip [lindex $key 1]
	lappend CSV [csv::join [list $n $DATA($key) $ip]]
	set DATA($key) $n
	incr n
	lappend iplist $ip
    }

    # --- --- ----
    # Table 2: Benchmark information

    set dlist {}
    foreach key [lsort -dict -index 1 [array names DATA desc*]] {
	lappend dlist [lindex $key 1]
    }

    set n 1
    foreach desc $dlist { 
	set record {}
	lappend record $n
	lappend record $desc
	foreach ip $iplist {
	    if {[catch {
		lappend record $DATA([list usec $desc $ip])
	    }]} {
		lappend record {}
	    }
	}
	lappend CSV [csv::join $record]
	incr n
    }

    return [join $CSV \n]
}

# ### ### ### ######### ######### ######### ###########################
## Internal commands

# ### ### ### ######### ######### ######### ###########################
## Initialize internal data structures.

# ### ### ### ######### ######### ######### ###########################
## Ready to run

package provide bench::out::csv 0.1.2
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<










































































































































































































Deleted scriptlibs/tcllib1.12/bench/bench_wtext.tcl.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
# bench_wtext.tcl --
#
#	Management of benchmarks, formatted text.
#
# Copyright (c) 2005 by Andreas Kupries <andreas_kupries@users.sourceforge.net>
# library derived from runbench.tcl application (C) Jeff Hobbs.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# 
# RCS: @(#) $Id: bench_wtext.tcl,v 1.4 2007/01/21 23:29:06 andreas_kupries Exp $

# ### ### ### ######### ######### ######### ###########################
## Requisites - Packages and namespace for the commands and data.

package require Tcl 8.2
package require struct::matrix
package require report

namespace eval ::bench::out {}

# ### ### ### ######### ######### ######### ###########################
## Public API - Result formatting.

# ::bench::out::text --
#
#	Format the result of a benchmark run.
#	Style: TEXT
#
#	General structure like CSV, but nicely formatted and aligned
#	columns.
#
# Arguments:
#	DATA dict
#
# Results:
#	String containing the formatted DATA.

proc ::bench::out::text {data} {
    array set DATA $data
    set LINES {}

    # 1st line to #shells: Interpreter data (id, version, path)
    # #shells+1 to end:    Benchmark data (id,desc,result1,...,result#shells)

    lappend LINES {}

    # --- --- ----
    # Table 1: Interpreter information.

    set ipkeys [array names DATA interp*]
    set n 1
    set iplist {}
    set vlen 0
    foreach key [lsort -dict $ipkeys] {
	lappend iplist [lindex $key 1]
	incr n
	set l [string length $DATA($key)]
	if {$l > $vlen} {set vlen $l}
    }
    set idlen [string length $n]

    set dlist {}
    set n 1
    foreach key [lsort -dict -index 1 [array names DATA desc*]] {
	lappend dlist [lindex $key 1]
	incr n
    }
    set didlen [string length $n]

    set n 1
    set record [list "" INTERP]
    foreach ip $iplist {
	set v $DATA([list interp $ip])
	lappend LINES " [PADL $idlen $n]: [PADR $vlen $v] $ip"
	lappend record $n
	incr n
    }

    lappend LINES {}

    # --- --- ----
    # Table 2: Benchmark information

    set m [struct::matrix m]
    $m add columns [expr {2 + [llength $iplist]}]
    $m add row $record

    set n 1
    foreach desc $dlist { 
	set     record [list $n]
	lappend record $desc

	foreach ip $iplist {
	    if {[catch {
		set val $DATA([list usec $desc $ip])
	    }]} {
		set val {}
	    }
	    if {[string is double -strict $val]} {
		lappend record [format %.2f $val]
	    } else {
		lappend record [format %s   $val]
	    }
	}
	$m add row $record
	incr n
    }

    ::report::defstyle simpletable {} {
	data	set [split "[string repeat "| "   [columns]]|"]
	top	set [split "[string repeat "+ - " [columns]]+"]
	bottom	set [top get]
	top	enable
	bottom	enable

	set c [columns]
	justify 0 right
	pad 0 both

	if {$c > 1} {
	    justify 1 left
	    pad 1 both
	}
	for {set i 2} {$i < $c} {incr i} {
	    justify $i right
	    pad $i both
	}
    }
    ::report::defstyle captionedtable {{n 1}} {
	simpletable
	topdata   set [data get]
	topcapsep set [top get]
	topcapsep enable
	tcaption $n
    }

    set r [report::report r [$m columns] style captionedtable]
    lappend LINES [$m format 2string $r]
    $m destroy
    $r destroy

    return [join $LINES \n]
}

# ### ### ### ######### ######### ######### ###########################
## Internal commands

proc ::bench::out::PADL {max str} {
    format "%${max}s" $str
    #return "[PAD $max $str]$str"
}

proc ::bench::out::PADR {max str} {
    format "%-${max}s" $str
    #return "$str[PAD $max $str]"
}

# ### ### ### ######### ######### ######### ###########################
## Initialize internal data structures.

# ### ### ### ######### ######### ######### ###########################
## Ready to run

package provide bench::out::text 0.1.2
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<










































































































































































































































































































































Deleted scriptlibs/tcllib1.12/bench/libbench.tcl.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
# -*- tcl -*-
# libbench.tcl ?(<option> <value>)...? <benchFile>...
#
# This file has to have code that works in any version of Tcl that
# the user would want to benchmark.
#
# RCS: @(#) $Id: libbench.tcl,v 1.4 2008/07/02 23:34:06 andreas_kupries Exp $
#
# Copyright (c) 2000-2001 Jeffrey Hobbs.
# Copyright (c) 2007      Andreas Kupries
#

# This code provides the supporting commands for the execution of a
# benchmark files. It is actually an application and is exec'd by the
# management code.

# Options:
# -help				Print usage message.
# -rmatch <regexp-pattern>	Run only tests whose description matches the pattern.
# -match  <glob-pattern>	Run only tests whose description matches the pattern.
# -interp <name>		Name of the interp running the benchmarks.
# -thread <num>                 Invoke threaded benchmarks, number of threads to use.
# -errors <boolean>             Throw errors, or not.

# Note: If both -match and -rmatch are specified then _both_
# apply. I.e. a benchmark will be run if and only if it matches both
# patterns.

# Application activity and results are communicated to the highlevel
# management via text written to stdout. Each line written is a list
# and has one of the following forms:
#
# __THREADED <version>     - Indicates threaded mode, and version
#                            of package Thread in use.
#
# Sourcing {<desc>: <res>} - Benchmark <desc> has started.
#                            <res> is the result from executing
#                            it once (compilation of body.)
#
# Sourcing <file>          - Benchmark file <file> starts execution.
#
# <desc> <res>             - Result of a benchmark.
#
# The above implies that no benchmark may use the strings 'Sourcing'
# or '__THREADED' as their description.

# We will put our data into these named globals.

global BENCH bench

# 'BENCH' contents:
#
# - ERRORS  : Boolean flag. If set benchmark output mismatches are
#             reported by throwing an error. Otherwise they are simply
#             listed as BAD_RES. Default true. Can be set/reset via
#             option -errors.
#
# - MATCH   : Match pattern, see -match, default empty, aka everything
#             matches.
#
# - RMATCH  : Match pattern, see -rmatch, default empty, aka
#             everything matches.
#
# - OUTFILE : Name of output file, default is special value "stdout".
# - OUTFID  : Channel for output.
#
# The outfile cannot be set by the caller, thus output is always
# written to stdout.
#
# - FILES   : List of benchmark files to run.
#
# - ITERS   : Number of iterations to run a benchmark body, default
#             1000. Can be overridden by the individual benchmarks.
#
# - THREADS : Number of threads to use. 0 signals no threading.
#             Limited to number of files if there are less files than
#             requested threads.
#
# - EXIT    : Boolean flag. True when appplication is run by wish, for
#             special exit processing. ... Actually always true.
#
# - INTERP  : Name of the interpreter running the benchmarks. Is the
#             executable running this code. Can be overridden via the
#             command line option -interp.
#
# - uniqid  : Counter for 'bench_tmpfile' to generate unique names of
#             tmp files.
#
# - us      : Thread id of main thread.
#
# - inuse   : Number of threads active, present and relevant only in
#             threaded mode.
#
# - file    : Currently executed benchmark file. Relevant only in
#             non-threaded mode.

#
# 'bench' contents.

# Benchmark results, mapping from the benchmark descriptions to their
# results. Usually time in microseconds, but the following special
# values can occur:
#
# - BAD_RES    - Result from benchmark body does not match expectations.
# - ERR        - Benchmark body aborted with an error.
# - Any string - Forced by error code 666 to pass to management.

#
# We claim all procedures starting with bench*
#

# bench_tmpfile --
#
#   Return a temp file name that can be modified at will
#
# Arguments:
#   None
#
# Results:
#   Returns file name
#
proc bench_tmpfile {} {
    global tcl_platform env BENCH
    if {![info exists BENCH(uniqid)]} { set BENCH(uniqid) 0 }
    set base "tclbench[incr BENCH(uniqid)].dat"
    if {[info exists tcl_platform(platform)]} {
	if {$tcl_platform(platform) == "unix"} {
	    return "/tmp/$base"
	} elseif {$tcl_platform(platform) == "windows"} {
	    return [file join $env(TEMP) $base]
	} else {
	    return $base
	}
    } else {
	# The Good Ol' Days (?) when only Unix support existed
	return "/tmp/$base"
    }
}

# bench_rm --
#
#   Remove a file silently (no complaining)
#
# Arguments:
#   args	Files to delete
#
# Results:
#   Returns nothing
#
proc bench_rm {args} {
    foreach file $args {
	if {[info tclversion] > 7.4} {
	    catch {file delete $file}
	} else {
	    catch {exec /bin/rm $file}
	}
    }
}

proc bench_puts {args} {
    eval [linsert $args 0 FEEDBACK]
    return
}

# bench --
#
#   Main bench procedure.
#   The bench test is expected to exit cleanly.  If an error occurs,
#   it will be thrown all the way up.  A bench proc may return the
#   special code 666, which says take the string as the bench value.
#   This is usually used for N/A feature situations.
#
# Arguments:
#
#   -pre	script to run before main timed body
#   -body	script to run as main timed body
#   -post	script to run after main timed body
#   -ipre	script to run before timed body, per iteration of the body.
#   -ipost	script to run after timed body, per iteration of the body.
#   -desc	message text
#   -iterations	<#>
#
# Note:
#
#   Using -ipre and/or -ipost will cause us to compute the average
#   time ourselves, i.e. 'time body 1' n times. Required to ensure
#   that prefix/post operation are executed, yet not timed themselves.
#
# Results:
#
#   Returns nothing
#
# Side effects:
#
#   Sets up data in bench global array
#
proc bench {args} {
    global BENCH bench errorInfo errorCode

    # -pre script
    # -body script
    # -desc msg
    # -post script
    # -ipre script
    # -ipost script
    # -iterations <#>
    array set opts {
	-pre	{}
	-body	{}
	-desc	{}
	-post	{}
	-ipre	{}
	-ipost	{}
    }
    set opts(-iter) $BENCH(ITERS)
    while {[llength $args]} {
	set key [lindex $args 0]
	switch -glob -- $key {
	    -res*	{ set opts(-res)  [lindex $args 1] }
	    -pr*	{ set opts(-pre)  [lindex $args 1] }
	    -po*	{ set opts(-post) [lindex $args 1] }
	    -ipr*	{ set opts(-ipre)  [lindex $args 1] }
	    -ipo*	{ set opts(-ipost) [lindex $args 1] }
	    -bo*	{ set opts(-body) [lindex $args 1] }
	    -de*	{ set opts(-desc) [lindex $args 1] }
	    -it*	{
		# Only change the iterations when it is smaller than
		# the requested default
		set val [lindex $args 1]
		if {$opts(-iter) > $val} { set opts(-iter) $val }
	    }
	    default {
		error "unknown option $key"
	    }
	}
	set args [lreplace $args 0 1]
    }

    FEEDBACK "Running <$opts(-desc)>"

    if {($BENCH(MATCH) != "") && ![string match $BENCH(MATCH) $opts(-desc)]} {
	return
    }
    if {($BENCH(RMATCH) != "") && ![regexp $BENCH(RMATCH) $opts(-desc)]} {
	return
    }
    if {$opts(-pre) != ""} {
	uplevel \#0 $opts(-pre)
    }
    if {$opts(-body) != ""} {
	# always run it once to remove compile phase confusion
	if {$opts(-ipre) != ""} {
	    uplevel \#0 $opts(-ipre)
	}
	set code [catch {uplevel \#0 $opts(-body)} res]
	if {$opts(-ipost) != ""} {
	    uplevel \#0 $opts(-ipost)
	}
	if {!$code && [info exists opts(-res)] \
		&& [string compare $opts(-res) $res]} {
	    if {$BENCH(ERRORS)} {
		return -code error "Result was:\n$res\nResult\
			should have been:\n$opts(-res)"
	    } else {
		set res "BAD_RES"
	    }
	    #set bench($opts(-desc)) $res
	    RESULT $opts(-desc) $res
	} else {
	    if {($opts(-ipre) != "") || ($opts(-ipost) != "")} {
		# We do the averaging on our own, to allow untimed
		# pre/post execution per iteration. We catch and
		# handle problems in the pre/post code as if
		# everything was executed as one block (like it would
		# be in the other path). We are using floating point
		# to avoid integer overflow, easily happening when
		# accumulating a high number (iterations) of large
		# integers (microseconds).

		set total 0.0
		for {set i 0} {$i < $opts(-iter)} {incr i} {
		    set code 0
		    if {$opts(-ipre) != ""} {
			set code [catch {uplevel \#0 $opts(-ipre)} res]
			if {$code} break
		    }
		    set code [catch {uplevel \#0 [list time $opts(-body) 1]} res]
		    if {$code} break
		    set total [expr {$total + [lindex $res 0]}]
		    if {$opts(-ipost) != ""} {
			set code [catch {uplevel \#0 $opts(-ipost)} res]
			if {$code} break
		    }
		}
		if {!$code} {
		    set res [list [expr {int ($total/$opts(-iter))}] microseconds per iteration]
		}
	    } else {
		set code [catch {uplevel \#0 \
			[list time $opts(-body) $opts(-iter)]} res]
	    }
	    if {!$BENCH(THREADS)} {
		if {$code == 0} {
		    # Get just the microseconds value from the time result
		    set res [lindex $res 0]
		} elseif {$code != 666} {
		    # A 666 result code means pass it through to the bench
		    # suite. Otherwise throw errors all the way out, unless
		    # we specified not to throw errors (option -errors 0 to
		    # libbench).
		    if {$BENCH(ERRORS)} {
			return -code $code -errorinfo $errorInfo \
				-errorcode $errorCode
		    } else {
			set res "ERR"
		    }
		}
		#set bench($opts(-desc)) $res
		RESULT $opts(-desc) $res
	    } else {
		# Threaded runs report back asynchronously
		thread::send $BENCH(us) \
			[list thread_report $opts(-desc) $code $res]
	    }
	}
    }
    if {($opts(-post) != "") && [catch {uplevel \#0 $opts(-post)} err] \
	    && $BENCH(ERRORS)} {
	return -code error "post code threw error:\n$err"
    }
    return
}

proc RESULT {desc time} {
    global BENCH
    puts $BENCH(OUTFID) [list RESULT $desc $time]
    return
}

proc FEEDBACK {text} {
    global BENCH
    puts $BENCH(OUTFID) [list LOG $text]
    return
}


proc usage {} {
    set me [file tail [info script]]
    puts stderr "Usage: $me ?options?\
	    \n\t-help			# print out this message\
	    \n\t-rmatch <regexp>	# only run tests matching this pattern\
	    \n\t-match <glob>		# only run tests matching this pattern\
	    \n\t-interp	<name>		# name of interp (tries to get it right)\
	    \n\t-thread	<num>		# number of threads to use\
	    \n\tfileList		# files to benchmark"
    exit 1
}

#
# Process args
#
if {[catch {set BENCH(INTERP) [info nameofexec]}]} {
    set BENCH(INTERP) $argv0
}
foreach {var val} {
	ERRORS		1
	MATCH		{}
	RMATCH		{}
	OUTFILE		stdout
	FILES		{}
	ITERS		1000
	THREADS		0
        PKGDIR          {}
	EXIT		"[info exists tk_version]"
} {
    if {![info exists BENCH($var)]} {
	set BENCH($var) [subst $val]
    }
}
set BENCH(EXIT) 1

if {[llength $argv]} {
    while {[llength $argv]} {
	set key [lindex $argv 0]
	switch -glob -- $key {
	    -help*	{ usage }
	    -err*	{ set BENCH(ERRORS)  [lindex $argv 1] }
	    -int*	{ set BENCH(INTERP)  [lindex $argv 1] }
	    -rmat*	{ set BENCH(RMATCH)  [lindex $argv 1] }
	    -mat*	{ set BENCH(MATCH)   [lindex $argv 1] }
	    -iter*	{ set BENCH(ITERS)   [lindex $argv 1] }
	    -thr*	{ set BENCH(THREADS) [lindex $argv 1] }
            -pkg*       { set BENCH(PKGDIR)  [lindex $argv 1] }
	    default {
		foreach arg $argv {
		    if {![file exists $arg]} { usage }
		    lappend BENCH(FILES) $arg
		}
		break
	    }
	}
	set argv [lreplace $argv 0 1]
    }
}

if {[string length $BENCH(PKGDIR)]} {
    set auto_path [linsert $auto_path 0 $BENCH(PKGDIR)]
}

if {$BENCH(THREADS)} {
    # We have to be able to load threads if we want to use threads, and
    # we don't want to create more threads than we have files.
    if {[catch {package require Thread}]} {
	set BENCH(THREADS) 0
    } elseif {[llength $BENCH(FILES)] < $BENCH(THREADS)} {
	set BENCH(THREADS) [llength $BENCH(FILES)]
    }
}

rename exit exit.true
proc exit args {
    error "called \"exit $args\" in benchmark test"
}

if {[string compare $BENCH(OUTFILE) stdout]} {
    set BENCH(OUTFID) [open $BENCH(OUTFILE) w]
} else {
    set BENCH(OUTFID) stdout
}

#
# Everything that gets output must be in pairwise format, because
# the data will be collected in via an 'array set'.
#

if {$BENCH(THREADS)} {
    # Each file must run in it's own thread because of all the extra
    # header stuff they have.
    #set DEBUG 1
    proc thread_one {{id 0}} {
	global BENCH
	set file [lindex $BENCH(FILES) 0]
	set BENCH(FILES) [lrange $BENCH(FILES) 1 end]
	if {[file exists $file]} {
	    incr BENCH(inuse)
	    FEEDBACK [list Sourcing $file]
	    if {$id} {
		set them $id
	    } else {
		set them [thread::create]
		thread::send -async $them { load {} Thread }
		thread::send -async $them \
			[list array set BENCH [array get BENCH]]
		thread::send -async $them \
			[list proc bench_tmpfile {} [info body bench_tmpfile]]
		thread::send -async $them \
			[list proc bench_rm {args} [info body bench_rm]]
		thread::send -async $them \
			[list proc bench {args} [info body bench]]
	    }
	    if {[info exists ::DEBUG]} {
		FEEDBACK "SEND [clock seconds] thread $them $file INUSE\
		$BENCH(inuse) of $BENCH(THREADS)"
	    }
	    thread::send -async $them [list source $file]
	    thread::send -async $them \
		    [list thread::send $BENCH(us) [list thread_ready $them]]
	    #thread::send -async $them { thread::unwind }
	}
    }

    proc thread_em {} {
	global BENCH
	while {[llength $BENCH(FILES)]} {
	    if {[info exists ::DEBUG]} {
		FEEDBACK "THREAD ONE [lindex $BENCH(FILES) 0]"
	    }
	    thread_one
	    if {$BENCH(inuse) >= $BENCH(THREADS)} {
		break
	    }
	}
    }

    proc thread_ready {id} {
	global BENCH

	incr BENCH(inuse) -1
	if {[llength $BENCH(FILES)]} {
	    if {[info exists ::DEBUG]} {
		FEEDBACK "SEND ONE [clock seconds] thread $id"
	    }
	    thread_one $id
	} else {
	    if {[info exists ::DEBUG]} {
		FEEDBACK "UNWIND thread $id"
	    }
	    thread::send -async $id { thread::unwind }
	}
    }

    proc thread_report {desc code res} {
	global BENCH bench errorInfo errorCode

	if {$code == 0} {
	    # Get just the microseconds value from the time result
	    set res [lindex $res 0]
	} elseif {$code != 666} {
	    # A 666 result code means pass it through to the bench suite.
	    # Otherwise throw errors all the way out, unless we specified
	    # not to throw errors (option -errors 0 to libbench).
	    if {$BENCH(ERRORS)} {
		return -code $code -errorinfo $errorInfo \
			-errorcode $errorCode
	    } else {
		set res "ERR"
	    }
	}
	#set bench($desc) $res
	RESULT $desc $res
    }

    proc thread_finish {{delay 4000}} {
	global BENCH bench
	set val [expr {[llength [thread::names]] > 1}]
	#set val [expr {$BENCH(inuse)}]
	if {$val} {
	    after $delay [info level 0]
	} else {
	    if {0} {foreach desc [array names bench] {
		RESULT $desc $bench($desc)
	    }}
	    if {$BENCH(EXIT)} {
		exit.true ; # needed for Tk tests
	    }
	}
    }

    set BENCH(us) [thread::id]
    set BENCH(inuse) 0 ; # num threads in use
    FEEDBACK [list __THREADED [package provide Thread]]

    thread_em
    thread_finish
    vwait forever
} else {
    foreach BENCH(file) $BENCH(FILES) {
	if {[file exists $BENCH(file)]} {
	    FEEDBACK [list Sourcing $BENCH(file)]
	    source $BENCH(file)
	}
    }

    if {0} {foreach desc [array names bench] {
	RESULT $desc $bench($desc)
    }}

    if {$BENCH(EXIT)} {
	exit.true ; # needed for Tk tests
    }
}
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<


































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































Deleted scriptlibs/tcllib1.12/bench/pkgIndex.tcl.

1
2
3
4
5
6
7
if {![package vsatisfies [package provide Tcl] 8.2]} {
    return
}
package ifneeded bench            0.4 [list source [file join $dir bench.tcl]]
package ifneeded bench::out::text 0.1.2 [list source [file join $dir bench_wtext.tcl]]
package ifneeded bench::out::csv  0.1.2 [list source [file join $dir bench_wcsv.tcl]]
package ifneeded bench::in        0.1   [list source [file join $dir bench_read.tcl]]
<
<
<
<
<
<
<














Deleted scriptlibs/tcllib1.12/bibtex/bibtex.tcl.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
#####
#
# "BibTeX parser"
# http://wiki.tcl.tk/13719
#
# Tcl code harvested on:   7 Mar 2005, 23:55 GMT
# Wiki page last updated: ???
#
#####

# bibtex.tcl --
#
#      A basic parser for BibTeX bibliography databases.
#
# Copyright (c) 2005 Neil Madden.
# Copyright (c) 2005 Andreas Kupries.
# License: Tcl/BSD style.

### NOTES
###
### Need commands to introspect parser state. Especially the string
### map (for testing of 'addStrings', should be useful in general as
### well).

# ### ### ### ######### ######### #########
## Requisites

package require Tcl 8.4
package require cmdline

# ### ### ### ######### ######### #########
## Implementation: Public API

namespace eval ::bibtex {}

# bibtex::parse --
#
#	Parse a bibtex file.
#
# parse ?options? ?bibtex?

proc ::bibtex::parse {args} {
    variable data
    variable id

    # Argument processing
    if {[llength $args] < 1} {
	set err "[lindex [info level 0] 0] ?options? ?bibtex?"
	return -code error "wrong # args: should be \"$err\""
    }

    array set state {}
    GetOptions $args state

    # Initialize the parser state from the options, fill in default
    # values, and handle the input according the specified mode.

    set token bibtex[incr id]
    foreach {k v} [array get state] {
	set data($token,$k) $v
    }

    if {$state(stream)} {
	# Text not in memory
	if {!$state(bg)} {
	    # Text from a channel, no async processing. We read everything
	    # into memory and the handle it as before.

	    set blockmode [fconfigure $state(-channel) -blocking]
	    fconfigure $state(-channel) -blocking 1
	    set data($token,buffer) [read $state(-channel)]
	    fconfigure $state(-channel) -blocking $blockmode

	    # Tell upcoming processing that the text is in memory.
	    set state(stream) 0
	} else {
	    # Text from a channel, and processing is async. Create an
	    # event handler for the incoming data.

	    set data($token,done) 0
	    fileevent $state(-channel) readable \
		    [list ::bibtex::ReadChan $token]

	    # Initialize the parser internal result buffer if we use plain
	    # -command, and not the SAX api.
	    if {!$state(sax)} {
		set data($token,result) {}
	    }
	}
    }

    # Initialize the string mappings (none known), and the result
    # accumulator.
    set data($token,strings) {}
    set data($token,result)  {}

    if {!$state(stream)} {
	ParseRecords $token 1
	if {$state(sax)} {
	    set result $token
	} else {
	    set result $data($token,result)
	    destroy $token
	}
	return $result
    }

    # Assert: Processing is in background.
    return $token
}

# Cleanup a parser, cancelling any callbacks etc.

proc ::bibtex::destroy {token} {
    variable data

    if {![info exists data($token,stream)]} {
	return -code error "Illegal bibtex parser \"$token\""
    }
    if {$data($token,stream)} {
	fileevent $data($token,-channel) readable {}
    }

    array unset data $token,*
    return
}


proc ::bibtex::wait {token} {
    variable data

    if {![info exists data($token,stream)]} {
	return -code error "Illegal bibtex parser \"$token\""
    }
    vwait ::bibtex::data($token,done)
    return
}

# bibtex::addStrings --
#
#	Add strings to the map for a particular parser. All strings are
#	expanded at parse time.

proc ::bibtex::addStrings {token strings} {
    variable data
    eval [linsert $strings 0 lappend data($token,strings)]
    return
}

# ### ### ### ######### ######### #########
## Implementation: Private utility routines

proc ::bibtex::AddRecord {token type key recdata} {
    variable data
    lappend  data($token,result) [list $type $key $recdata]
    return
}

proc ::bibtex::GetOptions {argv statevar} {
    upvar 1 $statevar state

    # Basic processing of the argument list
    # and the options found therein.

    set opts [lrange [::cmdline::GetOptionDefaults {
	{command.arg         {}}
	{channel.arg         {}}
	{recordcommand.arg   {}}
	{preamblecommand.arg {}}
	{stringcommand.arg   {}}
	{commentcommand.arg  {}}
	{progresscommand.arg {}}
    } result] 2 end] ;# Remove ? and help.

    set argc [llength $argv]
    while {[set err [::cmdline::getopt argv $opts opt arg]]} {
	if {$err < 0} {
	    set olist ""
	    foreach o [lsort $opts] {
		if {[string match *.arg $o]} {
		    set o [string range $o 0 end-4]
		}
		lappend olist -$o
	    }
	    return -code error "bad option \"$opt\",\
		    should be one of\
		    [linsert [join $olist ", "] end-1 or]"
	}
	set state(-$opt) $arg
    }

    # Check the information gained so far
    # for inconsistencies and/or missing
    # pieces.

    set sax [expr {
	[info exists state(-recordcommand)]   ||
	[info exists state(-preamblecommand)] ||
	[info exists state(-stringcommand)]   ||
	[info exists state(-commentcommand)]  ||
	[info exists state(-progresscommand)]
    }] ; # {}

    set bg [info exists state(-command)]

    if {$sax && $bg} {
	# Sax callbacks and channel completion callback exclude each
	# other.
	return -code error "The options -command and -TYPEcommand exclude each other"
    }

    set stream [info exists state(-channel)]

    if {$stream} {
	# Channel is present, a text is not allowed.
	if {[llength $argv]} {
	    return -code error "Option -channel and text exclude each other"
	}

	# The channel has to exist as well.
	if {[lsearch -exact [file channels] $state(-channel)] < 0} {
	    return -code error "Illegal channel handle \"$state(-channel)\""
	}
    } else {
	# Channel is not present, we have to have a text, and only
	# exactly one. And a general -command callback is not allowed.

	if {![llength $argv]} {
	    return -code error "Neither -channel nor text specified"
	} elseif {[llength $argv] > 1} {
	    return -code error "wrong # args: [lindex [info level 1] 0] ?options? ?bibtex?"
	}

	# Channel completion callback is not allowed if we are not
	# reading from a channel.

	if {$bg} {
	    return -code error "Option -command and text exclude each other"
	}

	set state(buffer) [lindex $argv 0]
    }

    set state(stream) $stream
    set state(sax)    $sax
    set state(bg)     [expr {$sax || $bg}]

    if {![info exists state(-stringcommand)]} {
	set state(-stringcommand) [list ::bibtex::addStrings]
    }
    if {![info exists state(-recordcommand)] && (!$sax)} {
	set state(-recordcommand) [list ::bibtex::AddRecord]
    }
    return
}

proc ::bibtex::Callback {token type args} {
    variable data

    #puts stdout "Callback ($token $type ($args))"

    if {[info exists data($token,-${type}command)]} {
	eval $data($token,-${type}command) [linsert $args 0 $token]
    }
    return
}

proc ::bibtex::ReadChan {token} {
    variable data

    # Read the waiting characters into our buffer and process
    # them. The records are saved either through a user supplied
    # record callback, or the standard callback for our non-sax
    # processing.

    set    chan $data($token,-channel)
    append data($token,buffer) [read $chan]

    if {[eof $chan]} {
	# Final processing. In non-SAX mode we have to deliver the
	# completed result before destroying the parser.

	ParseRecords $token 1
	set data($token,done) 1
	if {!$data($token,sax)} {
	    Callback $token {} $data($token,result)
	}
	return
    }

    # Processing of partial data.

    ParseRecords $token 0
    return
}

proc ::bibtex::Tidy {str} {
    return [string tolower [string trim $str]]
}

proc ::bibtex::ParseRecords {token eof} {
    # A rough BibTeX grammar (case-insensitive):
    #
    # Database      ::= (Junk '@' Entry)*
    # Junk          ::= .*?
    # Entry         ::= Record
    #               |   Comment
    #               |   String
    #               |   Preamble
    # Comment       ::= "comment" [^\n]* \n         -- ignored
    # String        ::= "string" '{' Field* '}'
    # Preamble      ::= "preamble" '{' .* '}'       -- (balanced)
    # Record        ::= Type '{' Key ',' Field* '}'
    #               |   Type '(' Key ',' Field* ')' -- not handled
    # Type          ::= Name
    # Key           ::= Name
    # Field         ::= Name '=' Value
    # Name          ::= [^\s\"#%'(){}]*
    # Value         ::= [0-9]+
    #               |   '"' ([^'"']|\\'"')* '"'
    #               |   '{' .* '}'                  -- (balanced)

    # " - Fixup emacs hilit confusion from the grammar above.
    variable data
    set bibtex $data($token,buffer)

    # Split at each @ character which is at the beginning of a line,
    # modulo whitespace. This is a heuristic to distinguish the @'s
    # starting a new record from the @'s occuring inside a record, as
    # part of email addresses. Empty pices at beginning or end are
    # stripped before the split.

    regsub -line -all {^[\n\r\f\t ]*@} $bibtex \000 bibtex
    set db [split [string trim $bibtex \000] \000]

    if {$eof} {
	set total [llength $db]
	set step  [expr {double($total) / 100.0}]
	set istep [expr {$step > 1 ? int($step) : 1}]
	set count 0
    } else {
	if {[llength $db] < 2} {
	    # Nothing to process, or data which ay be incomplete.
	    return
	}

	set data($token,buffer) [lindex $db end]
	set db                  [lrange $db 0 end-1]

	# Fake progress meter.
	set count -1
    }

    foreach block $db {
	if {$count < 0} {
	    Callback $token progress -1
	} elseif {([incr count] % $istep) == 0} {
	    Callback $token progress [expr {int($count / $step)}]
	}
	if {[regexp -nocase {\s*comment([^\n])*\n(.*)} $block \
		-> cmnt rest]} {
	    # Are @comments blocks, or just 1 line?
	    # Does anyone care?
	    Callback $token comment $cmnt

	} elseif {[regexp -nocase {\s*string[^\{]*\{(.*)\}[^\}]*} \
		$block -> rest]} {
	    # string macro defs
	    Callback $token string [ParseBlock $rest]

	} elseif {[regexp -nocase {\s*preamble[^\{]*\{(.*)\}[^\}]*} \
		$block -> rest]} {
	    Callback $token preamble $rest

	} elseif {[regexp {([^\{]+)\{([^,]*),(.*)\}[^\}]*} \
		$block -> type key rest]} {
	    # Do any @string mappings (these are case insensitive)
	    set rest [string map -nocase $data($token,strings) $rest]
	    Callback $token record [Tidy $type] [string trim $key] \
		    [ParseBlock $rest]
	} else {
	    ## FUTURE: Use a logger.
	    puts stderr "Skipping: $block"
	}
    }
}

proc ::bibtex::ParseBlock {block} {
    set ret   [list]
    set index 0
    while {
	[regexp -start $index -indices -- \
		{(\S+)[^=]*=(.*)} $block -> key rest]
    } {
	foreach {ks ke} $key break
	set k [Tidy [string range $block $ks $ke]]
	foreach {rs re} $rest break
	foreach {v index} \
		[ParseBibString $rs [string range $block $rs $re]] \
		break
	lappend ret $k $v
    }
    return $ret
}

proc ::bibtex::ParseBibString {index str} {
    set count 0
    set retstr ""
    set escape 0
    set string 0
    foreach char [split $str ""] {
	incr index
	if {$escape} {
	    set escape 0
	} else {
	    if {$char eq "\{"} {
		incr count
		continue
	    } elseif {$char eq "\}"} {
		incr count -1
		if {$count < 0} {incr index -1; break}
		continue
	    } elseif {$char eq ","} {
		if {$count == 0} break
	    } elseif {$char eq "\\"} {
		set escape 1
		continue
	    } elseif {$char eq "\""} {
		# Managing the count ensures that comma inside of a
		# string is not considered as the end of the field.
		if {!$string} {
		    incr count
		    set string 1
		} else {
		    incr count -1
		    set string 0
		}
		continue
	    }
	    # else: Nothing
	}
	append retstr $char
    }
    regsub -all {\s+} $retstr { } retstr
    return [list [string trim $retstr] $index]
}


# ### ### ### ######### ######### #########
## Internal. Package configuration and state.

namespace eval bibtex {
    # Counter for the generation of parser tokens.
    variable id 0

    # State of all parsers. Keys for each parser are prefixed with the
    # parser token.
    variable  data
    array set data {}

    # Keys and their meaning (listed without token prefix)
    ##
    # buffer
    # eof
    # channel    <-\/- Difference ?
    # strings      |
    # -async       |
    # -blocksize   |
    # -channel   <-/
    # -recordcommand   -- callback for each record
    # -preamblecommand -- callback for @preamble blocks
    # -stringcommand   -- callback for @string macros
    # -commentcommand  -- callback for @comment blocks
    # -progresscommand -- callback to indicate progress of parse
    ##
}

# ### ### ### ######### ######### #########
## Ready to go
package provide bibtex 0.5
# EOF
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<


































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































Deleted scriptlibs/tcllib1.12/bibtex/pkgIndex.tcl.

1
2
if {![package vsatisfies [package provide Tcl] 8.4]} {return}
package ifneeded bibtex 0.5 [list source [file join $dir bibtex.tcl]]
<
<




Deleted scriptlibs/tcllib1.12/blowfish/blowfish.tcl.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
# blowfish.tcl - 
#
#   Pure-Tcl implementation of the Blowfish algorithm.
#
#   See http://www.schneier.com/blowfish.html for information about the
#   Blowfish algorithm.
#
#   The implementation is derived from Paul Kocher's implementation,
#   available at http://www.schneier.com/blowfish-download.html
#
# Copyright (C) 2004 Frank Pilhofer
# Copyright (C) 2004 Pat Thoyts <patthoyts@users.sourceforge.net>
#
# -------------------------------------------------------------------------
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# -------------------------------------------------------------------------
#

package require Tcl 8.2

namespace eval blowfish {
    variable version 1.0.4
    variable rcsid {$Id: blowfish.tcl,v 1.10 2007/09/17 14:19:07 patthoyts Exp $}
    variable uid ; if {![info exists uid]} { set uid 0 }
    variable accel
    array set accel {trf 0}

    namespace export blowfish

    variable ORIG_P {
        0x243F6A88 0x85A308D3 0x13198A2E 0x03707344
        0xA4093822 0x299F31D0 0x082EFA98 0xEC4E6C89
        0x452821E6 0x38D01377 0xBE5466CF 0x34E90C6C
        0xC0AC29B7 0xC97C50DD 0x3F84D5B5 0xB5470917
        0x9216D5D9 0x8979FB1B
    }

    variable ORIG_S {
        0xD1310BA6 0x98DFB5AC 0x2FFD72DB 0xD01ADFB7
        0xB8E1AFED 0x6A267E96 0xBA7C9045 0xF12C7F99
        0x24A19947 0xB3916CF7 0x0801F2E2 0x858EFC16
        0x636920D8 0x71574E69 0xA458FEA3 0xF4933D7E
        0x0D95748F 0x728EB658 0x718BCD58 0x82154AEE
        0x7B54A41D 0xC25A59B5 0x9C30D539 0x2AF26013
        0xC5D1B023 0x286085F0 0xCA417918 0xB8DB38EF
        0x8E79DCB0 0x603A180E 0x6C9E0E8B 0xB01E8A3E
        0xD71577C1 0xBD314B27 0x78AF2FDA 0x55605C60
        0xE65525F3 0xAA55AB94 0x57489862 0x63E81440
        0x55CA396A 0x2AAB10B6 0xB4CC5C34 0x1141E8CE
        0xA15486AF 0x7C72E993 0xB3EE1411 0x636FBC2A
        0x2BA9C55D 0x741831F6 0xCE5C3E16 0x9B87931E
        0xAFD6BA33 0x6C24CF5C 0x7A325381 0x28958677
        0x3B8F4898 0x6B4BB9AF 0xC4BFE81B 0x66282193
        0x61D809CC 0xFB21A991 0x487CAC60 0x5DEC8032
        0xEF845D5D 0xE98575B1 0xDC262302 0xEB651B88
        0x23893E81 0xD396ACC5 0x0F6D6FF3 0x83F44239
        0x2E0B4482 0xA4842004 0x69C8F04A 0x9E1F9B5E
        0x21C66842 0xF6E96C9A 0x670C9C61 0xABD388F0
        0x6A51A0D2 0xD8542F68 0x960FA728 0xAB5133A3
        0x6EEF0B6C 0x137A3BE4 0xBA3BF050 0x7EFB2A98
        0xA1F1651D 0x39AF0176 0x66CA593E 0x82430E88
        0x8CEE8619 0x456F9FB4 0x7D84A5C3 0x3B8B5EBE
        0xE06F75D8 0x85C12073 0x401A449F 0x56C16AA6
        0x4ED3AA62 0x363F7706 0x1BFEDF72 0x429B023D
        0x37D0D724 0xD00A1248 0xDB0FEAD3 0x49F1C09B
        0x075372C9 0x80991B7B 0x25D479D8 0xF6E8DEF7
        0xE3FE501A 0xB6794C3B 0x976CE0BD 0x04C006BA
        0xC1A94FB6 0x409F60C4 0x5E5C9EC2 0x196A2463
        0x68FB6FAF 0x3E6C53B5 0x1339B2EB 0x3B52EC6F
        0x6DFC511F 0x9B30952C 0xCC814544 0xAF5EBD09
        0xBEE3D004 0xDE334AFD 0x660F2807 0x192E4BB3
        0xC0CBA857 0x45C8740F 0xD20B5F39 0xB9D3FBDB
        0x5579C0BD 0x1A60320A 0xD6A100C6 0x402C7279
        0x679F25FE 0xFB1FA3CC 0x8EA5E9F8 0xDB3222F8
        0x3C7516DF 0xFD616B15 0x2F501EC8 0xAD0552AB
        0x323DB5FA 0xFD238760 0x53317B48 0x3E00DF82
        0x9E5C57BB 0xCA6F8CA0 0x1A87562E 0xDF1769DB
        0xD542A8F6 0x287EFFC3 0xAC6732C6 0x8C4F5573
        0x695B27B0 0xBBCA58C8 0xE1FFA35D 0xB8F011A0
        0x10FA3D98 0xFD2183B8 0x4AFCB56C 0x2DD1D35B
        0x9A53E479 0xB6F84565 0xD28E49BC 0x4BFB9790
        0xE1DDF2DA 0xA4CB7E33 0x62FB1341 0xCEE4C6E8
        0xEF20CADA 0x36774C01 0xD07E9EFE 0x2BF11FB4
        0x95DBDA4D 0xAE909198 0xEAAD8E71 0x6B93D5A0
        0xD08ED1D0 0xAFC725E0 0x8E3C5B2F 0x8E7594B7
        0x8FF6E2FB 0xF2122B64 0x8888B812 0x900DF01C
        0x4FAD5EA0 0x688FC31C 0xD1CFF191 0xB3A8C1AD
        0x2F2F2218 0xBE0E1777 0xEA752DFE 0x8B021FA1
        0xE5A0CC0F 0xB56F74E8 0x18ACF3D6 0xCE89E299
        0xB4A84FE0 0xFD13E0B7 0x7CC43B81 0xD2ADA8D9
        0x165FA266 0x80957705 0x93CC7314 0x211A1477
        0xE6AD2065 0x77B5FA86 0xC75442F5 0xFB9D35CF
        0xEBCDAF0C 0x7B3E89A0 0xD6411BD3 0xAE1E7E49
        0x00250E2D 0x2071B35E 0x226800BB 0x57B8E0AF
        0x2464369B 0xF009B91E 0x5563911D 0x59DFA6AA
        0x78C14389 0xD95A537F 0x207D5BA2 0x02E5B9C5
        0x83260376 0x6295CFA9 0x11C81968 0x4E734A41
        0xB3472DCA 0x7B14A94A 0x1B510052 0x9A532915
        0xD60F573F 0xBC9BC6E4 0x2B60A476 0x81E67400
        0x08BA6FB5 0x571BE91F 0xF296EC6B 0x2A0DD915
        0xB6636521 0xE7B9F9B6 0xFF34052E 0xC5855664
        0x53B02D5D 0xA99F8FA1 0x08BA4799 0x6E85076A
        0x4B7A70E9 0xB5B32944 0xDB75092E 0xC4192623
        0xAD6EA6B0 0x49A7DF7D 0x9CEE60B8 0x8FEDB266
        0xECAA8C71 0x699A17FF 0x5664526C 0xC2B19EE1
        0x193602A5 0x75094C29 0xA0591340 0xE4183A3E
        0x3F54989A 0x5B429D65 0x6B8FE4D6 0x99F73FD6
        0xA1D29C07 0xEFE830F5 0x4D2D38E6 0xF0255DC1
        0x4CDD2086 0x8470EB26 0x6382E9C6 0x021ECC5E
        0x09686B3F 0x3EBAEFC9 0x3C971814 0x6B6A70A1
        0x687F3584 0x52A0E286 0xB79C5305 0xAA500737
        0x3E07841C 0x7FDEAE5C 0x8E7D44EC 0x5716F2B8
        0xB03ADA37 0xF0500C0D 0xF01C1F04 0x0200B3FF
        0xAE0CF51A 0x3CB574B2 0x25837A58 0xDC0921BD
        0xD19113F9 0x7CA92FF6 0x94324773 0x22F54701
        0x3AE5E581 0x37C2DADC 0xC8B57634 0x9AF3DDA7
        0xA9446146 0x0FD0030E 0xECC8C73E 0xA4751E41
        0xE238CD99 0x3BEA0E2F 0x3280BBA1 0x183EB331
        0x4E548B38 0x4F6DB908 0x6F420D03 0xF60A04BF
        0x2CB81290 0x24977C79 0x5679B072 0xBCAF89AF
        0xDE9A771F 0xD9930810 0xB38BAE12 0xDCCF3F2E
        0x5512721F 0x2E6B7124 0x501ADDE6 0x9F84CD87
        0x7A584718 0x7408DA17 0xBC9F9ABC 0xE94B7D8C
        0xEC7AEC3A 0xDB851DFA 0x63094366 0xC464C3D2
        0xEF1C1847 0x3215D908 0xDD433B37 0x24C2BA16
        0x12A14D43 0x2A65C451 0x50940002 0x133AE4DD
        0x71DFF89E 0x10314E55 0x81AC77D6 0x5F11199B
        0x043556F1 0xD7A3C76B 0x3C11183B 0x5924A509
        0xF28FE6ED 0x97F1FBFA 0x9EBABF2C 0x1E153C6E
        0x86E34570 0xEAE96FB1 0x860E5E0A 0x5A3E2AB3
        0x771FE71C 0x4E3D06FA 0x2965DCB9 0x99E71D0F
        0x803E89D6 0x5266C825 0x2E4CC978 0x9C10B36A
        0xC6150EBA 0x94E2EA78 0xA5FC3C53 0x1E0A2DF4
        0xF2F74EA7 0x361D2B3D 0x1939260F 0x19C27960
        0x5223A708 0xF71312B6 0xEBADFE6E 0xEAC31F66
        0xE3BC4595 0xA67BC883 0xB17F37D1 0x018CFF28
        0xC332DDEF 0xBE6C5AA5 0x65582185 0x68AB9802
        0xEECEA50F 0xDB2F953B 0x2AEF7DAD 0x5B6E2F84
        0x1521B628 0x29076170 0xECDD4775 0x619F1510
        0x13CCA830 0xEB61BD96 0x0334FE1E 0xAA0363CF
        0xB5735C90 0x4C70A239 0xD59E9E0B 0xCBAADE14
        0xEECC86BC 0x60622CA7 0x9CAB5CAB 0xB2F3846E
        0x648B1EAF 0x19BDF0CA 0xA02369B9 0x655ABB50
        0x40685A32 0x3C2AB4B3 0x319EE9D5 0xC021B8F7
        0x9B540B19 0x875FA099 0x95F7997E 0x623D7DA8
        0xF837889A 0x97E32D77 0x11ED935F 0x16681281
        0x0E358829 0xC7E61FD6 0x96DEDFA1 0x7858BA99
        0x57F584A5 0x1B227263 0x9B83C3FF 0x1AC24696
        0xCDB30AEB 0x532E3054 0x8FD948E4 0x6DBC3128
        0x58EBF2EF 0x34C6FFEA 0xFE28ED61 0xEE7C3C73
        0x5D4A14D9 0xE864B7E3 0x42105D14 0x203E13E0
        0x45EEE2B6 0xA3AAABEA 0xDB6C4F15 0xFACB4FD0
        0xC742F442 0xEF6ABBB5 0x654F3B1D 0x41CD2105
        0xD81E799E 0x86854DC7 0xE44B476A 0x3D816250
        0xCF62A1F2 0x5B8D2646 0xFC8883A0 0xC1C7B6A3
        0x7F1524C3 0x69CB7492 0x47848A0B 0x5692B285
        0x095BBF00 0xAD19489D 0x1462B174 0x23820E00
        0x58428D2A 0x0C55F5EA 0x1DADF43E 0x233F7061
        0x3372F092 0x8D937E41 0xD65FECF1 0x6C223BDB
        0x7CDE3759 0xCBEE7460 0x4085F2A7 0xCE77326E
        0xA6078084 0x19F8509E 0xE8EFD855 0x61D99735
        0xA969A7AA 0xC50C06C2 0x5A04ABFC 0x800BCADC
        0x9E447A2E 0xC3453484 0xFDD56705 0x0E1E9EC9
        0xDB73DBD3 0x105588CD 0x675FDA79 0xE3674340
        0xC5C43465 0x713E38D8 0x3D28F89E 0xF16DFF20
        0x153E21E7 0x8FB03D4A 0xE6E39F2B 0xDB83ADF7
        0xE93D5A68 0x948140F7 0xF64C261C 0x94692934
        0x411520F7 0x7602D4F7 0xBCF46B2E 0xD4A20068
        0xD4082471 0x3320F46A 0x43B7D4B7 0x500061AF
        0x1E39F62E 0x97244546 0x14214F74 0xBF8B8840
        0x4D95FC1D 0x96B591AF 0x70F4DDD3 0x66A02F45
        0xBFBC09EC 0x03BD9785 0x7FAC6DD0 0x31CB8504
        0x96EB27B3 0x55FD3941 0xDA2547E6 0xABCA0A9A
        0x28507825 0x530429F4 0x0A2C86DA 0xE9B66DFB
        0x68DC1462 0xD7486900 0x680EC0A4 0x27A18DEE
        0x4F3FFEA2 0xE887AD8C 0xB58CE006 0x7AF4D6B6
        0xAACE1E7C 0xD3375FEC 0xCE78A399 0x406B2A42
        0x20FE9E35 0xD9F385B9 0xEE39D7AB 0x3B124E8B
        0x1DC9FAF7 0x4B6D1856 0x26A36631 0xEAE397B2
        0x3A6EFA74 0xDD5B4332 0x6841E7F7 0xCA7820FB
        0xFB0AF54E 0xD8FEB397 0x454056AC 0xBA489527
        0x55533A3A 0x20838D87 0xFE6BA9B7 0xD096954B
        0x55A867BC 0xA1159A58 0xCCA92963 0x99E1DB33
        0xA62A4A56 0x3F3125F9 0x5EF47E1C 0x9029317C
        0xFDF8E802 0x04272F70 0x80BB155C 0x05282CE3
        0x95C11548 0xE4C66D22 0x48C1133F 0xC70F86DC
        0x07F9C9EE 0x41041F0F 0x404779A4 0x5D886E17
        0x325F51EB 0xD59BC0D1 0xF2BCC18F 0x41113564
        0x257B7834 0x602A9C60 0xDFF8E8A3 0x1F636C1B
        0x0E12B4C2 0x02E1329E 0xAF664FD1 0xCAD18115
        0x6B2395E0 0x333E92E1 0x3B240B62 0xEEBEB922
        0x85B2A20E 0xE6BA0D99 0xDE720C8C 0x2DA2F728
        0xD0127845 0x95B794FD 0x647D0862 0xE7CCF5F0
        0x5449A36F 0x877D48FA 0xC39DFD27 0xF33E8D1E
        0x0A476341 0x992EFF74 0x3A6F6EAB 0xF4F8FD37
        0xA812DC60 0xA1EBDDF8 0x991BE14C 0xDB6E6B0D
        0xC67B5510 0x6D672C37 0x2765D43B 0xDCD0E804
        0xF1290DC7 0xCC00FFA3 0xB5390F92 0x690FED0B
        0x667B9FFB 0xCEDB7D9C 0xA091CF0B 0xD9155EA3
        0xBB132F88 0x515BAD24 0x7B9479BF 0x763BD6EB
        0x37392EB3 0xCC115979 0x8026E297 0xF42E312D
        0x6842ADA7 0xC66A2B3B 0x12754CCC 0x782EF11C
        0x6A124237 0xB79251E7 0x06A1BBE6 0x4BFB6350
        0x1A6B1018 0x11CAEDFA 0x3D25BDD8 0xE2E1C3C9
        0x44421659 0x0A121386 0xD90CEC6E 0xD5ABEA2A
        0x64AF674E 0xDA86A85F 0xBEBFE988 0x64E4C3FE
        0x9DBC8057 0xF0F7C086 0x60787BF8 0x6003604D
        0xD1FD8346 0xF6381FB0 0x7745AE04 0xD736FCCC
        0x83426B33 0xF01EAB71 0xB0804187 0x3C005E5F
        0x77A057BE 0xBDE8AE24 0x55464299 0xBF582E61
        0x4E58F48F 0xF2DDFDA2 0xF474EF38 0x8789BDC2
        0x5366F9C3 0xC8B38E74 0xB475F255 0x46FCD9B9
        0x7AEB2661 0x8B1DDF84 0x846A0E79 0x915F95E2
        0x466E598E 0x20B45770 0x8CD55591 0xC902DE4C
        0xB90BACE1 0xBB8205D0 0x11A86248 0x7574A99E
        0xB77F19B6 0xE0A9DC09 0x662D09A1 0xC4324633
        0xE85A1F02 0x09F0BE8C 0x4A99A025 0x1D6EFE10
        0x1AB93D1D 0x0BA5A4DF 0xA186F20F 0x2868F169
        0xDCB7DA83 0x573906FE 0xA1E2CE9B 0x4FCD7F52
        0x50115E01 0xA70683FA 0xA002B5C4 0x0DE6D027
        0x9AF88C27 0x773F8641 0xC3604C06 0x61A806B5
        0xF0177A28 0xC0F586E0 0x006058AA 0x30DC7D62
        0x11E69ED7 0x2338EA63 0x53C2DD94 0xC2C21634
        0xBBCBEE56 0x90BCB6DE 0xEBFC7DA1 0xCE591D76
        0x6F05E409 0x4B7C0188 0x39720A3D 0x7C927C24
        0x86E3725F 0x724D9DB9 0x1AC15BB4 0xD39EB8FC
        0xED545578 0x08FCA5B5 0xD83D7CD3 0x4DAD0FC4
        0x1E50EF5E 0xB161E6F8 0xA28514D9 0x6C51133C
        0x6FD5C7E7 0x56E14EC4 0x362ABFCE 0xDDC6C837
        0xD79A3234 0x92638212 0x670EFA8E 0x406000E0
        0x3A39CE37 0xD3FAF5CF 0xABC27737 0x5AC52D1B
        0x5CB0679E 0x4FA33742 0xD3822740 0x99BC9BBE
        0xD5118E9D 0xBF0F7315 0xD62D1C7E 0xC700C47B
        0xB78C1B6B 0x21A19045 0xB26EB1BE 0x6A366EB4
        0x5748AB2F 0xBC946E79 0xC6A376D2 0x6549C2C8
        0x530FF8EE 0x468DDE7D 0xD5730A1D 0x4CD04DC6
        0x2939BBDB 0xA9BA4650 0xAC9526E8 0xBE5EE304
        0xA1FAD5F0 0x6A2D519A 0x63EF8CE2 0x9A86EE22
        0xC089C2B8 0x43242EF6 0xA51E03AA 0x9CF2D0A4
        0x83C061BA 0x9BE96A4D 0x8FE51550 0xBA645BD6
        0x2826A2F9 0xA73A3AE1 0x4BA99586 0xEF5562E9
        0xC72FEFD3 0xF752F7DA 0x3F046F69 0x77FA0A59
        0x80E4A915 0x87B08601 0x9B09E6AD 0x3B3EE593
        0xE990FD5A 0x9E34D797 0x2CF0B7D9 0x022B8B51
        0x96D5AC3A 0x017DA67D 0xD1CF3ED6 0x7C7D2D28
        0x1F9F25CF 0xADF2B89B 0x5AD6B472 0x5A88F54C
        0xE029AC71 0xE019A5E6 0x47B0ACFD 0xED93FA9B
        0xE8D3C48D 0x283B57CC 0xF8D56629 0x79132E28
        0x785F0191 0xED756055 0xF7960E44 0xE3D35E8C
        0x15056DD4 0x88F46DBA 0x03A16125 0x0564F0BD
        0xC3EB9E15 0x3C9057A2 0x97271AEC 0xA93A072A
        0x1B3F6D9B 0x1E6321F5 0xF59C66FB 0x26DCF319
        0x7533D928 0xB155FDF5 0x03563482 0x8ABA3CBB
        0x28517711 0xC20AD9F8 0xABCC5167 0xCCAD925F
        0x4DE81751 0x3830DC8E 0x379D5862 0x9320F991
        0xEA7A90C2 0xFB3E7BCE 0x5121CE64 0x774FBE32
        0xA8B6E37E 0xC3293D46 0x48DE5369 0x6413E680
        0xA2AE0810 0xDD6DB224 0x69852DFD 0x09072166
        0xB39A460A 0x6445C0DD 0x586CDECF 0x1C20C8AE
        0x5BBEF7DD 0x1B588D40 0xCCD2017F 0x6BB4E3BB
        0xDDA26A7E 0x3A59FF45 0x3E350A44 0xBCB4CDD5
        0x72EACEA8 0xFA6484BB 0x8D6612AE 0xBF3C6F47
        0xD29BE463 0x542F5D9E 0xAEC2771B 0xF64E6370
        0x740E0D8D 0xE75B1357 0xF8721671 0xAF537D5D
        0x4040CB08 0x4EB4E2CC 0x34D2466A 0x0115AF84
        0xE1B00428 0x95983A1D 0x06B89FB4 0xCE6EA048
        0x6F3F3B82 0x3520AB82 0x011A1D4B 0x277227F8
        0x611560B1 0xE7933FDC 0xBB3A792B 0x344525BD
        0xA08839E1 0x51CE794B 0x2F32C9B7 0xA01FBAC9
        0xE01CC87E 0xBCC7D1F6 0xCF0111C3 0xA1E8AAC7
        0x1A908749 0xD44FBD9A 0xD0DADECB 0xD50ADA38
        0x0339C32A 0xC6913667 0x8DF9317C 0xE0B12B4F
        0xF79E59B7 0x43F5BB3A 0xF2D519FF 0x27D9459C
        0xBF97222C 0x15E6FC2A 0x0F91FC71 0x9B941525
        0xFAE59361 0xCEB69CEB 0xC2A86459 0x12BAA8D1
        0xB6C1075E 0xE3056A0C 0x10D25065 0xCB03A442
        0xE0EC6E0E 0x1698DB3B 0x4C98A0BE 0x3278E964
        0x9F1F9532 0xE0D392DF 0xD3A0342B 0x8971F21E
        0x1B0A7441 0x4BA3348C 0xC5BE7120 0xC37632D8
        0xDF359F8D 0x9B992F2E 0xE60B6F47 0x0FE3F11D
        0xE54CDA54 0x1EDAD891 0xCE6279CF 0xCD3E7E6F
        0x1618B166 0xFD2C1D05 0x848FD2C5 0xF6FB2299
        0xF523F357 0xA6327623 0x93A83531 0x56CCCD02
        0xACF08162 0x5A75EBB5 0x6E163697 0x88D273CC
        0xDE966292 0x81B949D0 0x4C50901B 0x71C65614
        0xE6C6C7BD 0x327A140A 0x45E1D006 0xC3F27B9A
        0xC9AA53FD 0x62A80F00 0xBB25BFE2 0x35BDD2F6
        0x71126905 0xB2040222 0xB6CBCF7C 0xCD769C2B
        0x53113EC0 0x1640E3D3 0x38ABBD60 0x2547ADF0
        0xBA38209C 0xF746CE76 0x77AFA1C5 0x20756060
        0x85CBFE4E 0x8AE88DD8 0x7AAAF9B0 0x4CF9AA7E
        0x1948C25C 0x02FB8A8C 0x01C36AE4 0xD6EBE1F9
        0x90D4F869 0xA65CDEA0 0x3F09252D 0xC208E69F
        0xB74E6132 0xCE77E25B 0x578FDFE3 0x3AC372E6
    }
}

proc ::blowfish::intEncrypt {P S xl xr} {
    for {set i 0} {$i < 16} {incr i} {
        set xl [expr {$xl ^ [lindex $P $i]}]

        set S0a [lindex $S [expr { ($xl >> 24) & 0xff}]]
        set S1b [lindex $S [expr {(($xl >> 16) & 0xff) + 256}]]
        set S2c [lindex $S [expr {(($xl >>  8) & 0xff) + 512}]]
        set S3d [lindex $S [expr { ($xl        & 0xff) + 768}]]
        set xr [expr {(((($S0a + $S1b) ^ $S2c) + $S3d) & 0xffffffff) ^ $xr}]

        set temp $xl ; set xl $xr ; set xr $temp
    }

    set temp $xl ; set xl $xr ; set xr $temp
    return [list [expr {$xl ^ [lindex $P 17]}] [expr {$xr ^ [lindex $P 16]}]]
}

proc ::blowfish::intDecrypt {P S xl xr} {
    for {set i 17} {$i > 1} {incr i -1} {
        set xl [expr {$xl ^ [lindex $P $i]}]

        set S0a [lindex $S [expr { ($xl >> 24) & 0xff}]]
        set S1b [lindex $S [expr {(($xl >> 16) & 0xff) + 256}]]
        set S2c [lindex $S [expr {(($xl >>  8) & 0xff) + 512}]]
        set S3d [lindex $S [expr { ($xl        & 0xff) + 768}]]
        set xr [expr {(((($S0a + $S1b) ^ $S2c) + $S3d) & 0xffffffff) ^ $xr}]

        set temp $xl ; set xl $xr ; set xr $temp
    }
    
    set temp $xl ; set xl $xr ; set xr $temp
    return [list [expr {$xl ^ [lindex $P 0]}] [expr {$xr ^ [lindex $P 1]}]]
}

proc ::blowfish::Init {mode key iv} {
    variable ORIG_S
    variable ORIG_P
    variable uid

    set S $ORIG_S
    set P [list]
    
    set kl [string length $key]
    binary scan $key c* kc
    
    set j 0
    for {set i 0} {$i < 18} {incr i} {
        set data 0
        for {set k 0} {$k < 4} {incr k} {
            set data [expr {(($data << 8) | ([lindex $kc $j] & 0xff)) & 0xffffffff}]
            if {[incr j] >= $kl} {
                set j 0
            }
        }
        set OPi [lindex $ORIG_P $i]
        lappend P [expr {$OPi ^ $data}]
    }
    
    set datal 0
    set datar 0
    
    for {set i 0} {$i < 18} {incr i} {
        set ed [intEncrypt $P $S $datal $datar]
        set datal [lindex $ed 0]
        set datar [lindex $ed 1]
        set P [lreplace $P $i [incr i] $datal $datar]
    }
    
    for {set i 0} {$i < 4} {incr i} {
        for {set j 0} {$j < 256} {incr j 2} {
            set ed [intEncrypt $P $S $datal $datar]
            set datal [lindex $ed 0]
            set datar [lindex $ed 1]
            set t [expr {$i * 256 + $j}]
            set S [lreplace $S $t [incr t] $datal $datar]
        }
    }

    set token [namespace current]::[incr uid]
    variable $token
    upvar #0 $token state
    array set state [list P $P S $S M $mode I $iv]
    return $token
}

proc ::blowfish::Reset {token iv} {
    upvar #0 $token state
    set state(I) $iv
    return
}

proc ::blowfish::Final {token} {
    # PRAGMA: nocheck
    variable $token
    unset $token
}

proc ::blowfish::EncryptBlock {token block} {
    upvar #0 $token state
    if {[binary scan $block II xl xr] != 2} {
        error "block must be 8 bytes"
    }
    set xl [expr {$xl & 0xffffffff}]
    set xr [expr {$xr & 0xffffffff}]
    set d  [intEncrypt $state(P) $state(S) $xl $xr]
    return [binary format I2 $d]
}

proc ::blowfish::Encrypt {Key data} {
    upvar #0 $Key state
    set P $state(P)
    set S $state(S)
    set cbc_mode [string equal "cbc" $state(M)]

    if {[binary scan $state(I) II s0 s1] != 2} {
        return -code error "invalid initialization vector: must be 8 bytes"
    }

    set len [string length $data]
    if {($len % 8) != 0} {
        return -code error "invalid block size: blocks must be 8 bytes"
    }

    set s0 [expr {$s0 & 0xffffffff}]
    set s1 [expr {$s1 & 0xffffffff}]
    
    set result ""
    for {set i 0} {$i < $len} {incr i 8} {
        if {[binary scan $data @[set i]II xl xr] != 2} {
            return -code error "oops"
        }
        if {$cbc_mode} {
            set xl [expr {($xl & 0xffffffff) ^ $s0}]
            set xr [expr {($xr & 0xffffffff) ^ $s1}]
        }
        set d  [intEncrypt $P $S $xl $xr]
        if {$cbc_mode} {
            set s0 [lindex $d 0]
            set s1 [lindex $d 1]
        }
        append result [binary format I2 $d]
    }
    if {$cbc_mode} {
        set state(I) [binary format II $s0 $s1]
    }
    return $result
}

proc ::blowfish::DecryptBlock {Key block} {
    upvar #0 $Key state
    if {[binary scan $block II xl xr] != 2} {
        return -code error "invalid block size: block must be 8 bytes"
    }
    set xl [expr {$xl & 0xffffffff}]
    set xr [expr {$xr & 0xffffffff}]
    set d  [intDecrypt $state(P) $state(S) $xl $xr]
    return [binary format I2 $d]
}

proc ::blowfish::Decrypt {token data} {
    upvar #0 $token state
    set P $state(P)
    set S $state(S)
    set cbc_mode [string equal "cbc" $state(M)]

    if {[binary scan $state(I) II s0 s1] != 2} {
        return -code error "initialization vector must be 8 bytes"
    }

    set len [string length $data]
    if {($len % 8) != 0} {
        return -code error "block size invalid"
    }

    set s0 [expr {$s0 & 0xffffffff}]
    set s1 [expr {$s1 & 0xffffffff}]

    set result ""
    for {set i 0} {$i < $len} {incr i 8} {
        if {[binary scan $data @[set i]II xl xr] != 2} {
            error "oops"
        }
        set xl [expr {$xl & 0xffffffff}]
        set xr [expr {$xr & 0xffffffff}]
        set d  [intDecrypt $P $S $xl $xr]
        if {$cbc_mode} {
            set d0 [lindex $d 0]
            set d1 [lindex $d 1]
            set c0 [expr {$d0 ^ $s0}]
            set c1 [expr {$d1 ^ $s1}]
            set s0 $xl
            set s1 $xr
            append result [binary format II $c0 $c1]
        } else {
            append result [binary format I2 $d]
        }
    }
    if {$cbc_mode} {
        set state(I) [binary format II $s0 $s1]
    }
    return $result
}


# -------------------------------------------------------------------------
# Fileevent handler for chunked file reading.
#
proc ::blowfish::Chunk {Key in {out {}} {chunksize 4096} {pad \0}} {
    upvar #0 $Key state
    
    if {[eof $in]} {
        fileevent $in readable {}
        set state(reading) 0
    }

    set data [read $in $chunksize]
    # FIX ME: we should ony pad after eof
    if {[string length $pad] > 0} {
        set data [Pad $data 8]
    }
    
    if {$out == {}} {
        append state(output) [$state(cmd) $Key $data]
    } else {
        puts -nonewline $out [$state(cmd) $Key $data]
    }
}

# -------------------------------------------------------------------------

# LoadAccelerator --
#
#	This package can make use of a number of compiled extensions to
#	accelerate the digest computation. This procedure manages the
#	use of these extensions within the package. During normal usage
#	this should not be called, but the test package manipulates the
#	list of enabled accelerators.
#
proc ::blowfish::LoadAccelerator {name} {
    variable accel
    set r 0
    switch -exact -- $name {
        trf {
            if {![catch {package require Trfcrypt}]} {
                set block [string repeat \0 8]
                set r [expr {![catch {::blowfish -dir enc -mode ecb -key $block $block} msg]}]
            }
        }
        default {
            return -code error "invalid accelerator package:\
                must be one of [join [array names accel] {, }]"
        }
    }
    set accel($name) $r
}

# -------------------------------------------------------------------------

proc ::blowfish::Hex {data} {
    binary scan $data H* r
    return $r
}

proc ::blowfish::SetOneOf {lst item} {                
    set ndx [lsearch -glob $lst "${item}*"]
    if {$ndx == -1} {
        set err [join $lst ", "]
        return -code error "invalid mode \"$item\": must be one of $err"
    }
    return [lindex $lst $ndx]
}

proc ::blowfish::CheckSize {what size thing} {
    if {[string length $thing] != $size} {
        return -code error "invalid value for $what: must be $size bytes long"
    }
    return $thing
}

proc ::blowfish::CheckPad {char} {
    if {[string length $char] > 1} {
        return -code error "invalid value: should be a char or empty string"
    }
    return $char
}

proc ::blowfish::Pad {data blocksize {fill \0}} {
    set len [string length $data]
    if {$len == 0} {
        set data [string repeat $fill $blocksize]
    } elseif {($len % $blocksize) != 0} {
        set pad [expr {$blocksize - ($len % $blocksize)}]
        append data [string repeat $fill $pad]
    }
    return $data
}

# Description:
#  Pop the nth element off a list. Used in options processing.
#
proc ::blowfish::Pop {varname {nth 0}} {
    upvar $varname args
    set r [lindex $args $nth]
    set args [lreplace $args $nth $nth]
    return $r
}

proc ::blowfish::blowfish {args} {
    variable accel
    array set opts {-dir encrypt -mode cbc -key {} -in {} -out {} -hex 0 -pad \0}
    set opts(-chunksize) 4096
    set opts(-iv) [string repeat \0 8]
    set modes {ecb cbc}
    set dirs  {encrypt decrypt}
    while {[string match -* [set option [lindex $args 0]]]} {
        switch -exact -- $option {
            -mode       { set opts(-mode) [SetOneOf $modes [Pop args 1]] }
            -dir        { set opts(-dir) [SetOneOf $dirs [Pop args 1]] }
            -iv         { set opts(-iv)  [CheckSize -iv 8 [Pop args 1]] }
            -key        { set opts(-key) [Pop args 1] }
            -in         { set opts(-in) [Pop args 1] }
            -out        { set opts(-out) [Pop args 1] }
            -chunksize  { set opts(-chunksize) [Pop args 1] }
            -hex        { set opts(-hex) 1 }
            -pad        { set opts(-pad) [CheckPad [Pop args 1]] }
            --          { Pop args; break }
            default {
                if {[string length $opts(-in)] == 0 && [llength $args] == 1} break
                set err [join [lsort [array names opts]] ", "]
                return -code error "bad option \"$option\":\
                    must be one of $err"
            }
        }
        Pop args
    }
    
    if {$opts(-key) == {}} {
        return -code error "no key provided: the -key option is required"
    }
    
    set r {}
    if {$opts(-in) == {}} {

        if {[llength $args] != 1} {
            return -code error "wrong \# args:\
                should be \"blowfish ?options...? -key keydata plaintext\""
        }

        set data [lindex $args 0]
        if {[string length $opts(-pad)] > 0} {
            set data [Pad [lindex $args 0] 8 $opts(-pad)]
        }
        if {$accel(trf)} {
            set r [::blowfish -dir $opts(-dir) -mode $opts(-mode) \
                       -key $opts(-key) -iv $opts(-iv) -- $data]
        } else {
            set Key [Init $opts(-mode) $opts(-key) $opts(-iv)]
            if {[string equal $opts(-dir) "encrypt"]} {
                set r [Encrypt $Key $data]
            } else {
                set r [Decrypt $Key $data]
            }
            Final $Key
        }

        if {$opts(-out) != {}} {
            puts -nonewline $opts(-out) $r
            set r {}
        }
        
    } else {

        if {[llength $args] != 0} {
            return -code error "wrong \# args:\
                should be \"blowfish ?options...? -key keydata -in channel\""
        }
        
        set Key [Init $opts(-mode) $opts(-key) $opts(-iv)]
        upvar $Key state
        set state(reading) 1
        if {[string equal $opts(-dir) "encrypt"]} {
            set state(cmd) Encrypt
        } else {
            set state(cmd) Decrypt
        }
        set state(output) ""
        fileevent $opts(-in) readable \
            [list [namespace origin Chunk] \
                 $Key $opts(-in) $opts(-out) $opts(-chunksize) $opts(-pad)]
        if {[info commands ::tkwait] != {}} {
            tkwait variable [subst $Key](reading)
        } else {
            vwait [subst $Key](reading)
        }
        if {$opts(-out) == {}} {
            set r $state(output)
        }
        Final $Key

    }

    if {$opts(-hex)} {
        set r [Hex $r]
    }
    return $r
}

# -------------------------------------------------------------------------

# Try and load a compiled extension to help.
namespace eval ::blowfish {
    variable e; foreach e {trf} { if {[LoadAccelerator $e]} { break } }
}

package provide blowfish $::blowfish::version

# -------------------------------------------------------------------------
#
# Local Variables:
# mode: tcl
# indent-tabs-mode: nil
# End:
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































Deleted scriptlibs/tcllib1.12/blowfish/pkgIndex.tcl.

1
2
3
4
5
if {![package vsatisfies [package provide Tcl] 8.2]} {
    # PRAGMA: returnok
    return
}
package ifneeded blowfish 1.0.4 [list source [file join $dir blowfish.tcl]]
<
<
<
<
<










Deleted scriptlibs/tcllib1.12/cache/async.tcl.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
## -*- tcl -*-
# ### ### ### ######### ######### #########

# Copyright (c) 2008 Andreas Kupries <andreas_kupries@users.sourceforge.net>

# Aynchronous in-memory cache. Queries of the cache generate
# asynchronous requests for data for unknown parts, with asynchronous
# result return. Data found in the cache may return fully asynchronous
# as well, or semi-synchronous. The latter meaning that the regular
# callbacks are used, but invoked directly, and not decoupled through
# events. The cache can be pre-filled synchronously.

# ### ### ### ######### ######### #########
## Requisites

package require Tcl 8.4 ; #
package require snit    ; # 

# ### ### ### ######### ######### #########
##

snit::type cache::async {

    # ### ### ### ######### ######### #########
    ## Unknown methods and options are forwared to the object actually
    ## providing the cached data, making the cache a proper facade for
    ## it.

    delegate method * to myprovider
    delegate option * to myprovider

    # ### ### ### ######### ######### #########
    ## API 

    option -full-async-results -default 1 -type snit::boolean

    constructor {provider args} {
	set myprovider $provider
	$self configurelist $args
	return
    }

    method get {key donecmd} {
	# Register request
	lappend mywaiting($key) $donecmd

	# Check if the request can be satisfied from the cache. If yes
	# then that is done.

	if {[info exists mymiss($key)]} {
	    $self NotifyUnset 1 $key
	    return
	} elseif {[info exists myhit($key)]} {
	    $self NotifySet 1 $key
	    return
	}

	# We have to ask our provider if there is data or
	# not. however, if a request for this key is already in flight
	# then we have to do nothing more. Our registration at the
	# beginning ensures that we will get notified when the
	# requested information comes back.

	if {[llength $mywaiting($key)] > 1} return

	# This is the first query for this key, ask the provider.

	after idle [linsert $myprovider end get $key $self]
	return
    }

    method clear {args} {
	# Note: This method cannot interfere with async queries caused
	# by 'get' invokations.  If the data is present, and now
	# removed, all 'get' invokations before this call were
	# satisfied from the cache and only invokations coming after
	# it can trigger async queries of the provider. If the data is
	# not present the state will not change, and queries in flight
	# simply refill the cache as they would do anyway without the
	# 'clear'.

	if {![llength $args]} {
	    array unset myhit  *
	    array unset mymiss *
	} elseif {[llength $arg] == 1} {
	    set key [lindex $args 0]
	    unset -nocomplain  myhit($key)
	    unset -nocomplain mymiss($key)
	} else {
	    WrongArgs ?key?
	}
	return
    }

    method exists {key} {
	return [expr {[info exists myhit($key)] || [info exists mymiss($key)]}]
    }

    method set {key value} {
	# Add data to the cache, and notify all outstanding queries.
	# Nothing is done if the key is already known and has the same
	# value.

	# This is the method invoked by the provider in response to
	# queries, and also the method to use to prefill the cache
	# with data.

	if {
	    [info exists myhit($key)] &&
	    ($value eq $myhit($key))
	} return

	set                myhit($key) $value
	unset -nocomplain mymiss($key)
	$self NotifySet 0 $key
	return
    }

    method unset {key} {
	# Add hole to the cache, and notify all outstanding queries.
	# This is the method invoked by the provider in response to
	# queries, and also the method to use to prefill the cache
	# with holes.
	unset -nocomplain myhit($key)
	set              mymiss($key) .
	$self NotifyUnset 0 $key
	return
    }

    method NotifySet {found key} {
	if {![info exists mywaiting($key)] || ![llength $mywaiting($key)]} return

	set pending $mywaiting($key)
	unset mywaiting($key)

	set value $myhit($key)
	if {$found && !$options(-full-async-results)} {
	    foreach donecmd $pending {
		uplevel \#0 [linsert $donecmd end set $key $value]
	    }
	} else {
	    foreach donecmd $pending {
		after idle [linsert $donecmd end set $key $value]
	    }
	}
	return
    }

    method NotifyUnset {found key} {
	if {![info exists mywaiting($key)] || ![llength $mywaiting($key)]} return

	set pending $mywaiting($key)
	unset mywaiting($key)

	if {$found && !$options(-full-async-results)} {
	    foreach donecmd $pending {
		uplevel \#0 [linsert $donecmd end unset $key]
	    }
	} else {
	    foreach donecmd $pending {
		after idle [linsert $donecmd end unset $key]
	    }
	}
	return
    }

    proc WrongArgs {expected} {
	return -code error "wrong#args: Expected $expected"
    }

    # ### ### ### ######### ######### #########
    ## State

    variable myprovider          ; # Command prefix providing the data to cache.
    variable myhit     -array {} ; # Cache array mapping keys to values.
    variable mymiss    -array {} ; # Cache array mapping keys to holes.
    variable mywaiting -array {} ; # Map of keys pending to notifier commands.

    # ### ### ### ######### ######### #########
}

# ### ### ### ######### ######### #########
## Ready

package provide cache::async 0.3
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<


















































































































































































































































































































































































Deleted scriptlibs/tcllib1.12/cache/pkgIndex.tcl.

1
2
3
if {![package vsatisfies [package provide Tcl] 8.4]} {return}
package ifneeded cache::async 0.3 [list source [file join $dir async.tcl]]

<
<
<






Deleted scriptlibs/tcllib1.12/cmdline/cmdline.tcl.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
# cmdline.tcl --
#
#	This package provides a utility for parsing command line
#	arguments that are processed by our various applications.
#	It also includes a utility routine to determine the
#	application name for use in command line errors.
#
# Copyright (c) 1998-2000 by Ajuba Solutions.
# Copyright (c) 2001-2006 by Andreas Kupries <andreas_kupries@users.sf.net>.
# Copyright (c) 2003      by David N. Welton  <davidw@dedasys.com>
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# 
# RCS: @(#) $Id: cmdline.tcl,v 1.26 2008/07/09 18:02:59 andreas_kupries Exp $

package require Tcl 8.2
package provide cmdline 1.3.1

namespace eval ::cmdline {
    namespace export getArgv0 getopt getKnownOpt getfiles getoptions \
	    getKnownOptions usage
}

# ::cmdline::getopt --
#
#	The cmdline::getopt works in a fashion like the standard
#	C based getopt function.  Given an option string and a 
#	pointer to an array or args this command will process the
#	first argument and return info on how to proceed.
#
# Arguments:
#	argvVar		Name of the argv list that you
#			want to process.  If options are found the
#			arg list is modified and the processed arguments
#			are removed from the start of the list.
#	optstring	A list of command options that the application
#			will accept.  If the option ends in ".arg" the
#			getopt routine will use the next argument as 
#			an argument to the option.  Otherwise the option	
#			is a boolean that is set to 1 if present.
#	optVar		The variable pointed to by optVar
#			contains the option that was found (without the
#			leading '-' and without the .arg extension).
#	valVar		Upon success, the variable pointed to by valVar
#			contains the value for the specified option.
#			This value comes from the command line for .arg
#			options, otherwise the value is 1.
#			If getopt fails, the valVar is filled with an
#			error message.
#
# Results:
# 	The getopt function returns 1 if an option was found, 0 if no more
# 	options were found, and -1 if an error occurred.

proc ::cmdline::getopt {argvVar optstring optVar valVar} {
    upvar 1 $argvVar argsList
    upvar 1 $optVar option
    upvar 1 $valVar value

    set result [getKnownOpt argsList $optstring option value]

    if {$result < 0} {
        # Collapse unknown-option error into any-other-error result.
        set result -1
    }
    return $result
}

# ::cmdline::getKnownOpt --
#
#	The cmdline::getKnownOpt works in a fashion like the standard
#	C based getopt function.  Given an option string and a 
#	pointer to an array or args this command will process the
#	first argument and return info on how to proceed.
#
# Arguments:
#	argvVar		Name of the argv list that you
#			want to process.  If options are found the
#			arg list is modified and the processed arguments
#			are removed from the start of the list.  Note that
#			unknown options and the args that follow them are
#			left in this list.
#	optstring	A list of command options that the application
#			will accept.  If the option ends in ".arg" the
#			getopt routine will use the next argument as 
#			an argument to the option.  Otherwise the option	
#			is a boolean that is set to 1 if present.
#	optVar		The variable pointed to by optVar
#			contains the option that was found (without the
#			leading '-' and without the .arg extension).
#	valVar		Upon success, the variable pointed to by valVar
#			contains the value for the specified option.
#			This value comes from the command line for .arg
#			options, otherwise the value is 1.
#			If getopt fails, the valVar is filled with an
#			error message.
#
# Results:
# 	The getKnownOpt function returns 1 if an option was found,
#	0 if no more options were found, -1 if an unknown option was
#	encountered, and -2 if any other error occurred. 

proc ::cmdline::getKnownOpt {argvVar optstring optVar valVar} {
    upvar 1 $argvVar argsList
    upvar 1 $optVar  option
    upvar 1 $valVar  value

    # default settings for a normal return
    set value ""
    set option ""
    set result 0

    # check if we're past the end of the args list
    if {[llength $argsList] != 0} {

	# if we got -- or an option that doesn't begin with -, return (skipping
	# the --).  otherwise process the option arg.
	switch -glob -- [set arg [lindex $argsList 0]] {
	    "--" {
		set argsList [lrange $argsList 1 end]
	    }

	    "-*" {
		set option [string range $arg 1 end]

		if {[lsearch -exact $optstring $option] != -1} {
		    # Booleans are set to 1 when present
		    set value 1
		    set result 1
		    set argsList [lrange $argsList 1 end]
		} elseif {[lsearch -exact $optstring "$option.arg"] != -1} {
		    set result 1
		    set argsList [lrange $argsList 1 end]
		    if {[llength $argsList] != 0} {
			set value [lindex $argsList 0]
			set argsList [lrange $argsList 1 end]
		    } else {
			set value "Option \"$option\" requires an argument"
			set result -2
		    }
		} else {
		    # Unknown option.
		    set value "Illegal option \"-$option\""
		    set result -1
		}
	    }
	    default {
		# Skip ahead
	    }
	}
    }

    return $result
}

# ::cmdline::getoptions --
#
#	Process a set of command line options, filling in defaults
#	for those not specified.  This also generates an error message
#	that lists the allowed flags if an incorrect flag is specified.
#
# Arguments:
#	arglistVar	The name of the argument list, typically argv.
#			We remove all known options and their args from it.
#	optlist		A list-of-lists where each element specifies an option
#			in the form:
#				(where flag takes no argument) 
#					flag comment 
#
#				(or where flag takes an argument) 
#					flag default comment
#
#			If flag ends in ".arg" then the value is taken from the
#			command line. Otherwise it is a boolean and appears in
#			the result if present on the command line. If flag ends
#			in ".secret", it will not be displayed in the usage.
#	usage		Text to include in the usage display. Defaults to
#			"options:"
#
# Results
#	Name value pairs suitable for using with array set.

proc ::cmdline::getoptions {arglistVar optlist {usage options:}} {
    upvar 1 $arglistVar argv

    set opts [GetOptionDefaults $optlist result]

    set argc [llength $argv]
    while {[set err [getopt argv $opts opt arg]]} {
	if {$err < 0} {
            set result(?) ""
            break
	}
	set result($opt) $arg
    }
    if {[info exist result(?)] || [info exists result(help)]} {
	error [usage $optlist $usage]
    }
    return [array get result]
}

# ::cmdline::getKnownOptions --
#
#	Process a set of command line options, filling in defaults
#	for those not specified.  This ignores unknown flags, but generates
#	an error message that lists the correct usage if a known option
#	is used incorrectly.
#
# Arguments:
#	arglistVar	The name of the argument list, typically argv.  This
#			We remove all known options and their args from it.
#	optlist		A list-of-lists where each element specifies an option
#			in the form:
#				flag default comment
#			If flag ends in ".arg" then the value is taken from the
#			command line. Otherwise it is a boolean and appears in
#			the result if present on the command line. If flag ends
#			in ".secret", it will not be displayed in the usage.
#	usage		Text to include in the usage display. Defaults to
#			"options:"
#
# Results
#	Name value pairs suitable for using with array set.

proc ::cmdline::getKnownOptions {arglistVar optlist {usage options:}} {
    upvar 1 $arglistVar argv

    set opts [GetOptionDefaults $optlist result]

    # As we encounter them, keep the unknown options and their
    # arguments in this list.  Before we return from this procedure,
    # we'll prepend these args to the argList so that the application
    # doesn't lose them.

    set unknownOptions [list]

    set argc [llength $argv]
    while {[set err [getKnownOpt argv $opts opt arg]]} {
	if {$err == -1} {
            # Unknown option.

            # Skip over any non-option items that follow it.
            # For now, add them to the list of unknownOptions.
            lappend unknownOptions [lindex $argv 0]
            set argv [lrange $argv 1 end]
            while {([llength $argv] != 0) \
                    && ![string match "-*" [lindex $argv 0]]} {
                lappend unknownOptions [lindex $argv 0]
                set argv [lrange $argv 1 end]
            }
	} elseif {$err == -2} {
            set result(?) ""
            break
        } else {
            set result($opt) $arg
        }
    }

    # Before returning, prepend the any unknown args back onto the
    # argList so that the application doesn't lose them.
    set argv [concat $unknownOptions $argv]

    if {[info exist result(?)] || [info exists result(help)]} {
	error [usage $optlist $usage]
    }
    return [array get result]
}

# ::cmdline::GetOptionDefaults --
#
#	This internal procedure processes the option list (that was passed to
#	the getopt or getKnownOpt procedure).  The defaultArray gets an index
#	for each option in the option list, the value of which is the option's
#	default value.
#
# Arguments:
#	optlist		A list-of-lists where each element specifies an option
#			in the form:
#				flag default comment
#			If flag ends in ".arg" then the value is taken from the
#			command line. Otherwise it is a boolean and appears in
#			the result if present on the command line. If flag ends
#			in ".secret", it will not be displayed in the usage.
#	defaultArrayVar	The name of the array in which to put argument defaults.
#
# Results
#	Name value pairs suitable for using with array set.

proc ::cmdline::GetOptionDefaults {optlist defaultArrayVar} {
    upvar 1 $defaultArrayVar result

    set opts {? help}
    foreach opt $optlist {
	set name [lindex $opt 0]
	if {[regsub -- .secret$ $name {} name] == 1} {
	    # Need to hide this from the usage display and getopt
	}   
	lappend opts $name
	if {[regsub -- .arg$ $name {} name] == 1} {

	    # Set defaults for those that take values.

	    set default [lindex $opt 1]
	    set result($name) $default
	} else {
	    # The default for booleans is false
	    set result($name) 0
	}
    }
    return $opts
}

# ::cmdline::usage --
#
#	Generate an error message that lists the allowed flags.
#
# Arguments:
#	optlist		As for cmdline::getoptions
#	usage		Text to include in the usage display. Defaults to
#			"options:"
#
# Results
#	A formatted usage message

proc ::cmdline::usage {optlist {usage {options:}}} {
    set str "[getArgv0] $usage\n"
    foreach opt [concat $optlist \
	    {{help "Print this message"} {? "Print this message"}}] {
	set name [lindex $opt 0]
	if {[regsub -- .secret$ $name {} name] == 1} {
	    # Hidden option
	    continue
	}
	if {[regsub -- .arg$ $name {} name] == 1} {
	    set default [lindex $opt 1]
	    set comment [lindex $opt 2]
	    append str [format " %-20s %s <%s>\n" "-$name value" \
		    $comment $default]
	} else {
	    set comment [lindex $opt 1]
	    append str [format " %-20s %s\n" "-$name" $comment]
	}
    }
    return $str
}

# ::cmdline::getfiles --
#
#	Given a list of file arguments from the command line, compute
#	the set of valid files.  On windows, file globbing is performed
#	on each argument.  On Unix, only file existence is tested.  If
#	a file argument produces no valid files, a warning is optionally
#	generated.
#
#	This code also uses the full path for each file.  If not
#	given it prepends [pwd] to the filename.  This ensures that
#	these files will never conflict with files in our zip file.
#
# Arguments:
#	patterns	The file patterns specified by the user.
#	quiet		If this flag is set, no warnings will be generated.
#
# Results:
#	Returns the list of files that match the input patterns.

proc ::cmdline::getfiles {patterns quiet} {
    set result {}
    if {$::tcl_platform(platform) == "windows"} {
	foreach pattern $patterns {
	    set pat [file join $pattern]
	    set files [glob -nocomplain -- $pat]
	    if {$files == {}} {
		if {! $quiet} {
		    puts stdout "warning: no files match \"$pattern\""
		}
	    } else {
		foreach file $files {
		    lappend result $file
		}
	    }
	}
    } else {
	set result $patterns
    }
    set files {}
    foreach file $result {
	# Make file an absolute path so that we will never conflict
	# with files that might be contained in our zip file.
	set fullPath [file join [pwd] $file]
	
	if {[file isfile $fullPath]} {
	    lappend files $fullPath
	} elseif {! $quiet} {
	    puts stdout "warning: no files match \"$file\""
	}
    }
    return $files
}

# ::cmdline::getArgv0 --
#
#	This command returns the "sanitized" version of argv0.  It will strip
#	off the leading path and remove the ".bin" extensions that our apps
#	use because they must be wrapped by a shell script.
#
# Arguments:
#	None.
#
# Results:
#	The application name that can be used in error messages.

proc ::cmdline::getArgv0 {} {
    global argv0

    set name [file tail $argv0]
    return [file rootname $name]
}

##
# ### ### ### ######### ######### #########
##
# Now the typed versions of the above commands.
##
# ### ### ### ######### ######### #########
##

# typedCmdline.tcl --
#
#    This package provides a utility for parsing typed command
#    line arguments that may be processed by various applications.
#
# Copyright (c) 2000 by Ross Palmer Mohn.
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# 
# RCS: @(#) $Id: cmdline.tcl,v 1.26 2008/07/09 18:02:59 andreas_kupries Exp $

namespace eval ::cmdline {
    namespace export typedGetopt typedGetoptions typedUsage

    # variable cmdline::charclasses --
    #
    #    Create regexp list of allowable character classes
    #    from "string is" error message.
    #
    # Results:
    #    String of character class names separated by "|" characters.

    variable charclasses
    #checker exclude badKey
    catch {string is . .} charclasses
    variable dummy
    regexp      -- {must be (.+)$} $charclasses dummy charclasses
    regsub -all -- {, (or )?}      $charclasses {|}   charclasses
    unset dummy
}

# ::cmdline::typedGetopt --
#
#	The cmdline::typedGetopt works in a fashion like the standard
#	C based getopt function.  Given an option string and a
#	pointer to a list of args this command will process the
#	first argument and return info on how to proceed. In addition,
#	you may specify a type for the argument to each option.
#
# Arguments:
#	argvVar		Name of the argv list that you want to process.
#			If options are found, the arg list is modified
#			and the processed arguments are removed from the
#			start of the list.
#
#	optstring	A list of command options that the application
#			will accept.  If the option ends in ".xxx", where
#			xxx is any valid character class to the tcl
#			command "string is", then typedGetopt routine will
#			use the next argument as a typed argument to the
#			option. The argument must match the specified
#			character classes (e.g. integer, double, boolean,
#			xdigit, etc.). Alternatively, you may specify
#			".arg" for an untyped argument.
#
#	optVar		Upon success, the variable pointed to by optVar
#			contains the option that was found (without the
#			leading '-' and without the .xxx extension).  If
#			typedGetopt fails the variable is set to the empty
#			string. SOMETIMES! Different for each -value!
#
#	argVar		Upon success, the variable pointed to by argVar
#			contains the argument for the specified option.
#			If typedGetopt fails, the variable is filled with
#			an error message.
#
# Argument type syntax:
#	Option that takes no argument.
#		foo
#
#	Option that takes a typeless argument.
#		foo.arg
#
#	Option that takes a typed argument. Allowable types are all
#	valid character classes to the tcl command "string is".
#	Currently must be one of alnum, alpha, ascii, control,
#	boolean, digit, double, false, graph, integer, lower, print,
#	punct, space, true, upper, wordchar, or xdigit.
#		foo.double
#
#	Option that takes an argument from a list.
#		foo.(bar|blat)
#
# Argument quantifier syntax:
#	Option that takes an optional argument.
#		foo.arg?
#
#	Option that takes a list of arguments terminated by "--".
#		foo.arg+
#
#	Option that takes an optional list of arguments terminated by "--".
#		foo.arg*
#
#	Argument quantifiers work on all argument types, so, for
#	example, the following is a valid option specification.
#		foo.(bar|blat|blah)?
#
# Argument syntax miscellany:
#	Options may be specified on the command line using a unique,
#	shortened version of the option name. Given that program foo
#	has an option list of {bar.alpha blah.arg blat.double},
#	"foo -b fob" returns an error, but "foo -ba fob"
#	successfully returns {bar fob}
#
# Results:
#	The typedGetopt function returns one of the following:
#	 1	a valid option was found
#	 0	no more options found to process
#	-1	invalid option
#	-2	missing argument to a valid option
#	-3	argument to a valid option does not match type
#
# Known Bugs:
#	When using options which include special glob characters,
#	you must use the exact option. Abbreviating it can cause
#	an error in the "cmdline::prefixSearch" procedure.

proc ::cmdline::typedGetopt {argvVar optstring optVar argVar} {
    variable charclasses

    upvar $argvVar argsList

    upvar $optVar retvar
    upvar $argVar optarg

    # default settings for a normal return
    set optarg ""
    set retvar ""
    set retval 0

    # check if we're past the end of the args list
    if {[llength $argsList] != 0} {

        # if we got -- or an option that doesn't begin with -, return (skipping
        # the --).  otherwise process the option arg.
        switch -glob -- [set arg [lindex $argsList 0]] {
            "--" {
                set argsList [lrange $argsList 1 end]
            }

            "-*" {
                # Create list of options without their argument extensions

                set optstr ""
                foreach str $optstring {
                    lappend optstr [file rootname $str]
                }

                set _opt [string range $arg 1 end]

                set i [prefixSearch $optstr [file rootname $_opt]]
                if {$i != -1} {
                    set opt [lindex $optstring $i]

                    set quantifier "none"
                    if {[regexp -- {\.[^.]+([?+*])$} $opt dummy quantifier]} {
                        set opt [string range $opt 0 end-1]
                    }

                    if {[string first . $opt] == -1} {
                        set retval 1
                        set retvar $opt
                        set argsList [lrange $argsList 1 end]

                    } elseif {[regexp -- "\\.(arg|$charclasses)\$" $opt dummy charclass]
                            || [regexp -- {\.\(([^)]+)\)} $opt dummy charclass]} {
				if {[string equal arg $charclass]} {
                            set type arg
			} elseif {[regexp -- "^($charclasses)\$" $charclass]} {
                            set type class
                        } else {
                            set type oneof
                        }

                        set argsList [lrange $argsList 1 end]
                        set opt [file rootname $opt]

                        while {1} {
                            if {[llength $argsList] == 0
                                    || [string equal "--" [lindex $argsList 0]]} {
                                if {[string equal "--" [lindex $argsList 0]]} {
                                    set argsList [lrange $argsList 1 end]
                                }

                                set oneof ""
                                if {$type == "arg"} {
                                    set charclass an
                                } elseif {$type == "oneof"} {
                                    set oneof ", one of $charclass"
                                    set charclass an
                                }
    
                                if {$quantifier == "?"} {
                                    set retval 1
                                    set retvar $opt
                                    set optarg ""
                                } elseif {$quantifier == "+"} {
                                    set retvar $opt
                                    if {[llength $optarg] < 1} {
                                        set retval -2
                                        set optarg "Option requires at least one $charclass argument$oneof -- $opt"
                                    } else {
                                        set retval 1
                                    }
                                } elseif {$quantifier == "*"} {
                                    set retval 1
                                    set retvar $opt
                                } else {
                                    set optarg "Option requires $charclass argument$oneof -- $opt"
                                    set retvar $opt
                                    set retval -2
                                }
                                set quantifier ""
                            } elseif {($type == "arg")
                                    || (($type == "oneof")
                                    && [string first "|[lindex $argsList 0]|" "|$charclass|"] != -1)
                                    || (($type == "class")
                                    && [string is $charclass [lindex $argsList 0]])} {
                                set retval 1
                                set retvar $opt
                                lappend optarg [lindex $argsList 0]
                                set argsList [lrange $argsList 1 end]
                            } else {
                                set oneof ""
                                if {$type == "arg"} {
                                    set charclass an
                                } elseif {$type == "oneof"} {
                                    set oneof ", one of $charclass"
                                    set charclass an
                                }
                                set optarg "Option requires $charclass argument$oneof -- $opt"
                                set retvar $opt
                                set retval -3
    
                                if {$quantifier == "?"} {
                                    set retval 1
                                    set optarg ""
                                }
                                set quantifier ""
                            }
                             if {![regexp -- {[+*]} $quantifier]} {
                                break;
                            }
                        }
                    } else {
                        error "Illegal option type specification:\
                                must be one of $charclasses"
                    }
                } else {
                    set optarg "Illegal option -- $_opt"
                    set retvar $_opt
                    set retval -1
                }
            }
	    default {
		# Skip ahead
	    }
        }
    }

    return $retval
}

# ::cmdline::typedGetoptions --
#
#	Process a set of command line options, filling in defaults
#	for those not specified. This also generates an error message
#	that lists the allowed options if an incorrect option is
#	specified.
#
# Arguments:
#	arglistVar	The name of the argument list, typically argv
#	optlist		A list-of-lists where each element specifies an option
#			in the form:
#
#				option default comment
#
#			Options formatting is as described for the optstring
#			argument of typedGetopt. Default is for optionally
#			specifying a default value. Comment is for optionally
#			specifying a comment for the usage display. The
#			options "-help" and "-?" are automatically included
#			in optlist.
#
# Argument syntax miscellany:
#	Options formatting and syntax is as described in typedGetopt.
#	There are two additional suffixes that may be applied when
#	passing options to typedGetoptions.
#
#	You may add ".multi" as a suffix to any option. For options
#	that take an argument, this means that the option may be used
#	more than once on the command line and that each additional
#	argument will be appended to a list, which is then returned
#	to the application.
#		foo.double.multi
#
#	If a non-argument option is specified as ".multi", it is
#	toggled on and off for each time it is used on the command
#	line.
#		foo.multi
#
#	If an option specification does not contain the ".multi"
#	suffix, it is not an error to use an option more than once.
#	In this case, the behavior for options with arguments is that
#	the last argument is the one that will be returned. For
#	options that do not take arguments, using them more than once
#	has no additional effect.
#
#	Options may also be hidden from the usage display by
#	appending the suffix ".secret" to any option specification.
#	Please note that the ".secret" suffix must be the last suffix,
#	after any argument type specification and ".multi" suffix.
#		foo.xdigit.multi.secret
#
# Results
#	Name value pairs suitable for using with array set.

proc ::cmdline::typedGetoptions {arglistVar optlist {usage options:}} {
    variable charclasses

    upvar 1 $arglistVar argv

    set opts {? help}
    foreach opt $optlist {
        set name [lindex $opt 0]
        if {[regsub -- {\.secret$} $name {} name] == 1} {
            # Remove this extension before passing to typedGetopt.
        }
        if {[regsub -- {\.multi$} $name {} name] == 1} {
            # Remove this extension before passing to typedGetopt.

            regsub -- {\..*$} $name {} temp
            set multi($temp) 1
        }
        lappend opts $name
        if {[regsub -- "\\.(arg|$charclasses|\\(.+).?\$" $name {} name] == 1} {
            # Set defaults for those that take values.
            # Booleans are set just by being present, or not

            set dflt [lindex $opt 1]
            if {$dflt != {}} {
                set defaults($name) $dflt
            }
        }
    }
    set argc [llength $argv]
    while {[set err [typedGetopt argv $opts opt arg]]} {
        if {$err == 1} {
            if {[info exists result($opt)]
                    && [info exists multi($opt)]} {
                # Toggle boolean options or append new arguments

                if {$arg == ""} {
                    unset result($opt)
                } else {
                    set result($opt) "$result($opt) $arg"
                }
            } else {
                set result($opt) "$arg"
            }
        } elseif {($err == -1) || ($err == -3)} {
            error [typedUsage $optlist $usage]
        } elseif {$err == -2 && ![info exists defaults($opt)]} {
            error [typedUsage $optlist $usage]
        }
    }
    if {[info exists result(?)] || [info exists result(help)]} {
        error [typedUsage $optlist $usage]
    }
    foreach {opt dflt} [array get defaults] {
        if {![info exists result($opt)]} {
            set result($opt) $dflt
        }
    }
    return [array get result]
}

# ::cmdline::typedUsage --
#
#	Generate an error message that lists the allowed flags,
#	type of argument taken (if any), default value (if any),
#	and an optional description.
#
# Arguments:
#	optlist		As for cmdline::typedGetoptions
#
# Results
#	A formatted usage message

proc ::cmdline::typedUsage {optlist {usage {options:}}} {
    variable charclasses

    set str "[getArgv0] $usage\n"
    foreach opt [concat $optlist \
            {{help "Print this message"} {? "Print this message"}}] {
        set name [lindex $opt 0]
        if {[regsub -- {\.secret$} $name {} name] == 1} {
            # Hidden option

        } else {
            if {[regsub -- {\.multi$} $name {} name] == 1} {
                # Display something about multiple options
            }

            if {[regexp -- "\\.(arg|$charclasses)\$" $name dummy charclass]
                    || [regexp -- {\.\(([^)]+)\)} $opt dummy charclass]} {
                   regsub -- "\\..+\$" $name {} name
                set comment [lindex $opt 2]
                set default "<[lindex $opt 1]>"
                if {$default == "<>"} {
                    set default ""
                }
                append str [format " %-20s %s %s\n" "-$name $charclass" \
                        $comment $default]
            } else {
                set comment [lindex $opt 1]
		append str [format " %-20s %s\n" "-$name" $comment]
            }
        }
    }
    return $str
}

# ::cmdline::prefixSearch --
#
#	Search a Tcl list for a pattern; searches first for an exact match,
#	and if that fails, for a unique prefix that matches the pattern 
#	(i.e, first "lsearch -exact", then "lsearch -glob $pattern*"
#
# Arguments:
#	list		list of words
#	pattern		word to search for
#
# Results:
#	Index of found word is returned. If no exact match or
#	unique short version is found then -1 is returned.

proc ::cmdline::prefixSearch {list pattern} {
    # Check for an exact match

    if {[set pos [::lsearch -exact $list $pattern]] > -1} {
        return $pos
    }

    # Check for a unique short version

    set slist [lsort $list]
    if {[set pos [::lsearch -glob $slist $pattern*]] > -1} {
        # What if there is nothing for the check variable?

        set check [lindex $slist [expr {$pos + 1}]]
        if {[string first $pattern $check] != 0} {
            return [::lsearch -exact $list [lindex $slist $pos]]
        }
    }
    return -1
}
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<






































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































Deleted scriptlibs/tcllib1.12/cmdline/pkgIndex.tcl.

1
2
if {![package vsatisfies [package provide Tcl] 8.2]} {return}
package ifneeded cmdline 1.3.1 [list source [file join $dir cmdline.tcl]]
<
<




Deleted scriptlibs/tcllib1.12/comm/comm.tcl.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
1483
1484
1485
1486
1487
1488
1489
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
1613
1614
1615
1616
1617
1618
1619
1620
1621
1622
1623
1624
1625
1626
1627
1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
1656
1657
1658
1659
1660
1661
1662
1663
1664
1665
1666
1667
1668
1669
1670
1671
1672
1673
1674
1675
1676
1677
1678
1679
1680
1681
1682
1683
1684
1685
1686
1687
1688
1689
1690
1691
1692
1693
1694
1695
1696
1697
1698
1699
1700
1701
1702
1703
1704
1705
1706
1707
1708
1709
1710
1711
1712
1713
1714
1715
1716
1717
1718
1719
1720
1721
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
1736
1737
1738
1739
1740
1741
1742
1743
1744
1745
1746
1747
1748
1749
1750
1751
1752
1753
1754
1755
1756
1757
1758
1759
1760
1761
1762
1763
1764
1765
1766
1767
1768
1769
1770
1771
1772
1773
1774
1775
1776
# comm.tcl --
#
#	socket-based 'send'ing of commands between interpreters.
#
# %%_OSF_FREE_COPYRIGHT_%%
# Copyright (C) 1995-1998 The Open Group.   All Rights Reserved.
# (Please see the file "comm.LICENSE" that accompanied this source,
#  or http://www.opengroup.org/www/dist_client/caubweb/COPYRIGHT.free.html)
# Copyright (c) 2003-2007 ActiveState Corporation
#
# This is the 'comm' package written by Jon Robert LoVerso, placed
# into its own namespace during integration into tcllib.
#
# Note that the actual code was changed in several places (Reordered,
# eval speedup)
# 
#	comm works just like Tk's send, except that it uses sockets.
#	These commands work just like "send" and "winfo interps":
#
#		comm send ?-async? <id> <cmd> ?<arg> ...?
#		comm interps
#
#	See the manual page comm.n for further details on this package.
#
# RCS: @(#) $Id: comm.tcl,v 1.33 2009/11/04 17:51:53 andreas_kupries Exp $

package require Tcl 8.3
package require snit ; # comm::future objects.

namespace eval ::comm {
    namespace export comm comm_send

    variable  comm
    array set comm {}

    if {![info exists comm(chans)]} {
	array set comm {
	    debug 0 chans {} localhost 127.0.0.1
	    connecting,hook	1
	    connected,hook	1
	    incoming,hook	1
	    eval,hook		1
	    callback,hook	1
	    reply,hook		1
	    lost,hook		1
	    offerVers		{3 2}
	    acceptVers		{3 2}
	    defVers		2
	    defaultEncoding	"utf-8"
	    defaultSilent   0
	}
	set comm(lastport) [expr {[pid] % 32768 + 9999}]
	# fast check for acceptable versions
	foreach comm(_x) $comm(acceptVers) {
	    set comm($comm(_x),vers) 1
	}
	catch {unset comm(_x)}
    }

    # Class variables:
    #	lastport		saves last default listening port allocated
    #	debug			enable debug output
    #	chans			list of allocated channels
    #   future,fid,$fid         List of futures a specific peer is waiting for.
    #
    # Channel instance variables:
    # comm()
    #	$ch,port		listening port (our id)
    #	$ch,socket		listening socket
    #	$ch,socketcmd		command to use to create sockets.
    #   $ch,silent      boolean to indicate whether to throw error on
    #                   protocol negotiation failure
    #	$ch,local		boolean to indicate if port is local
    #	$ch,interp		interpreter to run received scripts in.
    #				If not empty we own it! = We destroy it
    #				with the channel
    #	$ch,events		List of hoks to run in the 'interp', if defined
    #	$ch,serial		next serial number for commands
    #
    #	$ch,hook,$hook		script for hook $hook
    #
    #	$ch,peers,$id		open connections to peers; ch,id=>fid
    #	$ch,fids,$fid		reverse mapping for peers; ch,fid=>id
    #	$ch,vers,$id		negotiated protocol version for id
    #	$ch,pending,$id		list of outstanding send serial numbers for id
    #
    #	$ch,buf,$fid		buffer to collect incoming data
    #	$ch,result,$serial	result value set here to wake up sender
    #	$ch,return,$serial	return codes to go along with result

    if {0} {
	# Propagate result, code, and errorCode.  Can't just eval
	# otherwise TCL_BREAK gets turned into TCL_ERROR.
	global errorInfo errorCode
	set code [catch [concat commSend $args] res]
	return -code $code -errorinfo $errorInfo -errorcode $errorCode $res
    }
}

# ::comm::comm_send --
#
#	Convenience command. Replaces Tk 'send' and 'winfo' with
#	versions using the 'comm' variants. Multiple calls are
#	allowed, only the first one will have an effect.
#
# Arguments:
#	None.
#
# Results:
#	None.

proc ::comm::comm_send {} {
    proc send {args} {
	# Use pure lists to speed this up.
	uplevel 1 [linsert $args 0 ::comm::comm send]
    }
    rename winfo tk_winfo
    proc winfo {cmd args} {
	if {![string match in* $cmd]} {
	    # Use pure lists to speed this up ...
	    return [uplevel 1 [linsert $args 0 tk_winfo $cmd]]
	}
	return [::comm::comm interps]
    }
    proc ::comm::comm_send {} {}
}

# ::comm::comm --
#
#	See documentation for public methods of "comm".
#	This procedure is followed by the definition of
#	the public methods themselves.
#
# Arguments:
#	cmd	Invoked method
#	args	Arguments to method.
#
# Results:
#	As of the invoked method.

proc ::comm::comm {cmd args} {
    set method [info commands ::comm::comm_cmd_$cmd*]

    if {[llength $method] == 1} {
	set chan ::comm::comm; # passed to methods
	return [uplevel 1 [linsert $args 0 $method $chan]]
    } else {
	foreach c [info commands ::comm::comm_cmd_*] {
	    # remove ::comm::comm_cmd_
	    lappend cmds [string range $c 17 end]
	}
        return -code error "unknown subcommand \"$cmd\":\
		must be one of [join [lsort $cmds] {, }]"
    }
}

proc ::comm::comm_cmd_connect {chan args} {
    uplevel 1 [linsert $args 0 [namespace current]::commConnect $chan]
}
proc ::comm::comm_cmd_self {chan args} {
    variable comm
    return $comm($chan,port)
}
proc ::comm::comm_cmd_channels {chan args} {
    variable comm
    return $comm(chans)
}
proc ::comm::comm_cmd_configure {chan args} {
    uplevel 1 [linsert $args 0 [namespace current]::commConfigure $chan 0]
}
proc ::comm::comm_cmd_ids {chan args} {
    variable comm
    set res $comm($chan,port)
    foreach {i id} [array get comm $chan,fids,*] {lappend res $id}
    return $res
}
interp alias {} ::comm::comm_cmd_interps {} ::comm::comm_cmd_ids
proc ::comm::comm_cmd_remoteid {chan args} {
    variable comm
    if {[info exists comm($chan,remoteid)]} {
	set comm($chan,remoteid)
    } else {
	return -code error "No remote commands processed yet"
    }
}
proc ::comm::comm_cmd_debug {chan bool} {
    variable comm
    return [set comm(debug) [string is true -strict $bool]]
}

# ### ### ### ######### ######### #########
## API: Setup async result generation for a remotely invoked command.

# (future,fid,<fid>) -> list (future)
# (current,async)    -> bool (default 0) 
# (current,state)    -> list (chan fid cmd ser)

proc ::comm::comm_cmd_return_async {chan} {
    variable comm

    if {![info exists comm(current,async)]} {
	return -code error "No remote commands processed yet"
    }
    if {$comm(current,async)} {
	# Return the same future which were generated by the first
	# call.
	return $comm(current,state)
    }

    foreach {cmdchan cmdfid cmd ser} $comm(current,state) break

    # Assert that the channel performing the request and the channel
    # the current command came in are identical. Panic if not.

    if {![string equal $chan $cmdchan]} {
	return -code error "Internal error: Trying to activate\
		async return for a command on a different channel"
    }

    # Establish the future for the command and return a handle for
    # it. Remember the outstanding futures for a peer, so that we can
    # cancel them if the peer is lost before the promise implicit in
    # the future is redeemed.

    set future [::comm::future %AUTO% $chan $cmdfid $cmd $ser]

    lappend comm(future,fid,$cmdfid) $future
    set     comm(current,state)      $future

    # Mark the current command as using async result return. We do
    # this last to ensure that all errors in this method are reported
    # through the regular channels.

    set comm(current,async) 1

    return $future
}

# hook --
#
#	Internal command. Implements 'comm hook'.
#
# Arguments:
#	hook	hook to modify
#	script	Script to add/remove to/from the hook
#
# Results:
#	None.
#
proc ::comm::comm_cmd_hook {chan hook {script +}} {
    variable comm
    if {![info exists comm($hook,hook)]} {
	return -code error "Unknown hook invoked"
    }
    if {!$comm($hook,hook)} {
	return -code error "Unimplemented hook invoked"
    }
    if {[string equal + $script]} {
	if {[catch {set comm($chan,hook,$hook)} ret]} {
	    return
	}
	return $ret
    }
    if {[string match +* $script]} {
	append comm($chan,hook,$hook) \n [string range $script 1 end]
    } else {
	set comm($chan,hook,$hook) $script
    }
    return
}

# abort --
#
#	Close down all peer connections.
#	Implements the 'comm abort' method.
#
# Arguments:
#	None.
#
# Results:
#	None.

proc ::comm::comm_cmd_abort {chan} {
    variable comm

    foreach pid [array names comm $chan,peers,*] {
	commLostConn $chan $comm($pid) "Connection aborted by request"
    }
}

# destroy --
#
#	Destroy the channel invoking it.
#	Implements the 'comm destroy' method.
#
# Arguments:
#	None.
#
# Results:
#	None.
#
proc ::comm::comm_cmd_destroy {chan} {
    variable comm
    catch {close $comm($chan,socket)}
    comm_cmd_abort $chan
    if {$comm($chan,interp) != {}} {
	interp delete $comm($chan,interp)
    }
    catch {unset comm($chan,port)}
    catch {unset comm($chan,local)}
    catch {unset comm($chan,silent)}
    catch {unset comm($chan,interp)}
    catch {unset comm($chan,events)}
    catch {unset comm($chan,socket)}
    catch {unset comm($chan,socketcmd)}
    catch {unset comm($chan,remoteid)}
    unset comm($chan,serial)
    unset comm($chan,chan)
    unset comm($chan,encoding)
    unset comm($chan,listen)
    # array unset would have been nicer, but is not available in
    # 8.2/8.3
    foreach pattern {hook,* interp,* vers,*} {
	foreach k [array names comm $chan,$pattern] {unset comm($k)}
    }
    set pos [lsearch -exact $comm(chans) $chan]
    set comm(chans) [lreplace $comm(chans) $pos $pos]
    if {
	![string equal ::comm::comm $chan] &&
	![string equal [info proc $chan] ""]
    } {
	rename $chan {}
    }
    return
}

# shutdown --
#
#	Close down a peer connection.
#	Implements the 'comm shutdown' method.
#
# Arguments:
#	id	Reference to the remote interp
#
# Results:
#	None.
#
proc ::comm::comm_cmd_shutdown {chan id} {
    variable comm

    if {[info exists comm($chan,peers,$id)]} {
	commLostConn $chan $comm($chan,peers,$id) \
	    "Connection shutdown by request"
    }
}

# new --
#
#	Create a new comm channel/instance.
#	Implements the 'comm new' method.
#
# Arguments:
#	ch	Name of the new channel
#	args	Configuration, in the form of -option value pairs.
#
# Results:
#	None.
#
proc ::comm::comm_cmd_new {chan ch args} {
    variable comm

    if {[lsearch -exact $comm(chans) $ch] >= 0} {
	return -code error "Already existing channel: $ch"
    }
    if {([llength $args] % 2) != 0} {
	return -code error "Must have an even number of config arguments"
    }
    # ensure that the new channel name is fully qualified
    set ch ::[string trimleft $ch :]
    if {[string equal ::comm::comm $ch]} {
	# allow comm to be recreated after destroy
    } elseif {[string equal $ch [info commands $ch]]} {
	return -code error "Already existing command: $ch"
    } else {
	# Create the new channel with fully qualified proc name
	proc $ch {cmd args} {
	    set method [info commands ::comm::comm_cmd_$cmd*]

	    if {[llength $method] == 1} {
		# this should work right even if aliased
		# it is passed to methods to identify itself
		set chan [namespace origin [lindex [info level 0] 0]]
		return [uplevel 1 [linsert $args 0 $method $chan]]
	    } else {
		foreach c [info commands ::comm::comm_cmd_*] {
		    # remove ::comm::comm_cmd_
		    lappend cmds [string range $c 17 end]
		}
		return -code error "unknown subcommand \"$cmd\":\
			must be one of [join [lsort $cmds] {, }]"
	    }
	}
    }
    lappend comm(chans) $ch
    set chan $ch
    set comm($chan,serial) 0
    set comm($chan,chan)   $chan
    set comm($chan,port)   0
    set comm($chan,listen) 0
    set comm($chan,socket) ""
    set comm($chan,local)  1
    set comm($chan,silent)   $comm(defaultSilent)
    set comm($chan,encoding) $comm(defaultEncoding)
    set comm($chan,interp)   {}
    set comm($chan,events)   {}
    set comm($chan,socketcmd) ::socket

    if {[llength $args] > 0} {
	if {[catch [linsert $args 0 commConfigure $chan 1] err]} {
	    comm_cmd_destroy $chan
	    return -code error $err
	}
    }
    return $chan
}

# send --
#
#	Send command to a specified channel.
#	Implements the 'comm send' method.
#
# Arguments:
#	args	see inside
#
# Results:
#	varies.
#
proc ::comm::comm_cmd_send {chan args} {
    variable comm

    set cmd send

    # args = ?-async | -command command? id cmd ?arg arg ...?
    set i 0
    set opt [lindex $args $i]
    if {[string equal -async $opt]} {
	set cmd async
	incr i
    } elseif {[string equal -command $opt]} {
	set cmd command
	set callback [lindex $args [incr i]]
	incr i
    }
    # args = id cmd ?arg arg ...?

    set id [lindex $args $i]
    incr i
    set args [lrange $args $i end]

    if {![info complete $args]} {
	return -code error "Incomplete command"
    }
    if {![llength $args]} {
	return -code error \
		"wrong # args: should be \"send ?-async? id arg ?arg ...?\""
    }
    if {[catch {commConnect $chan $id} fid]} {
	return -code error "Connect to remote failed: $fid"
    }

    set ser [incr comm($chan,serial)]
    # This is unneeded - wraps from 2147483647 to -2147483648
    ### if {$comm($chan,serial) == 0x7fffffff} {set comm($chan,serial) 0}

    commDebug {puts stderr "<$chan> send <[list [list $cmd $ser $args]]>"}

    # The double list assures that the command is a single list when read.
    puts  $fid [list [list $cmd $ser $args]]
    flush $fid

    commDebug {puts stderr "<$chan> sent"}

    # wait for reply if so requested

    if {[string equal command $cmd]} {
	# In this case, don't wait on the command result.  Set the callback
	# in the return and that will be invoked by the result.
	lappend comm($chan,pending,$id) [list $ser callback]
	set comm($chan,return,$ser) $callback
	return $ser
    } elseif {[string equal send $cmd]} {
	upvar 0 comm($chan,pending,$id) pending	;# shorter variable name

	lappend pending $ser
	set comm($chan,return,$ser) ""		;# we're waiting

	commDebug {puts stderr "<$chan> --<<waiting $ser>>--"}
	vwait ::comm::comm($chan,result,$ser)

	# if connection was lost, pending is gone
	if {[info exists pending]} {
	    set pos [lsearch -exact $pending $ser]
	    set pending [lreplace $pending $pos $pos]
	}

	commDebug {
	    puts stderr "<$chan> result\
		    <$comm($chan,return,$ser);$comm($chan,result,$ser)>"
	}

	array set return $comm($chan,return,$ser)
	unset comm($chan,return,$ser)
	set thisres $comm($chan,result,$ser)
	unset comm($chan,result,$ser)
	switch -- $return(-code) {
	    "" - 0 {return $thisres}
	    1 {
		return  -code $return(-code) \
			-errorinfo $return(-errorinfo) \
			-errorcode $return(-errorcode) \
			$thisres
	    }
	    default {return -code $return(-code) $thisres}
	}
    }
}

###############################################################################

# ::comm::commDebug --
#
#	Internal command. Conditionally executes debugging
#	statements. Currently this are only puts commands logging the
#	various interactions. These could be replaced with calls into
#	the 'log' module.
#
# Arguments:
#	arg	Tcl script to execute.
#
# Results:
#	None.

proc ::comm::commDebug {cmd} {
    variable comm
    if {$comm(debug)} {
	uplevel 1 $cmd
    }
}

# ::comm::commConfVars --
#
#	Internal command. Used to declare configuration options.
#
# Arguments:
#	v	Name of configuration option.
#	t	Default value.
#
# Results:
#	None.

proc ::comm::commConfVars {v t} {
    variable comm
    set comm($v,var) $t
    set comm(vars) {}
    foreach c [array names comm *,var] {
	lappend comm(vars) [lindex [split $c ,] 0]
    }
    return
}
::comm::commConfVars port     p
::comm::commConfVars local    b
::comm::commConfVars listen   b
::comm::commConfVars socket   ro
::comm::commConfVars socketcmd socketcmd
::comm::commConfVars chan     ro
::comm::commConfVars serial   ro
::comm::commConfVars encoding enc
::comm::commConfVars silent   b
::comm::commConfVars interp   interp
::comm::commConfVars events   ev

# ::comm::commConfigure --
#
#	Internal command. Implements 'comm configure'.
#
# Arguments:
#	force	Boolean flag. If set the socket is reinitialized.
#	args	New configuration, as -option value pairs.
#
# Results:
#	None.

proc ::comm::commConfigure {chan {force 0} args} {
    variable comm

    # query
    if {[llength $args] == 0} {
	foreach v $comm(vars) {lappend res -$v $comm($chan,$v)}
	return $res
    } elseif {[llength $args] == 1} {
	set arg [lindex $args 0]
	set var [string range $arg 1 end]
	if {![string match -* $arg] || ![info exists comm($var,var)]} {
	    return -code error "Unknown configuration option: $arg"
	}
	return $comm($chan,$var)
    }

    # set
    set opt 0
    foreach arg $args {
	incr opt
	if {[info exists skip]} {unset skip; continue}
	set var [string range $arg 1 end]
	if {![string match -* $arg] || ![info exists comm($var,var)]} {
	    return -code error "Unknown configuration option: $arg"
	}
	set optval [lindex $args $opt]
	switch $comm($var,var) {
	    ev {
		if {![string equal  $optval ""]} {
		    set err 0
		    if {[catch {
			foreach ev $optval {
			    if {[lsearch -exact {connecting connected incoming eval callback reply lost} $ev] < 0} {
				set err 1
				break
			    }
			}
		    }]} {
			set err 1
		    }
		    if {$err} {
			return -code error \
				"Non-event to configuration option: -$var"
		    }
		}
		# FRINK: nocheck
		set $var $optval
		set skip 1
	    }
	    interp {
		if {
		    ![string equal  $optval ""] &&
		    ![interp exists $optval]
		} {
		    return -code error \
			    "Non-interpreter to configuration option: -$var"
		}
		# FRINK: nocheck
		set $var $optval
		set skip 1
	    }
	    b {
		# FRINK: nocheck
		set $var [string is true -strict $optval]
		set skip 1
	    }
	    v {
		# FRINK: nocheck
		set $var $optval
		set skip 1
	    }
	    p {
		if {
		    ![string equal $optval ""] &&
		    ![string is integer $optval]
		} {
		    return -code error \
			"Non-port to configuration option: -$var"
		}
		# FRINK: nocheck
		set $var $optval
		set skip 1
	    }
	    i {
		if {![string is integer $optval]} {
		    return -code error \
			"Non-integer to configuration option: -$var"
		}
		# FRINK: nocheck
		set $var $optval
		set skip 1
	    }
	    enc {
		# to configure encodings, we will need to extend the
		# protocol to allow for handshaked encoding changes
		return -code error "encoding not configurable"
		if {[lsearch -exact [encoding names] $optval] == -1} {
		    return -code error \
			"Unknown encoding to configuration option: -$var"
		}
		set $var $optval
		set skip 1
	    }
	    ro {
		return -code error "Readonly configuration option: -$var"
	    }
	    socketcmd {
		if {$optval eq {}} {
		    return -code error \
			"Non-command to configuration option: -$var"
		}

		set $var $optval
		set skip 1
	    }
	}
    }
    if {[info exists skip]} {
	return -code error "Missing value for option: $arg"
    }

    foreach var {port listen local socketcmd} {
	# FRINK: nocheck
	if {[info exists $var] && [set $var] != $comm($chan,$var)} {
	    incr force
	    # FRINK: nocheck
	    set comm($chan,$var) [set $var]
	}
    }

    foreach var {silent interp events} {
	# FRINK: nocheck
	if {[info exists $var] && ([set $var] != $comm($chan,$var))} {
	    # FRINK: nocheck
	    set comm($chan,$var) [set ip [set $var]]
	    if {[string equal $var "interp"] && ($ip != "")} {
		# Interrogate the interp about its capabilities.
		#
		# Like: set, array set, uplevel present ?
		# Or:   The above, hidden ?
		#
		# This is needed to decide how to execute hook scripts
		# and regular scripts in this interpreter.
		set comm($chan,interp,set)  [Capability $ip set]
		set comm($chan,interp,aset) [Capability $ip array]
		set comm($chan,interp,upl)  [Capability $ip uplevel]
	    }
	}
    }

    if {[info exists encoding] &&
	![string equal $encoding $comm($chan,encoding)]} {
	# This should not be entered yet
	set comm($chan,encoding) $encoding
	fconfigure $comm($chan,socket) -encoding $encoding
	foreach {i sock} [array get comm $chan,peers,*] {
	    fconfigure $sock -encoding $encoding
	}
    }

    # do not re-init socket
    if {!$force} {return ""}

    # User is recycling object, possibly to change from local to !local
    if {[info exists comm($chan,socket)]} {
	comm_cmd_abort $chan
	catch {close $comm($chan,socket)}
	unset comm($chan,socket)
    }

    set comm($chan,socket) ""
    if {!$comm($chan,listen)} {
	set comm($chan,port) 0
	return ""
    }

    if {[info exists port] && [string equal "" $comm($chan,port)]} {
	set nport [incr comm(lastport)]
    } else {
	set userport 1
	set nport $comm($chan,port)
    }
    while {1} {
	set cmd [list $comm($chan,socketcmd) -server [list ::comm::commIncoming $chan]]
	if {$comm($chan,local)} {
	    lappend cmd -myaddr $comm(localhost)
	}
	lappend cmd $nport
	if {![catch $cmd ret]} {
	    break
	}
	if {[info exists userport] || ![string match "*already in use" $ret]} {
	    # don't eradicate the class
	    if {
		![string equal ::comm::comm $chan] &&
		![string equal [info proc $chan] ""]
	    } {
		rename $chan {}
	    }
	    return -code error $ret
	}
	set nport [incr comm(lastport)]
    }
    set comm($chan,socket) $ret
    fconfigure $ret -translation lf -encoding $comm($chan,encoding)

    # If port was 0, system allocated it for us
    set comm($chan,port) [lindex [fconfigure $ret -sockname] 2]
    return ""
}

# ::comm::Capability --
#
#	Internal command. Interogate an interp for
#	the commands needed to execute regular and
#	hook scripts.

proc ::comm::Capability {interp cmd} {
    if {[lsearch -exact [interp hidden $interp] $cmd] >= 0} {
	# The command is present, although hidden.
	return hidden
    }

    # The command is not a hidden command. Use info to determine if it
    # is present as regular command. Note that the 'info' command
    # itself might be hidden.

    if {[catch {
	set has [llength [interp eval $interp [list info commands $cmd]]]
    }] && [catch {
	set has [llength [interp invokehidden $interp info commands $cmd]]
    }]} {
	# Unable to interogate the interpreter in any way. Assume that
	# the command is not present.
	set has 0
    }
    return [expr {$has ? "ok" : "no"}]
}

# ::comm::commConnect --
#
#	Internal command. Called to connect to a remote interp
#
# Arguments:
#	id	Specification of the location of the remote interp.
#		A list containing either one or two elements.
#		One element = port, host is localhost.
#		Two elements = port and host, in this order.
#
# Results:
#	fid	channel handle of the socket the connection goes through.

proc ::comm::commConnect {chan id} {
    variable comm

    commDebug {puts stderr "<$chan> commConnect $id"}

    # process connecting hook now
    CommRunHook $chan connecting

    if {[info exists comm($chan,peers,$id)]} {
	return $comm($chan,peers,$id)
    }
    if {[lindex $id 0] == 0} {
	return -code error "Remote comm is anonymous; cannot connect"
    }

    if {[llength $id] > 1} {
	set host [lindex $id 1]
    } else {
	set host $comm(localhost)
    }
    set port [lindex $id 0]
    set fid [$comm($chan,socketcmd) $host $port]

    # process connected hook now
    if {[catch {
	CommRunHook $chan connected
    } err]} {
	global  errorInfo
	set ei $errorInfo
	close $fid
	error $err $ei
    }

    # commit new connection
    commNewConn $chan $id $fid

    # send offered protocols versions and id to identify ourselves to remote
    puts $fid [list $comm(offerVers) $comm($chan,port)]
    set comm($chan,vers,$id) $comm(defVers)		;# default proto vers
    flush  $fid
    return $fid
}

# ::comm::commIncoming --
#
#	Internal command. Called for an incoming new connection.
#	Handles connection setup and initialization.
#
# Arguments:
#	chan	logical channel handling the connection.
#	fid	channel handle of the socket running the connection.
#	addr	ip address of the socket channel 'fid'
#	remport	remote port for the socket channel 'fid'
#
# Results:
#	None.

proc ::comm::commIncoming {chan fid addr remport} {
    variable comm

    commDebug {puts stderr "<$chan> commIncoming $fid $addr $remport"}

    # process incoming hook now
    if {[catch {
	CommRunHook $chan incoming
    } err]} {
	global errorInfo
	set ei $errorInfo
	close $fid
	error $err $ei
    }

    # a list of offered proto versions is the first word of first line
    # remote id is the second word of first line
    # rest of first line is ignored
    set protoline   [gets $fid]
    set offeredvers [lindex $protoline 0]
    set remid       [lindex $protoline 1]

    commDebug {puts stderr "<$chan> offered <$protoline>"}

    # use the first supported version in the offered list
    foreach v $offeredvers {
	if {[info exists comm($v,vers)]} {
	    set vers $v
	    break
	}
    }
    if {![info exists vers]} {
	close $fid
	if {[info exists comm($chan,silent)] && 
	    [string is true -strict $comm($chan,silent)]} then return
	error "Unknown offered protocols \"$protoline\" from $addr/$remport"
    }

    # If the remote host addr isn't our local host addr,
    # then add it to the remote id.
    if {[string equal [lindex [fconfigure $fid -sockname] 0] $addr]} {
	set id $remid
    } else {
	set id [list $remid $addr]
    }

    # Detect race condition of two comms connecting to each other
    # simultaneously.  It is OK when we are talking to ourselves.

    if {[info exists comm($chan,peers,$id)] && $id != $comm($chan,port)} {

	puts stderr "commIncoming race condition: $id"
	puts stderr "peers=$comm($chan,peers,$id) port=$comm($chan,port)"

	# To avoid the race, we really want to terminate one connection.
	# However, both sides are committed to using it.
	# commConnect needs to be synchronous and detect the close.
	# close $fid
	# return $comm($chan,peers,$id)
    }

    # Make a protocol response.  Avoid any temptation to use {$vers > 2}
    # - this forces forwards compatibility issues on protocol versions
    # that haven't been invented yet.  DON'T DO IT!  Instead, test for
    # each supported version explicitly.  I.e., {$vers >2 && $vers < 5} is OK.

    switch $vers {
	3 {
	    # Respond with the selected version number
	    puts  $fid [list [list vers $vers]]
	    flush $fid
	}
    }

    # commit new connection
    commNewConn $chan $id $fid
    set comm($chan,vers,$id) $vers
}

# ::comm::commNewConn --
#
#	Internal command. Common new connection processing
#
# Arguments:
#	id	Reference to the remote interp
#	fid	channel handle of the socket running the connection.
#
# Results:
#	None.

proc ::comm::commNewConn {chan id fid} {
    variable comm

    commDebug {puts stderr "<$chan> commNewConn $id $fid"}

    # There can be a race condition two where comms connect to each other
    # simultaneously.  This code favors our outgoing connection.

    if {[info exists comm($chan,peers,$id)]} {
	# abort this connection, use the existing one
	# close $fid
	# return -code return $comm($chan,peers,$id)
    } else {
	set comm($chan,pending,$id) {}
    	set comm($chan,peers,$id) $fid
    }
    set comm($chan,fids,$fid) $id
    fconfigure $fid -translation lf -encoding $comm($chan,encoding) -blocking 0
    fileevent $fid readable [list ::comm::commCollect $chan $fid]
}

# ::comm::commLostConn --
#
#	Internal command. Called to tidy up a lost connection,
#	including aborting ongoing sends. Each send should clean
#	themselves up in pending/result.
#
# Arguments:
#	fid	Channel handle of the socket which got lost.
#	reason	Message describing the reason of the loss.
#
# Results:
#	reason

proc ::comm::commLostConn {chan fid reason} {
    variable comm

    commDebug {puts stderr "<$chan> commLostConn $fid $reason"}

    catch {close $fid}

    set id $comm($chan,fids,$fid)

    # Invoke the callbacks of all commands which have such and are
    # still waiting for a response from the lost peer. Use an
    # appropriate error.

    foreach s $comm($chan,pending,$id) {
	if {[string equal "callback" [lindex $s end]]} {
	    set ser [lindex $s 0]
	    if {[info exists comm($chan,return,$ser)]} {
		set args [list -id       $id \
			      -serial    $ser \
			      -chan      $chan \
			      -code      -1 \
			      -errorcode NONE \
			      -errorinfo "" \
			      -result    $reason \
			     ]
		if {[catch {uplevel \#0 $comm($chan,return,$ser) $args} err]} {
		    commBgerror $err
		}
	    }
	} else {
	    set comm($chan,return,$s) {-code error}
	    set comm($chan,result,$s) $reason
	}
    }
    unset comm($chan,pending,$id)
    unset comm($chan,fids,$fid)
    catch {unset comm($chan,peers,$id)}		;# race condition
    catch {unset comm($chan,buf,$fid)}

    # Cancel all outstanding futures for requests which were made by
    # the lost peer, if there are any. This does not destroy
    # them. They will stay around until the long-running operations
    # they belong too kill them.

    CancelFutures $fid

    # process lost hook now
    catch {CommRunHook $chan lost}

    return $reason
}

proc ::comm::commBgerror {err} {
    # SF Tcllib Patch #526499
    # (See http://sourceforge.net/tracker/?func=detail&aid=526499&group_id=12883&atid=312883
    #  for initial request and comments)
    #
    # Error in async call. Look for [bgerror] to report it. Same
    # logic as in Tcl itself. Errors thrown by bgerror itself get
    # reported to stderr.
    if {[catch {bgerror $err} msg]} {
	puts stderr "bgerror failed to handle background error."
	puts stderr "    Original error: $err"
	puts stderr "    Error in bgerror: $msg"
	flush stderr
    }
}

# CancelFutures: Mark futures associated with a comm channel as
# expired, done when the connection to the peer has been lost. The
# marked futures will not generate result anymore. They will also stay
# around until destroyed by the script they belong to.

proc ::comm::CancelFutures {fid} {
    variable comm
    if {![info exists comm(future,fid,$fid)]} return

    commDebug {puts stderr "\tCanceling futures: [join $comm(future,fid,$fid) \
                         "\n\t                 : "]"}

    foreach future $comm(future,fid,$fid) {
	$future Cancel
    }

    unset comm(future,fid,$fid)
    return
}

###############################################################################

# ::comm::commCollect --
#
#	Internal command. Called from the fileevent to read from fid
#	and append to the buffer. This continues until we get a whole
#	command, which we then invoke.
#
# Arguments:
#	chan	logical channel collecting the data
#	fid	channel handle of the socket we collect.
#
# Results:
#	None.

proc ::comm::commCollect {chan fid} {
    variable comm
    upvar #0 comm($chan,buf,$fid) data

    # Tcl8 may return an error on read after a close
    if {[catch {read $fid} nbuf] || [eof $fid]} {
	commDebug {puts stderr "<$chan> collect/lost eof $fid = [eof $fid]"}
	commDebug {puts stderr "<$chan> collect/lost nbuf = <$nbuf>"}
	commDebug {puts stderr "<$chan> collect/lost [fconfigure $fid]"}

	fileevent $fid readable {}		;# be safe
	commLostConn $chan $fid "target application died or connection lost"
	return
    }
    append data $nbuf

    commDebug {puts stderr "<$chan> collect <$data>"}

    # If data contains at least one complete command, we will
    # be able to take off the first element, which is a list holding
    # the command.  This is true even if data isn't a well-formed
    # list overall, with unmatched open braces.  This works because
    # each command in the protocol ends with a newline, thus allowing
    # lindex and lreplace to work.
    #
    # This isn't true with Tcl8.0, which will return an error until
    # the whole buffer is a valid list.  This is probably OK, although
    # it could potentially cause a deadlock.

    # [AK] Actually no. This breaks down if the sender shoves so much
    # data at us so fast that the receiver runs into out of memory
    # before the list is fully well-formed and thus able to be
    # processed.

    while {![catch {
	set cmdrange [Word0 data]
	# word0 is essentially the pre-8.0 'lindex <list> 0', getting
	# the first word of a list, even if the remainder is not fully
	# well-formed. Slight API change, we get the char indices the
	# word is between, and a relative index to the remainder of
	# the list.
    }]} {
	# Unpack the indices, then extract the word.
	foreach {s e step} $cmdrange break
	set cmd [string range $data $s $e]
	commDebug {puts stderr "<$chan> cmd <$data>"}
	if {[string equal "" $cmd]} break
	if {[info complete $cmd]} {
	    # The word is a command, step to the remainder of the
	    # list, and delete the word we have processed.
	    incr e $step
	    set data [string range $data $e end]
	    after idle \
		    [list ::comm::commExec $chan $fid $comm($chan,fids,$fid) $cmd]
	}
    }
}

proc ::comm::Word0 {dv} {
    upvar 1 $dv data

    # data
    #
    # The string we expect to be either a full well-formed list, or a
    # well-formed list until the end of the first word in the list,
    # with non-wellformed data following after, i.e. an incomplete
    # list with a complete first word.

    if {[regexp -indices "^\\s*(\{)" $data -> bracerange]} {
	# The word is brace-quoted, starting at index 'lindex
	# bracerange 0'. We now have to find the closing brace,
	# counting inner braces, ignoring quoted braces. We fail if
	# there is no proper closing brace.

	foreach {s e} $bracerange break
	incr s ; # index of the first char after the brace.
	incr e ; # same. but this is our running index.

	set level 1
	set max [string length $data]

	while {$level} {
	    # We are looking for the first regular or backslash-quoted
	    # opening or closing brace in the string. If none is found
	    # then the word is not complete, and we abort our search.

	    if {![regexp -indices -start $e {(([{}])|(\\[{}]))} $data -> any regular quoted]} {
		#                            ^^      ^
		#                            |regular \quoted
		#                            any
		return -code error "no complete word found/1"
	    }

	    foreach {qs qe} $quoted break
	    foreach {rs re} $regular break

	    if {$qs >= 0} {
		# Skip quoted braces ...
		set e $qe
		incr e
		continue
	    } elseif {$rs >= 0} {
		# Step one nesting level in or out.
		if {[string index $data $rs] eq "\{"} {
		    incr level
		} else {
		    incr level -1
		}
		set  e $re
		incr e
		#puts @$e
		continue
	    } else {
		return -code error "internal error"
	    }
	}

	incr e -2 ; # index of character just before the brace.
	return [list $s $e 2]

    } elseif {[regexp -indices {^\s*(\S+)\s} $data -> wordrange]} {
	# The word is a simple literal which ends at the next
	# whitespace character. Note that there has to be a whitespace
	# for us to recognize a word, for while there is no whitespace
	# behind it in the buffer the word itself may be incomplete.

	return [linsert $wordrange end 1]
    }

    return -code error "no complete word found/2"
}

# ::comm::commExec --
#
#	Internal command. Receives and executes a remote command,
#	returning the result and/or error. Unknown protocol commands
#	are silently discarded
#
# Arguments:
#	chan		logical channel collecting the data
#	fid		channel handle of the socket we collect.
#	remoteid	id of the other side.
#	buf		buffer containing the command to execute.
#
# Results:
#	None.

proc ::comm::commExec {chan fid remoteid buf} {
    variable comm

    # buffer should contain:
    #	send  # {cmd}		execute cmd and send reply with serial #
    #	async # {cmd}		execute cmd but send no reply
    #	reply # {cmd}		execute cmd as reply to serial #

    # these variables are documented in the hook interface
    set cmd [lindex $buf 0]
    set ser [lindex $buf 1]
    set buf [lrange $buf 2 end]
    set buffer [lindex $buf 0]

    # Save remoteid for "comm remoteid".  This will only be valid
    # if retrieved before any additional events occur on this channel.
    # N.B. we could have already lost the connection to remote, making
    # this id be purely informational!
    set comm($chan,remoteid) [set id $remoteid]

    # Save state for possible async result generation
    AsyncPrepare $chan $fid $cmd $ser

    commDebug {puts stderr "<$chan> exec <$cmd,$ser,$buf>"}

    switch -- $cmd {
	send - async - command {}
	callback {
	    if {![info exists comm($chan,return,$ser)]} {
	        commDebug {puts stderr "<$chan> No one waiting for serial \"$ser\""}
		return
	    }

	    # Decompose reply command to assure it only uses "return"
	    # with no side effects.

	    array set return {-code "" -errorinfo "" -errorcode ""}
	    set ret [lindex $buffer end]
	    set len [llength $buffer]
	    incr len -2
	    foreach {sw val} [lrange $buffer 1 $len] {
		if {![info exists return($sw)]} continue
		set return($sw) $val
	    }

	    catch {CommRunHook $chan callback}

	    # this wakes up the sender
	    commDebug {puts stderr "<$chan> --<<wakeup $ser>>--"}

	    # the return holds the callback command
	    # string map the optional %-subs
	    set args [list -id       $id \
			  -serial    $ser \
			  -chan      $chan \
			  -code      $return(-code) \
			  -errorcode $return(-errorcode) \
			  -errorinfo $return(-errorinfo) \
			  -result    $ret \
			 ]
	    set code [catch {uplevel \#0 $comm($chan,return,$ser) $args} err]
	    catch {unset comm($chan,return,$ser)}

	    # remove pending serial
	    upvar 0 comm($chan,pending,$id) pending
	    if {[info exists pending]} {
		set pos [lsearch -exact $pending [list $ser callback]]
		if {$pos != -1} {
		    set pending [lreplace $pending $pos $pos]
		}
	    }
	    if {$code} {
		commBgerror $err
	    }
	    return
	}
	reply {
	    if {![info exists comm($chan,return,$ser)]} {
	        commDebug {puts stderr "<$chan> No one waiting for serial \"$ser\""}
		return
	    }

	    # Decompose reply command to assure it only uses "return"
	    # with no side effects.

	    array set return {-code "" -errorinfo "" -errorcode ""}
	    set ret [lindex $buffer end]
	    set len [llength $buffer]
	    incr len -2
	    foreach {sw val} [lrange $buffer 1 $len] {
		if {![info exists return($sw)]} continue
		set return($sw) $val
	    }

	    catch {CommRunHook $chan reply}

	    # this wakes up the sender
	    commDebug {puts stderr "<$chan> --<<wakeup $ser>>--"}
	    set comm($chan,result,$ser) $ret
	    set comm($chan,return,$ser) [array get return]
	    return
	}
	vers {
	    set ::comm::comm($chan,vers,$id) $ser
	    return
	}
	default {
	    commDebug {puts stderr "<$chan> unknown command; discard \"$cmd\""}
	    return
	}
    }

    # process eval hook now
    set done 0
    set err  0
    if {[info exists comm($chan,hook,eval)]} {
	set err [catch {CommRunHook $chan eval} ret]
	commDebug {puts stderr "<$chan> eval hook res <$err,$ret>"}
	switch $err {
	    1 {
		# error
		set done 1
	    }
	    2 - 3 {
		# return / break
		set err 0
		set done 1
	    }
	}
    }

    commDebug {puts stderr "<$chan> hook(eval) done=$done, err=$err"}

    # exec command
    if {!$done} {
	commDebug {puts stderr "<$chan> exec ($buffer)"}

	# Sadly, the uplevel needs to be in the catch to access the local
	# variables buffer and ret.  These cannot simply be global because
	# commExec is reentrant (i.e., they could be linked to an allocated
	# serial number).

	if {$comm($chan,interp) == {}} {
	    # Main interpreter
	    set thecmd [concat [list uplevel \#0] $buffer]
	    set err    [catch $thecmd ret]
	} else {
	    # Redirect execution into the configured slave
	    # interpreter. The exact command used depends on the
	    # capabilities of the interpreter. A best effort is made
	    # to execute the script in the global namespace.
	    set interp $comm($chan,interp)

	    if {$comm($chan,interp,upl) == "ok"} {
		set thecmd [concat [list uplevel \#0] $buffer]
		set err [catch {interp eval $interp $thecmd} ret]
	    } elseif {$comm($chan,interp,aset) == "hidden"} {
		set thecmd [linsert $buffer 0 interp invokehidden $interp uplevel \#0]
		set err [catch $thecmd ret]
	    } else {
		set thecmd [concat [list interp eval $interp] $buffer]
		set err [catch $thecmd ret]
	    }
	}
    }

    # Check and handle possible async result generation.
    if {[AsyncCheck]} return

    commSendReply $chan $fid $cmd $ser $err $ret
    return
}

# ::comm::commSendReply --
#
#	Internal command. Executed to construct and send the reply
#	for a command.
#
# Arguments:
#	fid		channel handle of the socket we are replying to.
#	cmd		The type of request (send, command) we are replying to.
#	ser		Serial number of the request the reply is for.
#	err		result code to place into the reply.
#	ret		result value to place into the reply.
#
# Results:
#	None.

proc ::comm::commSendReply {chan fid cmd ser err ret} {
    variable comm

    commDebug {puts stderr "<$chan> res <$err,$ret> /$cmd"}

    # The double list assures that the command is a single list when read.
    if {[string equal send $cmd] || [string equal command $cmd]} {
	# The catch here is just in case we lose the target.  Consider:
	#	comm send $other comm send [comm self] exit
	catch {
	    set return [list return -code $err]
	    # send error or result
	    if {$err == 1} {
		global errorInfo errorCode
		lappend return -errorinfo $errorInfo -errorcode $errorCode
	    }
	    lappend return $ret
	    if {[string equal send $cmd]} {
		set reply reply
	    } else {
		set reply callback
	    }
	    puts  $fid [list [list $reply $ser $return]]
	    flush $fid
	}
	commDebug {puts stderr "<$chan> reply sent"}
    }

    if {$err == 1} {
	commBgerror $ret
    }
    commDebug {puts stderr "<$chan> exec complete"}
    return
}

proc ::comm::CommRunHook {chan event} {
    variable comm

    # The documentation promises the hook scripts to have access to a
    # number of internal variables. For a regular hook we simply
    # execute it in the calling level to fulfill this. When the hook
    # is redirected into an interpreter however we do a best-effort
    # copying of the variable values into the interpreter. Best-effort
    # because the 'set' command may not be available in the
    # interpreter, not even hidden.

    if {![info exists comm($chan,hook,$event)]} return
    set cmd    $comm($chan,hook,$event)
    set interp $comm($chan,interp)
    commDebug {puts stderr "<$chan> hook($event) run <$cmd>"}

    if {
	($interp != {}) &&
	([lsearch -exact $comm($chan,events) $event] >= 0)
    } {
	# Best-effort to copy the context into the interpreter for
	# access by the hook script.
	set vars   {
	    addr buffer chan cmd fid host
	    id port reason remport ret var
	}

	if {$comm($chan,interp,set) == "ok"} {
	    foreach v $vars {
		upvar 1 $v V
		if {![info exists V]} continue
		interp eval $interp [list set $v $V]
	    }
	} elseif {$comm($chan,interp,set) == "hidden"} {
	    foreach v $vars {
		upvar 1 $v V
		if {![info exists V]} continue
		interp invokehidden $interp set $v $V
	    }
	}
	upvar 1 return AV
	if {[info exists AV]} {
	    if {$comm($chan,interp,aset) == "ok"} {
		interp eval $interp [list array set return [array get AV]]
	    } elseif {$comm($chan,interp,aset) == "hidden"} {
		interp invokehidden $interp array set return [array get AV]
	    }
	}

	commDebug {puts stderr "<$chan> /interp $interp"}
	set code [catch {interp eval $interp $cmd} res]
    } else {
	commDebug {puts stderr "<$chan> /main"}
	set code [catch {uplevel 1 $cmd} res]
    }

    # Perform the return code propagation promised
    # to the hook scripts.
    switch -exact -- $code {
	0 {}
	1 {
	    return -errorinfo $::errorInfo -errorcode $::errorCode -code error $res
	}
	3 {return}
	4 {}
	default {return -code $code $res}
    }
    return
}

# ### ### ### ######### ######### #########
## Hooks to link async return and future processing into the regular
## system.

# AsyncPrepare, AsyncCheck: Initialize state information for async
# return upon start of a remote invokation, and checking the state for
# async return.

proc ::comm::AsyncPrepare {chan fid cmd ser} {
    variable comm
    set comm(current,async) 0
    set comm(current,state) [list $chan $fid $cmd $ser]
    return
}

proc ::comm::AsyncCheck {} {
    # Check if the executed command notified us of an async return. If
    # not we let the regular return processing handle the end of the
    # script. Otherwise we stop the caller from proceeding, preventing
    # a regular return.

    variable comm
    if {!$comm(current,async)} {return 0}
    return 1
}

# FutureDone: Action taken by an uncanceled future to deliver the
# generated result to the proper invoker. This also removes the future
# from the list of pending futures for the comm channel.

proc comm::FutureDone {future chan fid cmd sid rcode rvalue} {
    variable comm
    commSendReply $chan $fid $cmd $sid $rcode $rvalue

    set pos [lsearch -exact $comm(future,fid,$fid) $future]
    set comm(future,fid,$fid) [lreplace $comm(future,fid,$fid) $pos $pos]
    return
}

# ### ### ### ######### ######### #########
## Hooks to save command state across nested eventloops a remotely
## invoked command may run before finally activating async result
## generation.

# DANGER !! We have to refer to comm internals using fully-qualified
# names because the wrappers will execute in the global namespace
# after their installation.

proc ::comm::Vwait {varname} {
    variable ::comm::comm

    set hasstate [info exists comm(current,async)]
    set hasremote 0
    if {$hasstate} {
	set chan     [lindex $comm(current,state) 0]
	set async    $comm(current,async)
	set state    $comm(current,state)
	set hasremote [info exists comm($chan,remoteid)]
	if {$hasremote} {
	    set remoteid $comm($chan,remoteid)
	}
    }

    set code [catch {uplevel 1 [list ::comm::VwaitOrig $varname]} res]

    if {$hasstate} {
	set comm(current,async)  $async
	set comm(current,state)	 $state
    }
    if {$hasremote} {
	set comm($chan,remoteid) $remoteid
    }

    return -code $code $res
}

proc ::comm::Update {args} {
    variable ::comm::comm

    set hasstate [info exists comm(current,async)]
    set hasremote 0
    if {$hasstate} {
	set chan     [lindex $comm(current,state) 0]
	set async    $comm(current,async)
	set state    $comm(current,state)

	set hasremote [info exists comm($chan,remoteid)]
	if {$hasremote} {
	    set remoteid $comm($chan,remoteid)
	}
    }

    set code [catch {uplevel 1 [linsert $args 0 ::comm::UpdateOrig]} res]

    if {$hasstate} {
	set comm(current,async)  $async
	set comm(current,state)	 $state
    }
    if {$hasremote} {
	set comm($chan,remoteid) $remoteid
    }

    return -code $code $res
}

# Install the wrappers.

proc ::comm::InitWrappers {} {
    rename ::vwait       ::comm::VwaitOrig
    rename ::comm::Vwait ::vwait

    rename ::update       ::comm::UpdateOrig
    rename ::comm::Update ::update

    proc ::comm::InitWrappers {} {}
    return
}

# ### ### ### ######### ######### #########
## API: Future objects.

snit::type comm::future {
    option -command -default {}

    constructor {chan fid cmd ser} {
	set xfid  $fid
	set xcmd  $cmd
	set xser  $ser
	set xchan $chan
	return
    }

    destructor {
	if {!$canceled} {
	    return -code error \
		    "Illegal attempt to destroy unresolved future \"$self\""
	}
    }

    method return {args} {
	# Syntax:             | 0
	#       : -code x     | 2
	#       : -code x val | 3
	#       :         val | 4
	# Allowing multiple -code settings, last one is taken.

	set rcode  0
	set rvalue {}

	while {[lindex $args 0] == "-code"} {
	    set rcode [lindex $args 1]
	    set args  [lrange $args 2 end]
	}
	if {[llength $args] > 1} {
	    return -code error "wrong\#args, expected \"?-code errcode? ?result?\""
	}
	if {[llength $args] == 1} {
	    set rvalue [lindex $args 0]
	}

	if {!$canceled} {
	    comm::FutureDone $self $xchan $xfid $xcmd $xser $rcode $rvalue
	    set canceled 1
	}
	# assert: canceled == 1
	$self destroy
	return
    }

    variable xfid  {}
    variable xcmd  {}
    variable xser  {}
    variable xchan {}
    variable canceled 0

    # Internal method for use by comm channels. Marks the future as
    # expired, no peer to return a result back to.

    method Cancel {} {
	set canceled 1
	if {![llength $options(-command)]} {return}
	uplevel #0 [linsert $options(-command) end $self]
	return
    }
}

# ### ### ### ######### ######### #########
## Setup
::comm::InitWrappers

###############################################################################
#
# Finish creating "comm" using the default port for this interp.
#

if {![info exists ::comm::comm(comm,port)]} {
    if {[string equal macintosh $tcl_platform(platform)]} {
	::comm::comm new ::comm::comm -port 0 -local 0 -listen 1
	set ::comm::comm(localhost) \
	    [lindex [fconfigure $::comm::comm(::comm::comm,socket) -sockname] 0]
	::comm::comm config -local 1
    } else {
	::comm::comm new ::comm::comm -port 0 -local 1 -listen 1
    }
}

#eof
package provide comm 4.6.1
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































Deleted scriptlibs/tcllib1.12/comm/pkgIndex.tcl.

1
2
if {![package vsatisfies [package provide Tcl] 8.3]} {return}
package ifneeded comm 4.6.1 [list source [file join $dir comm.tcl]]
<
<




Deleted scriptlibs/tcllib1.12/control/ascaller.tcl.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
# ascaller.tcl - 
#
#       A few utility procs that manage the evaluation of a command
#	or a script in the context of a caller, taking care of all 
#	the ugly details of proper return codes, errorcodes, and
#	a good stack trace in ::errorInfo as appropriate.
# -------------------------------------------------------------------------
#
# RCS: @(#) $Id: ascaller.tcl,v 1.3 2004/01/15 06:36:12 andreas_kupries Exp $

namespace eval ::control {

    proc CommandAsCaller {cmdVar resultVar {where {}} {codeVar code}} {
	set x [expr {[string equal "" $where] 
		? {} : [subst -nobackslashes {\n    ($where)}]}]
	set script [subst -nobackslashes -nocommands {
	    set $codeVar [catch {uplevel 1 $$cmdVar} $resultVar]
	    if {$$codeVar > 1} {
		return -code $$codeVar $$resultVar
	    }
	    if {$$codeVar == 1} {
		if {[string equal {"uplevel 1 $$cmdVar"} \
			[lindex [split [set ::errorInfo] \n] end]]} {
		    set $codeVar [join \
			    [lrange [split [set ::errorInfo] \n] 0 \
			    end-[expr {4+[llength [split $$cmdVar \n]]}]] \n]
		} else {
		    set $codeVar [join \
			    [lrange [split [set ::errorInfo] \n] 0 end-1] \n]
		}
		return -code error -errorcode [set ::errorCode] \
			-errorinfo "$$codeVar$x" $$resultVar
	    }
	}]
	return $script
    }

    proc BodyAsCaller {bodyVar resultVar codeVar {where {}}} {
	set x [expr {[string equal "" $where]
		? {} : [subst -nobackslashes -nocommands \
		{\n    ($where[string map {{    ("uplevel"} {}} \
		[lindex [split [set ::errorInfo] \n] end]]}]}]
	set script [subst -nobackslashes -nocommands {
	    set $codeVar [catch {uplevel 1 $$bodyVar} $resultVar]
	    if {$$codeVar == 1} {
		if {[string equal {"uplevel 1 $$bodyVar"} \
			[lindex [split [set ::errorInfo] \n] end]]} {
		    set ::errorInfo [join \
			    [lrange [split [set ::errorInfo] \n] 0 end-2] \n]
		} 
		set $codeVar [join \
			[lrange [split [set ::errorInfo] \n] 0 end-1] \n]
		return -code error -errorcode [set ::errorCode] \
			-errorinfo "$$codeVar$x" $$resultVar
	    }
	}]
	return $script
    }

    proc ErrorInfoAsCaller {find replace} {
	set info $::errorInfo
	set i [string last "\n    (\"$find" $info]
	if {$i == -1} {return $info}
	set result [string range $info 0 [incr i 6]]	;# keep "\n    (\""
	append result $replace			;# $find -> $replace
	incr i [string length $find]
	set j [string first ) $info [incr i]]	;# keep rest of parenthetical
	append result [string range $info $i $j]
        return $result
    }

}
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
















































































































































Deleted scriptlibs/tcllib1.12/control/assert.tcl.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
# assert.tcl --
#
#	The [assert] command of the package "control".
#
# RCS: @(#) $Id: assert.tcl,v 1.3 2004/01/15 06:36:12 andreas_kupries Exp $

namespace eval ::control {

    namespace eval assert {
	namespace export EnabledAssert DisabledAssert
	variable CallbackCmd [list return -code error]

	namespace import [namespace parent]::no-op
	rename no-op DisabledAssert

	proc EnabledAssert {expr args} {
	    variable CallbackCmd

	    set code [catch {uplevel 1 [list expr $expr]} res]
	    if {$code} {
		return -code $code $res
	    }
	    if {![string is boolean -strict $res]} {
		return -code error "invalid boolean expression: $expr"
	    }
	    if {$res} {return}
	    if {[llength $args]} {
		set msg [join $args]
	    } else {
		set msg "assertion failed: $expr"
	    }
	    # Might want to catch this
	    namespace eval :: $CallbackCmd [list $msg]
	}

	proc enabled {args} {
	    set n [llength $args]
	    if {$n > 1} {
		return -code error "wrong # args: should be\
			\"[lindex [info level 0] 0] ?boolean?\""
	    }
	    if {$n} {
		set val [lindex $args 0]
		if {![string is boolean -strict $val]} {
		    return -code error "invalid boolean value: $val"
		}
		if {$val} {
		    [namespace parent]::AssertSwitch Disabled Enabled
		} else {
		    [namespace parent]::AssertSwitch Enabled Disabled
		}
	    } else {
		return [string equal [namespace origin EnabledAssert] \
			[namespace origin [namespace parent]::assert]]
	    }
	    return ""
	}

	proc callback {args} {
	    set n [llength $args]
	    if {$n > 1} {
		return -code error "wrong # args: should be\
			\"[lindex [info level 0] 0] ?command?\""
	    }
	    if {$n} {
	        return [variable CallbackCmd [lindex $args 0]]
	    }
	    variable CallbackCmd
	    return $CallbackCmd
	}

    }

    proc AssertSwitch {old new} {
	if {[string equal [namespace origin assert] \
		[namespace origin assert::${new}Assert]]} {return}
	rename assert ${old}Assert
	rename ${new}Assert assert
    }

    namespace import assert::DisabledAssert assert::EnabledAssert

    # For indexer
    proc assert args #
    rename assert {}

    # Initial default: disabled asserts
    rename DisabledAssert assert

}

<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<






















































































































































































Deleted scriptlibs/tcllib1.12/control/control.tcl.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
# control.tcl --
#
#	This is the main package provide script for the package
#	"control".  It provides commands that govern the flow of
#	control of a program.
#
# RCS: @(#) $Id: control.tcl,v 1.15 2005/09/30 05:36:38 andreas_kupries Exp $

package require Tcl 8.2

namespace eval ::control {
    variable version 0.1.3
    namespace export assert control do no-op rswitch

    proc control {command args} {
	# Need to add error handling here
	namespace eval [list $command] $args
    }

    # Set up for auto-loading the commands
    variable home [file join [pwd] [file dirname [info script]]]
    if {[lsearch -exact $::auto_path $home] == -1} {
	lappend ::auto_path $home
    }

    package provide [namespace tail [namespace current]] $version
}
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<






















































Deleted scriptlibs/tcllib1.12/control/do.tcl.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
# do.tcl --
#
#        Tcl implementation of a "do ... while|until" loop.
#
# Originally written for the "Texas Tcl Shootout" programming contest
# at the 2000 Tcl Conference in Austin/Texas.
#
# Copyright (c) 2001 by Reinhard Max <Reinhard.Max@gmx.de>
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: do.tcl,v 1.6 2004/01/15 06:36:12 andreas_kupries Exp $
#
namespace eval ::control {

    proc do {body args} {

	#
	# Implements a "do body while|until test" loop
	# 
	# It is almost as fast as builtin "while" command for loops with
	# more than just a few iterations.
	#

	set len [llength $args]
	if {$len !=2 && $len != 0} {
	    set proc [namespace current]::[lindex [info level 0] 0]
	    return -code error "wrong # args: should be \"$proc body\" or \"$proc body \[until|while\] test\""
	}
	set test 0
	foreach {whileOrUntil test} $args {
	    switch -exact -- $whileOrUntil {
		"while" {}
		"until" { set test !($test) }
		default {
		    return -code error \
			"bad option \"$whileOrUntil\": must be until, or while"
		}
	    }
	    break
	}

	# the first invocation of the body
	set code [catch { uplevel 1 $body } result]

	# decide what to do upon the return code:
	#
	#               0 - the body executed successfully
	#               1 - the body raised an error
	#               2 - the body invoked [return]
	#               3 - the body invoked [break]
	#               4 - the body invoked [continue]
	# everything else - return and pass on the results
	#
	switch -exact -- $code {
	    0 {}
	    1 {
		return -errorinfo [ErrorInfoAsCaller uplevel do]  \
		    -errorcode $::errorCode -code error $result
	    }
	    3 {
		# FRINK: nocheck
		return
	    }
	    4 {}
	    default {
		return -code $code $result
	    }
	}
	# the rest of the loop
	set code [catch {uplevel 1 [list while $test $body]} result]
	if {$code == 1} {
	    return -errorinfo [ErrorInfoAsCaller while do] \
		-errorcode $::errorCode -code error $result
	}
	return -code $code $result
	
    }

}
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<


































































































































































Deleted scriptlibs/tcllib1.12/control/no-op.tcl.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
# no-op.tcl --
#
#	The [no-op] command of the package "control".
#	It accepts any number of arguments and does nothing.
#	It returns an empty string.
#
# RCS: @(#) $Id: no-op.tcl,v 1.2 2004/01/15 06:36:12 andreas_kupries Exp $

namespace eval ::control {

    proc no-op args {}

}

<
<
<
<
<
<
<
<
<
<
<
<
<
<




























Deleted scriptlibs/tcllib1.12/control/pkgIndex.tcl.

1
2
if {![package vsatisfies [package provide Tcl] 8.2]} {return}
package ifneeded control 0.1.3 [list source [file join $dir control.tcl]]
<
<




Deleted scriptlibs/tcllib1.12/control/tclIndex.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
# Tcl autoload index file, version 2.0
# This file is generated by the "auto_mkindex" command
# and sourced to set up indexing information for one or
# more commands.  Typically each line is a command that
# sets an element in the auto_index array, where the
# element name is the name of a command and the value is
# a script that loads the command.

set auto_index(::control::CommandAsCaller) [list source [file join $dir ascaller.tcl]]
set auto_index(::control::BodyAsCaller) [list source [file join $dir ascaller.tcl]]
set auto_index(::control::ErrorInfoAsCaller) [list source [file join $dir ascaller.tcl]]
set auto_index(::control::assert::EnabledAssert) [list source [file join $dir assert.tcl]]
set auto_index(::control::assert::enabled) [list source [file join $dir assert.tcl]]
set auto_index(::control::assert::callback) [list source [file join $dir assert.tcl]]
set auto_index(::control::AssertSwitch) [list source [file join $dir assert.tcl]]
set auto_index(::control::assert) [list source [file join $dir assert.tcl]]
set auto_index(::control::do) [list source [file join $dir do.tcl]]
set auto_index(::control::no-op) [list source [file join $dir no-op.tcl]]
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<




































Deleted scriptlibs/tcllib1.12/coroutine/coro_auto.tcl.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
## -- Tcl Module -- -*- tcl -*-
# # ## ### ##### ######## #############

# @@ Meta Begin
# Package coroutine::auto 1
# Meta platform        tcl
# Meta require         {Tcl 8.6}
# Meta require         coroutine
# Meta license         BSD
# Meta as::author      {Andreas Kupries}
# Meta summary         Coroutine Event and Channel Support
# Meta description     Built on top of coroutine, this
# Meta description     package intercepts various builtin
# Meta description     commands to make the code using them
# Meta description     coroutine-oblivious, i.e. able to run
# Meta description     inside and outside of a coroutine
# Meta description     without changes.
# @@ Meta End

# Copyright (c) 2009 Andreas Kupries

## $Id: coro_auto.tcl,v 1.1 2009/11/10 21:04:39 andreas_kupries Exp $
# # ## ### ##### ######## #############
## Requisites, and ensemble setup.

package require Tcl 8.6
package require coroutine

namespace eval ::coroutine::auto {}

# # ## ### ##### ######## #############
## Internal. Setup.

proc ::coroutine::auto::Init {} {

    # Replaces the builtin commands with coroutine-aware
    # counterparts. We cannot use the coroutine commands
    # directly, because the replacements have to use the saved builtin
    # commands when called outside of a coroutine. And some (read,
    # gets, update) even need full re-implementations, as they use the
    # builtin command they replace themselves to implement their
    # functionality.

    foreach cmd {
	global
	exit
	after
	vwait
	update
    } {
	rename ::$cmd [namespace current]::core_$cmd
	rename [namespace current]::wrap_$cmd ::$cmd
    }

    foreach cmd {
	gets
	read
    } {
	rename ::tcl::chan::$cmd [namespace current]::core_$cmd
	rename [namespace current]::wrap_$cmd ::tcl::chan::$cmd
    }

    return
}

# # ## ### ##### ######## #############
## API implementations. Uses the coroutine commands where
## possible.

proc ::coroutine::auto::wrap_global {args} {
    if {[info coroutine] eq {}} {
	tailcall [namespace current]::core_global {*}$args
    }

    tailcall ::coroutine::global {*}$args
}

# - -- --- ----- -------- -------------

proc ::coroutine::auto::wrap_after {delay args} {
    if {
	([info coroutine] eq {}) ||
	([llength $args] > 0)
    } {
	# We use the core builtin when called from either outside of a
	# coroutine, or for an asynchronous delay.

	tailcall [namespace current]::core_after $delay {*}$args
    }

    # Inside of coroutine, and synchronous delay (args == "").
    tailcall ::coroutine::after $delay
}

# - -- --- ----- -------- -------------

proc ::coroutine::auto::wrap_exit {{status 0}} {
    if {[info coroutine] eq {}} {
	tailcall [namespace current]::core_exit $status
    }

    tailcall ::coroutine::exit $status
}

# - -- --- ----- -------- -------------

proc ::coroutine::auto::wrap_vwait {varname} {
    if {[info coroutine] eq {}} {
	tailcall [namespace current]::core_vwait $varname
    }

    tailcall ::coroutine::vwait $varname
}

# - -- --- ----- -------- -------------

proc ::coroutine::auto::wrap_update {{what {}}} {
    if {[info coroutine] eq {}} {
	tailcall [namespace current]::core_update {*}$what
    }

    # This is a full re-implementation of mode (1), because the
    # coroutine-aware part uses the builtin itself for some
    # functionality, and this part cannot be taken as is.

    if {$what eq "idletasks"} {
        after idle [info coroutine]
    } elseif {$what ne {}} {
        # Force proper error message for bad call.
        tailcall [namespace current]::core_update $what
    } else {
        after 0 [info coroutine]
    }
    yield
    return
} 

# - -- --- ----- -------- -------------

proc ::coroutine::auto::wrap_gets {args} {
    # Process arguments.
    # Acceptable syntax:
    # * gets CHAN ?VARNAME?

    if {[info coroutine] eq {}} {
	tailcall [namespace current]::core_gets {*}$args
    }

    # This is a full re-implementation of mode (1), because the
    # coroutine-aware part uses the builtin itself for some
    # functionality, and this part cannot be taken as is.

    if {[llength $args] > 2} {
	# Calling the builtin gets command with the bogus arguments
	# gives us the necessary error with the proper message.
	tailcall [namespace current]::core_gets {*}$args
    } elseif {[llength $args] == 2} {
	lassign $args chan varname
        upvar 1 $varname line
    } else {
	# llength args == 1
	lassign $args chan
    }

    # Loop until we have a complete line. Yield to the event loop
    # where necessary. During 

    while {1} {
        set blocking [::chan configure $chan -blocking]
        ::chan configure $chan -blocking 0

	try {
	    [namespace current]::core_gets $chan line
	} on error {result opts} {
            ::chan configure $chan -blocking $blocking
            return -code $result -options $opts
	}

	if {[::chan blocked $chan]} {
            ::chan event $chan readable [list [info coroutine]]
            yield
            ::chan event $chan readable {}
        } else {
            ::chan configure $chan -blocking $blocking

            if {[llength $args] == 2} {
                return $result
            } else {
                return $line
            }
        }
    }
}

# - -- --- ----- -------- -------------

proc ::coroutine::auto::wrap_read {args} {
    # Process arguments.
    # Acceptable syntax:
    # * read ?-nonewline ? CHAN
    # * read               CHAN ?n?

    if {[info coroutine] eq {}} {
	tailcall [namespace current]::core_read {*}$args
    }

    # This is a full re-implementation of mode (1), because the
    # coroutine-aware part uses the builtin itself for some
    # functionality, and this part cannot be taken as is.

    if {[llength $args] > 2} {
	# Calling the builtin read command with the bogus arguments
	# gives us the necessary error with the proper message.
	[namespace current]::core_read {*}$args
	return
    }

    set total Inf ; # Number of characters to read. Here: Until eof.
    set chop  no  ; # Boolean flag. Determines if we have to trim a
    #               # \n from the end of the read string.

    if {[llength $args] == 2} {
	lassign $args a b
	if {$a eq "-nonewline"} {
	    set chan $b
	    set chop yes
	} else {
	    lassign $args chan total
	}
    } else {
	lassign $args chan
    }

    # Run the read loop. Yield to the event loop where
    # necessary. Differentiate between loop until eof, and loop until
    # n characters have been read (or eof reached).

    set buf {}

    if {$total eq "Inf"} {
	# Loop until eof.

	while {1} {
	    set blocking [::chan configure $chan -blocking]
	    ::chan configure $chan -blocking 0

	    try {
		[namespace current]::core_read $chan
	    } on error {result opts} {
		::chan configure $chan -blocking $blocking
		return -code $result -options $opts
	    }

	    if {[fblocked $chan]} {
		::chan event $chan readable [list [info coroutine]]
		yield
		::chan event $chan readable {}
	    } else {
		::chan configure $chan -blocking $blocking
		append buf $result

		if {[::chan eof $chan]} {
		    ::chan close $chan
		    break
		}
	    }
	}
    } else {
	# Loop until total characters have been read, or eof found,
	# whichever is first.

	set left $total
	while {1} {
	    set blocking [::chan configure $chan -blocking]
	    ::chan configure $chan -blocking 0

	    try {
		[namespace current]::core_read $chan $left
	    } on error {result opts} {
		::chan configure $chan -blocking $blocking
		return -code $result -options $opts
	    }

	    if {[::chan blocked $chan]} {
		::chan event $chan readable [list [info coroutine]]
		yield
		::chan event $chan readable {}
	    } else {
		::chan configure $chan -blocking $blocking
		append buf $result
		incr   left -[string length $result]

		if {[::chan eof $chan]} {
		    ::chan close $chan
		    break
		} elseif {!$left} {
		    break
		}
	    }
	}
    }

    if {$chop && [string index $buf end] eq "\n"} {
	set buf [string range $buf 0 end-1]
    }

    return $buf
}

# # ## ### ##### ######## #############
## Ready
::coroutine::auto::Init
package provide coroutine::auto 1
return
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<




















































































































































































































































































































































































































































































































































































































































Deleted scriptlibs/tcllib1.12/coroutine/coroutine.tcl.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
## -- Tcl Module -- -*- tcl -*-
# # ## ### ##### ######## #############

# @@ Meta Begin
# Package coroutine 1
# Meta platform        tcl
# Meta require         {Tcl 8.6}
# Meta license         BSD
# Meta as::author      {Andreas Kupries}
# Meta as::author      {Colin McCormack}
# Meta as::author      {Donal Fellows}
# Meta as::author      {Kevin Kenny}
# Meta as::author      {Neil Madden}
# Meta as::author      {Peter Spjuth}
# Meta summary         Coroutine Event and Channel Support
# Meta description     This package provides coroutine-aware
# Meta description     implementations of various event- and
# Meta description     channel related commands. It can be
# Meta description     in multiple modes: (1) Call the
# Meta description     commands through their ensemble, in
# Meta description     code which is explicitly written for
# Meta description     use within coroutines. (2) Import
# Meta description     the commands into a namespace, either
# Meta description     directly, or through 'namespace path'.
# Meta description     This allows the use from within code
# Meta description     which is not coroutine-aware per se
# Meta description     and restricted to specific namespaces.
# Meta description     A more agressive form of making code
# Meta description     coroutine-oblivious than (2) above is
# Meta description     available through the package
# Meta description     coroutine::auto, which intercepts
# Meta description     the relevant builtin commands and changes
# Meta description     their implementation dependending on the
# Meta description     context they are run in, i.e. inside or
# Meta description     outside of a coroutine.
# @@ Meta End

# Copyright (c) 2009 Andreas Kupries
# Copyright (c) 2009 Colin McCormack
# Copyright (c) 2009 Donal Fellows
# Copyright (c) 2009 Kevin Kenny
# Copyright (c) 2009 Neil Madden
# Copyright (c) 2009 Peter Spjuth

## $Id: coroutine.tcl,v 1.1 2009/11/10 21:04:39 andreas_kupries Exp $
# # ## ### ##### ######## #############
## Requisites, and ensemble setup.

package require Tcl 8.6

namespace eval ::coroutine {

    namespace export \
	create global after exit vwait update gets read await

    namespace ensemble create
}

# # ## ### ##### ######## #############
## API. Spawn coroutines, automatic naming
##      (like thread::create).

proc ::coroutine::create {args} {
    ::coroutine [ID] {*}$args
}

# # ## ### ##### ######## #############
## API.
#
# global (coroutine globals (like thread global storage))
# after  (synchronous).
# exit
# update ?idletasks? [1]
# vwait
# gets               [1]
# read               [1]
#
# [1] These commands call on their builtin counterparts to get some of
#     their functionality (like proper error messages for syntax errors).

# - -- --- ----- -------- -------------

proc ::coroutine::global {args} {
    # Frame #1 is the coroutine-specific stack frame at its
    # bottom. Variables there are out of view of the main code, and
    # can be made visible in the entire coroutine underneath.

    set cmd [list upvar "#1"]
    foreach var $args {
	lappend cmd $var $var 
    }
    tailcall $cmd
}

# - -- --- ----- -------- -------------

proc ::coroutine::after {delay} {
    ::after $delay [info coroutine]
    yield
    return
}

# - -- --- ----- -------- -------------

proc ::coroutine::exit {{status 0}} {
    return -level [info level] $status
}

# - -- --- ----- -------- -------------

proc ::coroutine::vwait {varname} {
    upvar 1 $varname var
    set callback [list [namespace current]::VWaitTrace [info coroutine]]

    # Step 1. Wait for a write to the variable, using a trace to
    # restart the coroutine

    trace add    variable var write $callback
    yield
    trace remove variable var write $callback

    # Step 2. To prevent the next section of the coroutine code from
    # running entirely within the variable trace (*) we now use an
    # idle handler to defer it until the trace is definitely
    # done. This trick by Peter Spjuth.
    #
    # (*) At this point we are in VWaitTrace running the coroutine.

    ::after idle [info coroutine]
    yield
    return
}

proc ::coroutine::VWaitTrace {coroutine args} {
    $coroutine
    return
}

# - -- --- ----- -------- -------------

proc ::coroutine::update {{what {}}} {
    if {$what eq "idletasks"} {
        ::after idle [info coroutine]
    } elseif {$what ne {}} {
        # Force proper error message for bad call.
        tailcall ::tcl::update $what
    } else {
        ::after 0 [info coroutine]
    }
    yield
    return
} 

# - -- --- ----- -------- -------------

proc ::coroutine::gets {args} {
    # Process arguments.
    # Acceptable syntax:
    # * gets CHAN ?VARNAME?

    if {[llength $args] > 2} {
	# Calling the builtin gets command with the bogus arguments
	# gives us the necessary error with the proper message.
	tailcall ::chan gets {*}$args
    } elseif {[llength $args] == 2} {
	lassign $args chan varname
        upvar 1 $varname line
    } else {
	# llength args == 1
	lassign $args chan
    }

    # Loop until we have a complete line. Yield to the event loop
    # where necessary. During 

    while {1} {
        set blocking [::chan configure $chan -blocking]
        ::chan configure $chan -blocking 0

	try {
	    ::chan gets $chan line
	} on error {result opts} {
            ::chan configure $chan -blocking $blocking
            return -code $result -options $opts
	}

	if {[::chan blocked $chan]} {
            ::chan event $chan readable [list [info coroutine]]
            yield
            ::chan event $chan readable {}
        } else {
            ::chan configure $chan -blocking $blocking

            if {[llength $args] == 2} {
                return $result
            } else {
                return $line
            }
        }
    }
}

# - -- --- ----- -------- -------------

proc ::coroutine::read {args} {
    # Process arguments.
    # Acceptable syntax:
    # * read ?-nonewline ? CHAN
    # * read               CHAN ?n?

    if {[llength $args] > 2} {
	# Calling the builtin read command with the bogus arguments
	# gives us the necessary error with the proper message.
	::chan read {*}$args
	return
    }

    set total Inf ; # Number of characters to read. Here: Until eof.
    set chop  no  ; # Boolean flag. Determines if we have to trim a
    #               # \n from the end of the read string.

    if {[llength $args] == 2} {
	lassign $args a b
	if {$a eq "-nonewline"} {
	    set chan $b
	    set chop yes
	} else {
	    lassign $args chan total
	}
    } else {
	lassign $args chan
    }

    # Run the read loop. Yield to the event loop where
    # necessary. Differentiate between loop until eof, and loop until
    # n characters have been read (or eof reached).

    set buf {}

    if {$total eq "Inf"} {
	# Loop until eof.

	while {1} {
	    set blocking [::chan configure $chan -blocking]
	    ::chan configure $chan -blocking 0

	    try {
		::chan read $chan
	    } on error {result opts} {
		::chan configure $chan -blocking $blocking
		return -code $result -options $opts
	    }

	    if {[fblocked $chan]} {
		::chan event $chan readable [list [info coroutine]]
		yield
		::chan event $chan readable {}
	    } else {
		::chan configure $chan -blocking $blocking
		append buf $result

		if {[::chan eof $chan]} {
		    ::chan close $chan
		    break
		}
	    }
	}
    } else {
	# Loop until total characters have been read, or eof found,
	# whichever is first.

	set left $total
	while {1} {
	    set blocking [::chan configure $chan -blocking]
	    ::chan configure $chan -blocking 0

	    try {
		::chan read $chan $left
	    } on error {result opts} {
		::chan configure $chan -blocking $blocking
		return -code $result -options $opts
	    }

	    if {[::chan blocked $chan]} {
		::chan event $chan readable [list [info coroutine]]
		yield
		::chan event $chan readable {}
	    } else {
		::chan configure $chan -blocking $blocking
		append buf $result
		incr   left -[string length $result]

		if {[::chan eof $chan]} {
		    ::chan close $chan
		    break
		} elseif {!$left} {
		    break
		}
	    }
	}
    }

    if {$chop && [string index $buf end] eq "\n"} {
	set buf [string range $buf 0 end-1]
    }

    return $buf
}

# - -- --- ----- -------- -------------
## This goes beyond the builtin vwait, wait for multiple variables,
## result is the name of the variable which was written.
## This code mainly by Neil Madden.

proc ::coroutine::await args {
    set callback [list [namespace current]::AWaitSignal [info coroutine]]

    # Step 1. Wait for a write to any of the variable, using a trace
    # to restart the coroutine, and the variable written to is
    # propagated into it.

    foreach varName $args {
        upvar 1 $varName var
        trace add variable var write $callback
    }

    set choice [yield]

    foreach varName $args {
	#checker exclude warnShadowVar 
        upvar 1 $varName var
        trace remove variable var write $callback
    }

    # Step 2. To prevent the next section of the coroutine code from
    # running entirely within the variable trace (*) we now use an
    # idle handler to defer it until the trace is definitely
    # done. This trick by Peter Spjuth.
    #
    # (*) At this point we are in AWaitSignal running the coroutine.

    ::after idle [info coroutine]
    yield

    return $choice
}

proc ::coroutine::AWaitSignal {coroutine var index op} {
    if {$op ne "write"} { return }
    set fullvar $var
    if {$index ne ""} { append fullvar ($index) }
    $coroutine $fullvar
} 

# # ## ### ##### ######## #############
## Internal (package specific) commands

proc ::coroutine::ID {} {
    variable counter
    return [namespace current]::C[incr counter]
}

# # ## ### ##### ######## #############
## Internal (package specific) state

namespace eval ::coroutine {
    #checker exclude warnShadowVar
    variable counter 0
}

# # ## ### ##### ######## #############
## Ready
package provide coroutine 1
return
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<












































































































































































































































































































































































































































































































































































































































































































































































Deleted scriptlibs/tcllib1.12/coroutine/pkgIndex.tcl.

1
2
3
if {![package vsatisfies [package provide Tcl] 8.6]} {return}
package ifneeded coroutine       1  [list source [file join $dir coroutine.tcl]]
package ifneeded coroutine::auto 1  [list source [file join $dir coro_auto.tcl]]
<
<
<






Deleted scriptlibs/tcllib1.12/counter/counter.tcl.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
# counter.tcl --
#
#   Procedures to manage simple counters and histograms.
#
# Copyright (c) 1998-2000 by Ajuba Solutions.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: counter.tcl,v 1.23 2005/09/30 05:36:38 andreas_kupries Exp $

package require Tcl 8.2

namespace eval ::counter {

    # Variables of name counter::T-$tagname
    # are created as arrays to support each counter.

    # Time-based histograms are kept in sync with each other,
    # so these variables are shared among them.
    # These base times record the time corresponding to the first bucket 
    # of the per-minute, per-hour, and per-day time-based histograms.

    variable startTime
    variable minuteBase
    variable hourBase
    variable hourEnd
    variable dayBase
    variable hourIndex
    variable dayIndex

    # The time-based histogram uses an after event and a list
    # of counters to do mergeing on.

    variable tagsToMerge
    if {![info exists tagsToMerge]} {
    set tagsToMerge {}
    }
    variable mergeInterval

    namespace export init reset count exists get names start stop
    namespace export histHtmlDisplay histHtmlDisplayRow histHtmlDisplayBarChart
}

# ::counter::init --
#
#   Set up a counter.
#
# Arguments:
#   tag The identifier for the counter.  Pass this to counter::count
#   args    option values pairs that define characteristics of the counter:
#       See the man page for definitons.
#
# Results:
#   None.
#
# Side Effects:
#   Initializes state about a counter.

proc ::counter::init {tag args} {
    upvar #0 counter::T-$tag counter
    if {[info exists counter]} {
    unset counter
    }
    set counter(N) 0    ;# Number of samples
    set counter(total) 0
    set counter(type) {}

    # With an empty type the counter is a simple accumulator
    # for which we can compute an average.  Here we loop through
    # the args to determine what additional counter attributes
    # we need to maintain in counter::count

    foreach {option value} $args {
    switch -- $option {
        -timehist {
        variable tagsToMerge
        variable secsPerMinute
        variable startTime
        variable minuteBase
        variable hourBase
        variable dayBase
        variable hourIndex
        variable dayIndex

        upvar #0 counter::H-$tag histogram
        upvar #0 counter::Hour-$tag hourhist
        upvar #0 counter::Day-$tag dayhist

        # Clear the histograms.

        for {set i 0} {$i < 60} {incr i} {
            set histogram($i) 0
        }
        for {set i 0} {$i < 24} {incr i} {
            set hourhist($i) 0
        }
        if {[info exists dayhist]} {
            unset dayhist
        }
        set dayhist(0) 0

        # Clear all-time high records

        set counter(maxPerMinute) 0
        set counter(maxPerHour) 0
        set counter(maxPerDay) 0

        # The value associated with -timehist is the number of seconds
        # in each bucket.  Normally this is 60, but for
        # testing, we compress minutes.  The value is limited at
        # 60 because the per-minute buckets are accumulated into
        # per-hour buckets later.

        if {$value == "" || $value == 0 || $value > 60} {
            set value 60
        }

        # Histogram state variables.
        # All time-base histograms share the same bucket size
        # and starting times to keep them all synchronized.
        # So, we only initialize these parameters once.

        if {![info exists secsPerMinute]} {
            set secsPerMinute $value

            set startTime [clock seconds]
            set dayIndex 0

            set dayStart [clock scan [clock format $startTime \
                -format 00:00]]
            
            # Figure out what "hour" we are

            set delta [expr {$startTime - $dayStart}]
            set hourIndex [expr {$delta / ($secsPerMinute * 60)}]
            set day [expr {$hourIndex / 24}]
            set hourIndex [expr {$hourIndex % 24}]

            set hourBase [expr {$dayStart + $day * $secsPerMinute * 60 * 24}]
            set minuteBase [expr {$hourBase + $hourIndex * 60 * $secsPerMinute}]

            set partialHour [expr {$startTime -
            ($hourBase + $hourIndex * 60 * $secsPerMinute)}]
            set secs [expr {(60 * $secsPerMinute) - $partialHour}]
            if {$secs <= 0} {
            set secs 1
            }

            # After the first timer, the event occurs once each "hour"

            set mergeInterval [expr {60 * $secsPerMinute * 1000}]
            after [expr {$secs * 1000}] [list counter::MergeHour $mergeInterval]
        }
        if {[lsearch $tagsToMerge $tag] < 0} {
            lappend tagsToMerge $tag
        }

        # This records the last used slots in order to zero-out the
        # buckets that are skipped during idle periods.

        set counter(lastMinute) -1

        # The following is referenced when bugs cause histogram
        # hits outside the expect range (overflow and underflow)

        set counter(bucketsize)  0
        }
        -group {
        # Cluster a set of counters with a single total

        upvar #0 counter::H-$tag histogram
        if {[info exists histogram]} {
            unset histogram
        }
        set counter(group) $value
        }
        -lastn {
        # The lastN samples are kept if a vector to form a running average.

        upvar #0 counter::V-$tag vector
        set counter(lastn) $value
        set counter(index) 0
        if {[info exists vector]} {
            unset vector
        }
        for {set i 0} {$i < $value} {incr i} {
            set vector($i) 0
        }
        }
        -hist {
        # A value-based histogram with buckets for different values.

        upvar #0 counter::H-$tag histogram
        if {[info exists histogram]} {
            unset histogram
        }
        set counter(bucketsize) $value
        set counter(mult) 1
        }
        -hist2x {
        upvar #0 counter::H-$tag histogram
        if {[info exists histogram]} {
            unset histogram
        }
        set counter(bucketsize) $value
        set counter(mult) 2
        }
        -hist10x {
        upvar #0 counter::H-$tag histogram
        if {[info exists histogram]} {
            unset histogram
        }
        set counter(bucketsize) $value
        set counter(mult) 10
        }
        -histlog {
        upvar #0 counter::H-$tag histogram
        if {[info exists histogram]} {
            unset histogram
        }
        set counter(bucketsize) $value
        }
        -simple {
        # Useful when disabling predefined -timehist or -group counter
        }
        default {
        return -code error "Unsupported option $option.\
        Must be -timehist, -group, -lastn, -hist, -hist2x, -hist10x, -histlog, or -simple."
        }
    }
    if {[string length $option]} {
        # In case an option doesn't change the type, but
        # this feature of the interface isn't used, etc.

        lappend counter(type) $option
    }
    }

    # Instead of supporting a counter that could have multiple attributes,
    # we support a single type to make counting more efficient.

    if {[llength $counter(type)] > 1} {
    return -code error "Multiple type attributes not supported.  Use only one of\
        -timehist, -group, -lastn, -hist, -hist2x, -hist10x, -histlog, -disabled."
    }
    return ""
}

# ::counter::reset --
#
#   Reset a counter.
#
# Arguments:
#   tag The identifier for the counter.
#
# Results:
#   None.
#
# Side Effects:
#   Deletes the counter and calls counter::init again for it.

proc ::counter::reset {tag args} {
    upvar #0 counter::T-$tag counter

    # Layer reset on top of init.  Here we figure out what
    # we need to pass into the init procedure to recreate it.

    switch -- $counter(type) {
    ""  {
        set args ""
    }
    -group {
        upvar #0 counter::H-$tag histogram
        if {[info exists histogram]} {
        unset histogram
        }
        set args [list -group $counter(group)]
    }
    -lastn {
        upvar #0 counter::V-$tag vector
        if {[info exists vector]} {
        unset vector
        }
        set args [list -lastn $counter(lastn)]
    }
    -hist -
    -hist10x -
    -histlog -
    -hist2x {
        upvar #0 counter::H-$tag histogram
        if {[info exists histogram]} {
        unset histogram
        }
        set args [list $counter(type) $counter(bucketsize)]
    }
    -timehist {
        foreach h [list counter::H-$tag counter::Hour-$tag counter::Day-$tag] {
        upvar #0 $h histogram
        if {[info exists histogram]} {
            unset histogram
        }
        }
        set args [list -timehist $counter::secsPerMinute]
    }
    default {#ignore}
    }
    unset counter
    eval {counter::init $tag} $args
    set counter(resetDate) [clock seconds]
    return ""
}

# ::counter::count --
#
#   Accumulate statistics.
#
# Arguments:
#   tag The counter identifier.
#   delta   The increment amount.  Defaults to 1.
#   arg For -group types, this is the histogram index.
#
# Results:
#   None
#
# Side Effects:
#   Accumlate statistics.

proc ::counter::count {tag {delta 1} args} {
    upvar #0 counter::T-$tag counter
    set counter(total) [expr {$counter(total) + $delta}]
    incr counter(N)

    # Instead of supporting a counter that could have multiple attributes,
    # we support a single type to make counting a skosh more efficient.

#    foreach option $counter(type) {
    switch -- $counter(type) {
        ""  {
        # Simple counter
        return
        }
        -group {
        upvar #0 counter::H-$tag histogram
        set subIndex [lindex $args 0]
        if {![info exists histogram($subIndex)]} {
            set histogram($subIndex) 0
        }
        set histogram($subIndex) [expr {$histogram($subIndex) + $delta}]
        }
        -lastn {
        upvar #0 counter::V-$tag vector
        set vector($counter(index)) $delta
        set counter(index) [expr {($counter(index) +1)%$counter(lastn)}]
        }
        -hist {
        upvar #0 counter::H-$tag histogram
        set bucket [expr {int($delta / $counter(bucketsize))}]
        if {![info exists histogram($bucket)]} {
            set histogram($bucket) 0
        }
        incr histogram($bucket)
        }
        -hist10x -
        -hist2x {
        upvar #0 counter::H-$tag histogram
        set bucket 0
        for {set max $counter(bucketsize)} {$delta > $max} \
            {set max [expr {$max * $counter(mult)}]} {
            incr bucket
        }
        if {![info exists histogram($bucket)]} {
            set histogram($bucket) 0
        }
        incr histogram($bucket)
        }
        -histlog {
        upvar #0 counter::H-$tag histogram
        set bucket [expr {int(log($delta)*$counter(bucketsize))}]
        if {![info exists histogram($bucket)]} {
            set histogram($bucket) 0
        }
        incr histogram($bucket)
        }
        -timehist {
        upvar #0 counter::H-$tag histogram
        variable minuteBase
        variable secsPerMinute

        set minute [expr {([clock seconds] - $minuteBase) / $secsPerMinute}]
        if {$minute > 59} {
            # this occurs while debugging if the process is
            # stopped at a breakpoint too long.
            set minute 59
        }

        # Initialize the current bucket and 
        # clear any buckets we've skipped since the last sample.
        
        if {$minute != $counter(lastMinute)} {
            set histogram($minute) 0
            for {set i [expr {$counter(lastMinute)+1}]} \
                {$i < $minute} \
                {incr i} {
            set histogram($i) 0
            }
            set counter(lastMinute) $minute
        }
        set histogram($minute) [expr {$histogram($minute) + $delta}]
        }
        default {#ignore}
    }
#   }
    return
}

# ::counter::exists --
#
#   Return true if the counter exists.
#
# Arguments:
#   tag The counter identifier.
#
# Results:
#   1 if it has been defined.
#
# Side Effects:
#   None.

proc ::counter::exists {tag} {
    upvar #0 counter::T-$tag counter
    return [info exists counter]
}

# ::counter::get --
#
#   Return statistics.
#
# Arguments:
#   tag The counter identifier.
#   option  What statistic to get
#   args    Needed by some options.
#
# Results:
#   With no args, just the counter value.
#
# Side Effects:
#   None.

proc ::counter::get {tag {option -total} args} {
    upvar #0 counter::T-$tag counter
    switch -- $option {
    -total {
        return $counter(total)
    }
    -totalVar {
        return ::counter::T-$tag\(total)
    }
    -N {
        return $counter(N)
    }
    -avg {
        if {$counter(N) == 0} {
        return 0
        } else {
        return [expr {$counter(total) / double($counter(N))}]
        }
    }
    -avgn {
        if {$counter(type) != "-lastn"} {
        return -code error "The -avgn option is only supported for -lastn counters."
        }
        upvar #0 counter::V-$tag vector
        set sum 0
        for {set i 0} {($i < $counter(N)) && ($i < $counter(lastn))} {incr i} {
        set sum [expr {$sum + $vector($i)}]
        }
        if {$i == 0} {
        return 0
        } else {
        return [expr {$sum / double($i)}]
        }
    }
    -hist {
        upvar #0 counter::H-$tag histogram
        if {[llength $args]} {
        # Return particular bucket
        set bucket [lindex $args 0]
        if {[info exists histogram($bucket)]} {
            return $histogram($bucket)
        } else {
            return 0
        }
        } else {
        # Dump the whole histogram

        set result {}
        if {$counter(type) == "-group"} {
            set sort -dictionary
        } else {
            set sort -integer
        }
        foreach x [lsort $sort [array names histogram]] {
            lappend result $x $histogram($x)
        }
        return $result
        }
    }
    -histVar {
        return ::counter::H-$tag
    }
    -histHour {
        upvar #0 counter::Hour-$tag histogram
        set result {}
        foreach x [lsort -integer [array names histogram]] {
        lappend result $x $histogram($x)
        }
        return $result
    }
    -histHourVar {
        return ::counter::Hour-$tag
    }
    -histDay {
        upvar #0 counter::Day-$tag histogram
        set result {}
        foreach x [lsort -integer [array names histogram]] {
        lappend result $x $histogram($x)
        }
        return $result
    }
    -histDayVar {
        return ::counter::Day-$tag
    }
    -maxPerMinute {
        return $counter(maxPerMinute)
    }
    -maxPerHour {
        return $counter(maxPerHour)
    }
    -maxPerDay {
        return $counter(maxPerDay)
    }
    -resetDate {
        if {[info exists counter(resetDate)]} {
        return $counter(resetDate)
        } else {
        return ""
        }
    }
    -all {
        return [array get counter]
    }
    default {
        return -code error "Invalid option $option.\
        Should be -all, -total, -N, -avg, -avgn, -hist, -histHour,\
        -histDay, -totalVar, -histVar, -histHourVar, -histDayVar -resetDate."
    }
    }
}

# ::counter::names --
#
#   Return the list of defined counters.
#
# Arguments:
#   none
#
# Results:
#   A list of counter tags.
#
# Side Effects:
#   None.

proc ::counter::names {} {
    set result {}
    foreach v [info vars ::counter::T-*] {
    if {[info exists $v]} {
        # Declared arrays might not exist, yet
        # strip prefix from name
        set v [string range $v [string length "::counter::T-"] end]
        lappend result $v
    }
    }
    return $result
}

# ::counter::MergeHour --
#
#   Sum the per-minute histogram into the next hourly bucket.
#   On 24-hour boundaries, sum the hourly buckets into the next day bucket.
#   This operates on all time-based histograms.
#
# Arguments:
#   none
#
# Results:
#   none
#
# Side Effects:
#   See description.

proc ::counter::MergeHour {interval} {
    variable hourIndex
    variable minuteBase
    variable hourBase
    variable tagsToMerge
    variable secsPerMinute

    after $interval [list counter::MergeHour $interval]
    if {![info exists hourBase] || $hourIndex == 0} {
    set hourBase $minuteBase
    }
    set minuteBase [clock seconds]

    foreach tag $tagsToMerge {
    upvar #0 counter::T-$tag counter
    upvar #0 counter::H-$tag histogram
    upvar #0 counter::Hour-$tag hourhist

    # Clear any buckets we've skipped since the last sample.

    for {set i [expr {$counter(lastMinute)+1}]} {$i < 60} {incr i} {
        set histogram($i) 0
    }
    set counter(lastMinute) -1

    # Accumulate into the next hour bucket.

    set hourhist($hourIndex) 0
    set max 0
    foreach i [array names histogram] {
        set hourhist($hourIndex) [expr {$hourhist($hourIndex) + $histogram($i)}]
        if {$histogram($i) > $max} {
        set max $histogram($i)
        }
    }
    set perSec [expr {$max / $secsPerMinute}]
    if {$perSec > $counter(maxPerMinute)} {
        set counter(maxPerMinute) $perSec
    }
    }
    set hourIndex [expr {($hourIndex + 1) % 24}]
    if {$hourIndex == 0} {
    counter::MergeDay
    }

}
# ::counter::MergeDay --
#
#   Sum the per-minute histogram into the next hourly bucket.
#   On 24-hour boundaries, sum the hourly buckets into the next day bucket.
#   This operates on all time-based histograms.
#
# Arguments:
#   none
#
# Results:
#   none
#
# Side Effects:
#   See description.

proc ::counter::MergeDay {} {
    variable dayIndex
    variable dayBase
    variable hourBase
    variable tagsToMerge
    variable secsPerMinute

    # Save the hours histogram into a bucket for the last day
    # counter(day,$day) is the starting time for that day bucket

    if {![info exists dayBase]} {
    set dayBase $hourBase
    }
    foreach tag $tagsToMerge {
    upvar #0 counter::T-$tag counter
    upvar #0 counter::Day-$tag dayhist
    upvar #0 counter::Hour-$tag hourhist
    set dayhist($dayIndex) 0
    set max 0
    for {set i 0} {$i < 24} {incr i} {
        if {[info exists hourhist($i)]} {
        set dayhist($dayIndex) [expr {$dayhist($dayIndex) + $hourhist($i)}]
        if {$hourhist($i) > $max} { 
            set max $hourhist($i) 
        }
        }
    }
    set perSec [expr {double($max) / ($secsPerMinute * 60)}]
    if {$perSec > $counter(maxPerHour)} {
        set counter(maxPerHour) $perSec
    }
    }
    set perSec [expr {double($dayhist($dayIndex)) / ($secsPerMinute * 60 * 24)}]
    if {$perSec > $counter(maxPerDay)} {
    set counter(maxPerDay) $perSec
    }
    incr dayIndex
}

# ::counter::histHtmlDisplay --
#
#   Create an html display of the histogram.
#
# Arguments:
#   tag The counter tag
#   args    option, value pairs that affect the display:
#       -title  Label to display above bar chart
#       -unit   minutes, hours, or days select time-base histograms.
#           Specify anything else for value-based histograms.
#       -images URL of /images directory.
#       -gif    Image for normal histogram bars
#       -ongif  Image for the active histogram bar
#       -max    Maximum number of value-based buckets to display
#       -height Pixel height of the highest bar
#       -width  Pixel width of each bar
#       -skip   Buckets to skip when labeling value-based histograms
#       -format Format used to display labels of buckets.
#       -text   If 1, a text version of the histogram is dumped,
#           otherwise a graphical one is generated.
#
# Results:
#   HTML for the display as a complete table.
#
# Side Effects:
#   None.

proc ::counter::histHtmlDisplay {tag args} {
    append result "<p>\n<table border=0 cellpadding=0 cellspacing=0>\n"
    append result [eval {counter::histHtmlDisplayRow $tag} $args]
    append result </table>
    return $result
}

# ::counter::histHtmlDisplayRow --
#
#   Create an html display of the histogram.
#
# Arguments:
#   See counter::histHtmlDisplay
#
# Results:
#   HTML for the display.  Ths is one row of a 2-column table,
#   the calling page must define the <table> tag.
#
# Side Effects:
#   None.

proc ::counter::histHtmlDisplayRow {tag args} {
    upvar #0 counter::T-$tag counter
    variable secsPerMinute
    variable minuteBase
    variable hourBase
    variable dayBase
    variable hourIndex
    variable dayIndex

    array set options [list \
    -title  $tag \
    -unit   "" \
    -images /images \
    -gif    Blue.gif \
    -ongif  Red.gif \
    -max    -1 \
    -height 100 \
    -width  4 \
    -skip   4 \
    -format %.2f \
    -text   0
    ]
    array set options $args

    # Support for self-posting pages that can clear counters.

    append result "<!-- resetCounter [ncgi::value resetCounter] -->"
    if {[ncgi::value resetCounter] == $tag} {
    counter::reset $tag
    return "<!-- Reset $tag counter -->"
    }

    switch -glob -- $options(-unit) {
    min* {
        upvar #0 counter::H-$tag histogram
        set histname counter::H-$tag
        if {![info exists minuteBase]} {
        return "<!-- No time-based histograms defined -->"
        }
        set time $minuteBase
        set secsForMax $secsPerMinute
        set periodMax $counter(maxPerMinute)
        set curIndex [expr {([clock seconds] - $minuteBase) / $secsPerMinute}]
        set options(-max) 60
        set options(-min) 0
    }
    hour* {
        upvar #0 counter::Hour-$tag histogram
        set histname counter::Hour-$tag
        if {![info exists hourBase]} {
        return "<!-- Hour merge has not occurred -->"
        }
        set time $hourBase
        set secsForMax [expr {$secsPerMinute * 60}]
        set periodMax $counter(maxPerHour)
        set curIndex [expr {$hourIndex - 1}]
        if {$curIndex < 0} {
        set curIndex 23
        }
        set options(-max) 24
        set options(-min) 0
    }
    day* {
        upvar #0 counter::Day-$tag histogram
        set histname counter::Day-$tag
        if {![info exists dayBase]} {
        return "<!-- Hour merge has not occurred -->"
        }
        set time $dayBase
        set secsForMax [expr {$secsPerMinute * 60 * 24}]
        set periodMax $counter(maxPerDay)
        set curIndex dayIndex
        set options(-max) $dayIndex
        set options(-min) 0
    }
    default {
        # Value-based histogram with arbitrary units.

        upvar #0 counter::H-$tag histogram
        set histname counter::H-$tag

        set unit $options(-unit)
        set curIndex ""
        set time ""
    }
    }
    if {! [info exists histogram]} {
    return "<!-- $histname doesn't exist -->\n"
    }

    set max 0
    set maxName 0
    foreach {name value} [array get histogram] {
    if {$value > $max} {
        set max $value
        set maxName $name
    }
    }

    # Start 2-column HTML display.  A summary table at the left, the histogram on the right.

    append result "<tr><td valign=top>\n"

    append result "<table bgcolor=#EEEEEE>\n"
    append result "<tr><td colspan=2 align=center>[html::font]<b>$options(-title)</b></font></td></tr>\n"
    append result "<tr><td>[html::font]<b>Total</b></font></td>"
    append result "<td>[html::font][format $options(-format) $counter(total)]</font></td></tr>\n"

    if {[info exists secsForMax]} {

    # Time-base histogram

    set string {}
    set t $secsForMax
    set days [expr {$t / (60 * 60 * 24)}]
    if {$days == 1} {
        append string "1 Day "
    } elseif {$days > 1} {
        append string "$days Days "
    }
    set t [expr {$t - $days * (60 * 60 * 24)}]
    set hours [expr {$t / (60 * 60)}]
    if {$hours == 1} {
        append string "1 Hour "
    } elseif {$hours > 1} {
        append string "$hours Hours "
    }
    set t [expr {$t - $hours * (60 * 60)}]
    set mins [expr {$t / 60}]
    if {$mins == 1} {
        append string "1 Minute "
    } elseif {$mins > 1} {
        append string "$mins Minutes "
    }
    set t [expr {$t - $mins * 60}]
    if {$t == 1} {
        append string "1 Second "
    } elseif {$t > 1} {
        append string "$t Seconds "
    }
    append result "<tr><td>[html::font]<b>Bucket Size</b></font></td>"
    append result "<td>[html::font]$string</font></td></tr>\n"

    append result "<tr><td>[html::font]<b>Max Per Sec</b></font></td>"
    append result "<td>[html::font][format %.2f [expr {$max/double($secsForMax)}]]</font></td></tr>\n"

    if {$periodMax > 0} {
        append result "<tr><td>[html::font]<b>Best Per Sec</b></font></td>"
        append result "<td>[html::font][format %.2f $periodMax]</font></td></tr>\n"
    }
    append result "<tr><td>[html::font]<b>Starting Time</b></font></td>"
    switch -glob -- $options(-unit) {
        min* {
        append result "<td>[html::font][clock format $time \
            -format %k:%M:%S]</font></td></tr>\n"
        }
        hour* {
        append result "<td>[html::font][clock format $time \
            -format %k:%M:%S]</font></td></tr>\n"
        }
        day* {
        append result "<td>[html::font][clock format $time \
            -format "%b %d %k:%M"]</font></td></tr>\n"
        }
        default {#ignore}
    }

    } else {

    # Value-base histogram

    set ix [lsort -integer [array names histogram]]

    set mode [expr {$counter(bucketsize) * $maxName}]
    set first [expr {$counter(bucketsize) * [lindex $ix 0]}]
    set last [expr {$counter(bucketsize) * [lindex $ix end]}]

    append result "<tr><td>[html::font]<b>Average</b></font></td>"
    append result "<td>[html::font][format $options(-format) [counter::get $tag -avg]]</font></td></tr>\n"

    append result "<tr><td>[html::font]<b>Mode</b></font></td>"
    append result "<td>[html::font]$mode</font></td></tr>\n"

    append result "<tr><td>[html::font]<b>Minimum</b></font></td>"
    append result "<td>[html::font]$first</font></td></tr>\n"

    append result "<tr><td>[html::font]<b>Maximum</b></font></td>"
    append result "<td>[html::font]$last</font></td></tr>\n"

    append result "<tr><td>[html::font]<b>Unit</b></font></td>"
    append result "<td>[html::font]$unit</font></td></tr>\n"

    append result "<tr><td colspan=2 align=center>[html::font]<b>"
    append result "<a href=[ncgi::urlStub]?resetCounter=$tag>Reset</a></td></tr>\n"

    if {$options(-max) < 0} {
        set options(-max) [lindex $ix end]
    }
    if {![info exists options(-min)]} {
        set options(-min) [lindex $ix 0]
    }
    }

    # End table nested inside left-hand column

    append result </table>\n
    append result </td>\n
    append result "<td valign=bottom>\n"


    # Display the histogram

    if {$options(-text)} {
    } else {
    append result [eval \
        {counter::histHtmlDisplayBarChart $tag histogram $max $curIndex $time} \
        [array get options]]
    }

    # Close the right hand column, but leave our caller's table open.

    append result </td></tr>\n

    return $result
}

# ::counter::histHtmlDisplayBarChart --
#
#   Create an html display of the histogram.
#
# Arguments:
#   tag     The counter tag.
#   histVar     The name of the histogram array
#   max     The maximum counter value in a histogram bucket.
#   curIndex    The "current" histogram index, for time-base histograms.
#   time        The base, or starting time, for the time-based histograms.
#   args        The array get of the options passed into histHtmlDisplay
#
# Results:
#   HTML for the bar chart.
#
# Side Effects:
#   See description.

proc ::counter::histHtmlDisplayBarChart {tag histVar max curIndex time args} {
    upvar #0 counter::T-$tag counter
    upvar 1 $histVar histogram
    variable secsPerMinute
    array set options $args

    append result "<table cellpadding=0 cellspacing=0 bgcolor=#eeeeee><tr>\n"

    set ix [lsort -integer [array names histogram]]

    for {set t $options(-min)} {$t < $options(-max)} {incr t} {
    if {![info exists histogram($t)]} {
        set value 0
    } else {
        set value $histogram($t)
    }
    if {$max == 0 || $value == 0} {
        set height 1
    } else {
        set percent [expr {round($value * 100.0 / $max)}]
        set height [expr {$percent * $options(-height) / 100}]
    }
    if {$t == $curIndex} {
        set img src=$options(-images)/$options(-ongif)
    } else {
        set img src=$options(-images)/$options(-gif)
    }
    append result "<td valign=bottom><img $img height=$height\
        width=$options(-width) title=$value alt=$value></td>\n"
    }
    append result "</tr>"

    # Count buckets outside the range requested

    set overflow 0
    set underflow 0
    foreach t [lsort -integer [array names histogram]] {
    if {($options(-max) > 0) && ($t > $options(-max))} {
        incr overflow
    }
    if {($options(-min) >= 0) && ($t < $options(-min))} {
        incr underflow
    }
    }

    # Append a row of labels at the bottom.

    set colors {black #CCCCCC}
    set bgcolors {#CCCCCC black}
    set colori 0
    if {$counter(type) != "-timehist"} {

    # Label each bucket with its value
    # This is probably wrong for hist2x and hist10x

    append result "<tr>"
    set skip $options(-skip)
    if {![info exists counter(mult)]} {
        set counter(mult) 1
    }

    # These are tick marks

    set img src=$options(-images)/$options(-gif)
    append result "<tr>"
    for {set i $options(-min)} {$i < $options(-max)} {incr i} {
        if {(($i % $skip) == 0)} {
        append result "<td valign=bottom><img $img height=3 \
            width=1></td>\n"
        } else {
        append result "<td valign=bottom></td>"
        }
    }
    append result </tr>

    # These are the labels

    append result "<tr>"
    for {set i $options(-min)} {$i < $options(-max)} {incr i} {
        if {$counter(type) == "-histlog"} {
        if {[catch {expr {int(log($i) * $counter(bucketsize))}} x]} {
            # Out-of-bounds
            break
        }
        } else {
        set x [expr {$i * $counter(bucketsize) * $counter(mult)}]
        }
        set label [format $options(-format) $x]
        if {(($i % $skip) == 0)} {
        set color [lindex $colors $colori]
        set bg [lindex $bgcolors $colori]
        set colori [expr {($colori+1) % 2}]
        append result "<td colspan=$skip><font size=1 color=$color>$label</font></td>"
        }
    }
    append result </tr>
    } else {
    switch -glob -- $options(-unit) {
        min*    {
        if {$secsPerMinute != 60} {
            set format %k:%M:%S
            set skip 12
        } else {
            set format %k:%M
            set skip 4
        }
        set deltaT $secsPerMinute
        set wrapDeltaT [expr {$secsPerMinute * -59}]
        }
        hour*   {
        if {$secsPerMinute != 60} {
            set format %k:%M
            set skip 4
        } else {
            set format %k
            set skip 2
        }
        set deltaT [expr {$secsPerMinute * 60}]
        set wrapDeltaT [expr {$secsPerMinute * 60 * -23}]
        }
        day* {
        if {$secsPerMinute != 60} {
            set format "%m/%d %k:%M"
            set skip 10
        } else {
            set format %k
            set skip $options(-skip)
        }
        set deltaT [expr {$secsPerMinute * 60 * 24}]
        set wrapDeltaT 0
        }
        default {#ignore}
    }
    # These are tick marks

    set img src=$options(-images)/$options(-gif)
    append result "<tr>"
    foreach t [lsort -integer [array names histogram]] {
        if {(($t % $skip) == 0)} {
        append result "<td valign=bottom><img $img height=3 \
            width=1></td>\n"
        } else {
        append result "<td valign=bottom></td>"
        }
    }
    append result </tr>

    set lastLabel ""
    append result "<tr>"
    foreach t [lsort -integer [array names histogram]] {

        # Label each bucket with its time

        set label [clock format $time -format $format]
        if {(($t % $skip) == 0) && ($label != $lastLabel)} {
        set color [lindex $colors $colori]
        set bg [lindex $bgcolors $colori]
        set colori [expr {($colori+1) % 2}]
        append result "<td colspan=$skip><font size=1 color=$color>$label</font></td>"
        set lastLabel $label
        }
        if {$t == $curIndex} {
        incr time $wrapDeltaT
        } else {
        incr time $deltaT
        }
    }
    append result </tr>\n
    }
    append result "</table>"
    if {$underflow > 0} {
    append result "<br>Skipped $underflow samples <\
        [expr {$options(-min) * $counter(bucketsize)}]\n"
    }
    if {$overflow > 0} {
    append result "<br>Skipped $overflow samples >\
        [expr {$options(-max) * $counter(bucketsize)}]\n"
    }
    return $result
}

# ::counter::start --
#
#   Start an inter