KitCreator
Check-in [5613f08f7e]
Login
HomeDownloadsSource CodeTicketsWiki
Overview
Comment:Added basic web interface
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA1: 5613f08f7e6941cfbef13ddc443652819700250c
User & Date: rkeene on 2014-07-19 06:59:18
Other Links: manifest | tags
Context
2014-07-19
07:07
Updated web UI check-in: e9692813d7 user: rkeene tags: trunk
06:59
Added basic web interface check-in: 5613f08f7e user: rkeene tags: trunk
2014-07-10
16:56
Added EOF fixes for TLS package check-in: 91e419adbd user: rkeene tags: trunk
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Modified .fossil-settings/ignore-glob from [2c3e9f6547] to [5261fbbc36]. 

1
2



3
4
5
6
7
8
9

build/test/kits
build/test/kits/*



itcl/build
itcl/build/*
itcl/build.log
itcl/inst
itcl/inst/*
itcl/out
itcl/out/*



>
>
>








1
2
3
4
5
6
7
8
9
10
11
12

build/test/kits
build/test/kits/*
build/web/queue
build/web/kitcreator.cgi
build/web/kitcreator.kit
itcl/build
itcl/build/*
itcl/build.log
itcl/inst
itcl/inst/*
itcl/out
itcl/out/*
︙︙
89
90
91
92
93
94
95









96
97
98
99
100
101
102

tcc4tcl/build.log
tcc4tcl/inst
tcc4tcl/inst/*
tcc4tcl/out
tcc4tcl/out/*
tcc4tcl/src
tcc4tcl/src/*









kitdll/buildsrc/kitdll-0.0/starpack.vfs
kitdll/buildsrc/kitdll-0.0/starpack.vfs/*
kitdll/buildsrc/kitdll-0.0/test
kitdll/buildsrc/kitdll-0.0/configure
kitdll/buildsrc/kitdll-0.0/libtcl*.so
kitdll/buildsrc/kitdll-0.0/Makefile
kitdll/buildsrc/kitdll-0.0/*.o








>
>
>
>
>
>
>
>
>








92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114

tcc4tcl/build.log
tcc4tcl/inst
tcc4tcl/inst/*
tcc4tcl/out
tcc4tcl/out/*
tcc4tcl/src
tcc4tcl/src/*
tls/build
tls/build/*
tls/build.log
tls/inst
tls/inst/*
tls/out
tls/out/*
tls/src
tls/src/*
kitdll/buildsrc/kitdll-0.0/starpack.vfs
kitdll/buildsrc/kitdll-0.0/starpack.vfs/*
kitdll/buildsrc/kitdll-0.0/test
kitdll/buildsrc/kitdll-0.0/configure
kitdll/buildsrc/kitdll-0.0/libtcl*.so
kitdll/buildsrc/kitdll-0.0/Makefile
kitdll/buildsrc/kitdll-0.0/*.o
︙︙

Modified build/web/Makefile from [a7224e283a] to [ee429274c4]. 

1
2


3
4
5
6
7
8
9






10
11
12
13
14
15

STARKIT2EXE = ../../../starkit2exe/starkit2exe
RIVET2STARKIT = ../../../rivet/bin/rivet2starkit



kitcreator.cgi: kitcreator.kit
	$(STARKIT2EXE) kitcreator.kit kitcreator.cgi

kitcreator.kit: kitcreator.vfs kitcreator.vfs/index.rvt
	$(RIVET2STARKIT) tclkit kitcreator.kit kitcreator.vfs







clean:
	rm -f kitcreator.kit kitcreator.cgi

distclean: clean

.PHONY: clean distclean



>
>







>
>
>
>
>
>





|

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23

STARKIT2EXE = ../../../starkit2exe/starkit2exe
RIVET2STARKIT = ../../../rivet/bin/rivet2starkit
WEBDIR = /web/customers/kitcreator.rkeene.org
WEBKITSDIR = $(WEBDIR)/kits

kitcreator.cgi: kitcreator.kit
	$(STARKIT2EXE) kitcreator.kit kitcreator.cgi

kitcreator.kit: kitcreator.vfs kitcreator.vfs/index.rvt
	$(RIVET2STARKIT) tclkit kitcreator.kit kitcreator.vfs

install: kitcreator.cgi building.cgi
	mkdir -p '$(WEBDIR)' '$(WEBKITSDIR)'
	cp kitcreator.cgi '$(WEBDIR)/'
	cp building.cgi '$(WEBKITSDIR)/'
	echo -n > '${WEBKITSDIR}/index.html'

clean:
	rm -f kitcreator.kit kitcreator.cgi

distclean: clean

.PHONY: clean distclean install

Added build/web/building.cgi version [df00af4fd1]. 



































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>

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

#! /usr/bin/env tclsh

set outdir "/web/customers/kitcreator.rkeene.org/kits"
set key ""
if {[info exists ::env(PATH_INFO)]} {
	set key [lindex [split $::env(PATH_INFO) "/"] 1]
}

set status "Unknown"
set terminal 0
if {![regexp {^[0-9a-f]+$} $key]} {
	set status "Invalid Key"

	unset key
}

if {[info exists key]} {
	set workdir [file join $outdir $key]
}

if {[info exists workdir]} {
	if {[file exists $workdir]} {
		set fd [open [file join $workdir filename]]
		set filename [gets $fd]
		close $fd

		set outfile [file join $workdir $filename]
	} else {
		set status "Queued"
	}
}

if {[info exists outfile]} {
	if {[file exists $outfile]} {
		set status "Complete"

		set url "http://kitcreator.rkeene.org/kits/$key/$filename"
	} elseif {[file exists "${outfile}.buildfail"]} {
		set status "Failed"

		set terminal 1
	} else {
		set status "Building"
	}
}

puts "Content-Type: text/html"
if {[info exists url]} {
	puts "Location: $url"
} else {
	if {!$terminal} {
		puts "Refresh: 30;url=."
	}
}
puts ""
puts "<html>"
puts "\t<head>"
puts "\t\t<title>KitCreator, Web Interface</title>"
puts "\t</head>"
puts "\t<body>"
puts "\t\t<h1>KitCreator Web Interface</h1>"
puts "\t\t<p><b>Status:</b> $status</p>"
puts "\t</body>"
puts "</html>"

Modified build/web/kitcreator.vfs/index.rvt from [aaeb907791] to [0b791688aa]. 

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

<?




	set sourcedir "/web/rkeene/devel/kitcreator/all"



	foreach file [glob -tails -nocomplain -directory $sourcedir "kitcreator-*.tar.gz"] {
		regexp {^kitcreator-(.*).tar.gz$} $file -> vers
		set kitcreator_versions($vers) $vers
	}
	set kitcreator_version_selected [lindex [lsort -dictionary [array names kitcreator_versions]] end]

	set kitcreator_versions(trunk) "Fossil Trunk Tip"

	set tcl_versions(8.4.19) 8.4.19
	set tcl_versions(8.5.9) 8.5.9
	set tcl_versions(cvs_HEAD) "Fossil Trunk Tip"




	set platforms(linux-x86) "Linux on x86"
	set platforms(linux-amd64) "Linux on amd64"

	set platforms(linux-mipsel) "Linux on MIPSEL"






	set platforms(windows-x86) "Windows on x86"









	set disable {
		platform linux-amd64 tk
		platform linux-mipsel tk





	}

	set specific {
		platform windows-x86 file icon {Kit Icon}
		platform windows-x86 text description {Description}


	}















































































































?><html>
  <head>
    <title>KitCreator, Web Interface</title>











    <script>
<!--















	function verifyOptions() {
		var kitcreator_version;
		var tcl_version;
		var platform;

		kitcreator_version = document.getElementsByName('kitcreator_version')[0].value;
		tcl_version = document.getElementsByName('tcl_version')[0].value;
		platform = document.getElementsByName('platform')[0].value;

























	}
-->
    </script>
  </head>
  <body>
    <h1>KitCreator Web Interface</h1>
    <form method="post" enctype="multipart/form-data">
      <table>
        <tr>
          <td>KitCreator Version:</td>
          <td>
            <select name="kitcreator_version" onChange="verifyOptions();">


>
>
>
>

>
>
>








|
|
|

>
>
>
|
|
>
|
>
>
>
>
>
>
|
>

>
>
>
>
>
>
>

|
|
>
>
>
>
>



|
|
>
>

>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>

|
|
>
>
>
>
>
>
>
>
>
>
>


>
>
>
>
>
>
>
>
>
>
>
>
>
>
>









>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>




|








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

<?
	package require sha1

	load_response args

	set sourcedir "/web/rkeene/devel/kitcreator/all"
	set queue "/home/rkeene/devel/kitcreator/build/web/queue"
	set secretfile "/home/rkeene/etc/kitcreator-web-secret"

	foreach file [glob -tails -nocomplain -directory $sourcedir "kitcreator-*.tar.gz"] {
		regexp {^kitcreator-(.*).tar.gz$} $file -> vers
		set kitcreator_versions($vers) $vers
	}
	set kitcreator_version_selected [lindex [lsort -dictionary [array names kitcreator_versions]] end]

	set kitcreator_versions(trunk) "Fossil Trunk Tip"

	set tcl_versions(8.5.15) 8.5.15
	set tcl_versions(8.6.1) 8.6.1
	set tcl_versions(fossil_trunk) "Fossil Trunk Tip"

	set platforms(android-arm) "Android/ARM"
	set platforms(freebsd-amd64) "FreeBSD/amd64"
	set platforms(hpux-hppa64) "HP-UX/PA-RISC 2.0"
	set platforms(linux-amd64) "Linux/amd64"
	set platforms(linux-arm) "Linux/ARM"
	set platforms(linux-i386) "Linux/i386"
	set platforms(linux-mipsel) "Linux/MIPS"
	set platforms(netbsd-amd64) "NetBSD/amd64"
	set platforms(netbsd-i386) "NetBSD/i386"
	set platforms(solaris-amd64) "Solaris/amd64"
	set platforms(solaris-i386) "Solaris/i386"
	set platforms(solaris-sparc) "Solaris/SPARC"
	set platforms(solaris-sparc64) "Solaris/SPARC64"
	set platforms(win32) "Windows/i386"
	set platforms(win64) "Windows/amd64"

	set packages(tk) "Tk"
	set packages(mk4tcl) "Metakit"
	set packages(tcc4tcl) "tcc4tcl"
	set packages(tls) TLS
	set packages(dbus) D-BUS
	set packages(tclx) TclX

	set disable {
		platform linux-mipsel {tk tcc4tcl}
		platform android-arm tk
		platform netbsd-amd64 {tk tcc4tcl}
		platform netbsd-i386 {tk tcc4tcl}
		platform solaris-sparc tcc4tcl
		platform solaris-sparc64 tcc4tcl
		platform hpux-hppa64 tcc4tcl
	}

	set specific {
		platform win32 file icon {Kit Icon}
		platform win32 text description {Description}
		platform win64 file icon {Kit Icon}
		platform win64 text description {Description}
	}

	if {[info exists args(platform)] && [info exists args(tcl_version)] && [info exist args(kitcreator_version)]} {
		# Read in arguments
		## Mandatory arguments
		set build_platform $args(platform)
		set build_tcl_version $args(tcl_version)
		set build_kitcreator_version $args(kitcreator_version)

		## Optional Arguments
		set build_packages [list]
		set build_options(threaded) 0
		set build_options(kitdll) 0
		foreach arg [array names args] {
			switch -glob -- $arg {
				"option_package_*" {
					set package [join [lrange [split $arg _] 2 end] _]

					lappend build_packages $package
				}
				"option_threaded" {
					set build_options(threaded) 1
				}
				"option_kitdll" {
					set build_options(kitdll) 1
				}
			}
		}
		set build_packages [lsort -dictionary $build_packages]

		# Validate arguments
		if {![info exists platforms($build_platform)]} {
			unset build_platform
		}

		if {![info exists tcl_versions($build_tcl_version)]} {
			unset build_tcl_version
		}

		if {![info exists kitcreator_versions($build_kitcreator_version)]} {
			unset build_kitcreator_version
		}

		foreach package $build_packages {
			if {![info exists packages($package)]} {
				unset build_packages

				break
			}
		}

		# Resolve version numbers to checkin IDs
		## XXX: TODO
		set cache_tcl_version $build_tcl_version
		if {$build_tcl_version == "fossil_trunk"} {
			set cache_tcl_version [clock seconds]
		}

		set cache_kitcreator_version $build_kitcreator_version
		if {$build_kitcreator_version == "trunk"} {
			set cache_kitcreator_version [clock seconds]
		}

		# Generate a serialized hash that represents the state of the build
		## Load a secret so keys cannot be pre-computed (but remain consistent)
		set secretfd [open $secretfile "r"]
		set secret [gets $secretfd]
		close $secretfd

		## Compute basic key	
		set key [list $secret $build_platform $cache_tcl_version $cache_kitcreator_version $build_packages]

		## Update key with options in deterministic order
		foreach option [lsort -dictionary [array names build_options]] {
			lappend key [list "option:$option" $build_options($option)]
		}

		## Convert key to a user-consumable string via hashing
		set key [string tolower [sha1::sha1 -hex $key]]

		# Determine filename
		if {$build_options(kitdll)} {
			set extension "so"
			switch -- $build_platform {
				"win32" - "win64" {
					set extension "dll"
				}
				"hpux-hppa64" {
					set extension "sl"
				}
			}

			## XXX: TODO: The version here needs to match what's in the SONAME
			set filename "libtclkit[string map [list "." ""] ${cache_tcl_version}].${extension}"
		} else {
			set filename "tclkit"

			switch -- $build_platform {
				"win32" - "win64" {
					append filename ".exe"
				}
			}
		}

		# Queue build up and wait for it to complete
		set fd [open $queue a+]
		puts $fd [list filename $filename key $key platform $build_platform tcl_version $build_tcl_version kitcreator_version $build_kitcreator_version packages $build_packages options [array get build_options]]
		close $fd

		set url "http://kitcreator.rkeene.org/kits/building/$key/"

		headers redirect $url
?><html>
	<head>
		<title>KitCreator, Web Interface</title>
	</head>
	<body>
		<h1>KitCreator Web Interface</h1>
		<p>Build in progress, output will be: <a href="<? puts -nonewline $url ?>"><? puts -nonewline $url ?></a></p>
	</body>
</html>
<?
	} else {
?><html>
  <head>
    <title>KitCreator, Web Interface</title>
    <script>
<!--
	function enablePackage(package) {
		var obj;

		obj = document.getElementById('option_package_' + package);
		obj.disabled = false;
	}

	function disablePackage(package) {
		var obj;

		obj = document.getElementById('option_package_' + package);
		obj.checked = false;
		obj.disabled = true;
	}

	function verifyOptions() {
		var kitcreator_version;
		var tcl_version;
		var platform;

		kitcreator_version = document.getElementsByName('kitcreator_version')[0].value;
		tcl_version = document.getElementsByName('tcl_version')[0].value;
		platform = document.getElementsByName('platform')[0].value;

<?
		set alldisabledpackages [list]
		foreach {keyword value disablepackages} $disable {
			foreach package $disablepackages {
				if {[lsearch -exact $alldisabledpackages $package] == -1} {
					lappend alldisabledpackages $package
				}
			}
		}

		foreach package $alldisabledpackages {
			puts "\t\tenablePackage(\"$package\");"
		}

		foreach {keyword value disablepackages} $disable {
			puts "\t\tif ($keyword == \"$value\") \{"

			foreach package $disablepackages {
				puts "\t\t\tdisablePackage(\"$package\");"
			}

			puts "\t\t\}"
		}
?>
	}
-->
    </script>
  </head>
  <body onLoad="verifyOptions();">
    <h1>KitCreator Web Interface</h1>
    <form method="post" enctype="multipart/form-data">
      <table>
        <tr>
          <td>KitCreator Version:</td>
          <td>
            <select name="kitcreator_version" onChange="verifyOptions();">
︙︙
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

?>
            </select>
          </td>
        </tr>
        <tr>
          <td>Kit Options:</td>
          <td>
            <input type="checkbox" name="option_package_tk">Tk<br>
            <input type="checkbox" name="option_package_itcl">[incr Tcl]<br>
            <input type="checkbox" name="option_package_mk4tcl">Metakit<br>
            <input type="checkbox" name="option_threaded">Threaded<br>
            <input type="checkbox" name="option_kitdll">Build Library (KitDLL)<br>
          </td>
        </tr>
        <tr>
          <td>Kit Icon:</td>
          <td>
            <input type="file" name="platform-windows-x86-icon">
          </td>
        </tr>
        <tr>
          <td>Description:</td>
          <td>
            <input type="text" name="platform-windows-x86-desc">
          </td>
        </tr>
      </table>
      <input type="submit" name="submit" value="Create">
    </form>
  </body>
</html>








|
|
|
|
|





|





|






|

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

?>
            </select>
          </td>
        </tr>
        <tr>
          <td>Kit Options:</td>
          <td>
<?  foreach package [lsort -dictionary [array names packages]] { ?>
            <input type="checkbox" name="option_package_<? puts -nonewline $package ?>" id="option_package_<? puts -nonewline $package ?>">Package: <? puts -nonewline $packages($package) ?><br>
<? } ?>
            <input type="checkbox" name="option_threaded">Kit: Threaded<br>
            <input type="checkbox" name="option_kitdll">Kit: Build Library (KitDLL)<br>
          </td>
        </tr>
        <tr>
          <td>Kit Icon:</td>
          <td>
            <input type="file" name="option_icon">
          </td>
        </tr>
        <tr>
          <td>Description:</td>
          <td>
            <input type="text" name="option_desc">
          </td>
        </tr>
      </table>
      <input type="submit" name="submit" value="Create">
    </form>
  </body>
</html><? } ?>

Added build/web/kitcreator.vfs/lib/.htaccess version [30ceba8f4e]. 





>

1

Deny from all

Added build/web/kitcreator.vfs/lib/sha1-2.0.3/pkgIndex.tcl version [6f6c09ab55]. 





>

1

package ifneeded sha1 2.0.3 [list source [file join $dir sha1.tcl]]

Added build/web/kitcreator.vfs/lib/sha1-2.0.3/sha1.tcl version [778d9b332e]. 

























































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>

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

# sha1.tcl - 

# @@ Meta Begin
# Package sha1 2.0.3
# Meta platform           tcl
# Meta rsk::build::date   2011-03-30
# Meta description        Part of the Tclib sha1 module
# Meta require            {Tcl 8.2}
# @@ Meta End

#
# Copyright (C) 2001 Don Libes <libes@nist.gov>
# Copyright (C) 2003 Pat Thoyts <patthoyts@users.sourceforge.net>
#
# SHA1 defined by FIPS 180-1, "The SHA1 Message-Digest Algorithm"
# HMAC defined by RFC 2104, "Keyed-Hashing for Message Authentication"
#
# This is an implementation of SHA1 based upon the example code given in
# FIPS 180-1 and upon the tcllib MD4 implementation and taking some ideas
# and methods from the earlier tcllib sha1 version by Don Libes.
#
# This implementation permits incremental updating of the hash and 
# provides support for external compiled implementations either using
# critcl (sha1c) or Trf.
#
# ref: http://www.itl.nist.gov/fipspubs/fip180-1.htm
#
# -------------------------------------------------------------------------
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# -------------------------------------------------------------------------
#
# $Id: sha1.tcl,v 1.22 2009/05/07 00:35:10 patthoyts Exp $

# @mdgen EXCLUDE: sha1c.tcl

package require Tcl 8.2;                # tcl minimum version

namespace eval ::sha1 {
    variable  version 2.0.3
    variable  rcsid {$Id: sha1.tcl,v 1.22 2009/05/07 00:35:10 patthoyts Exp $}

    variable  accel
    array set accel {tcl 0 critcl 0 cryptkit 0 trf 0}
    variable  loaded {}
    variable  active
    array set active {tcl 0 critcl 0 cryptkit 0 trf 0}

    namespace export sha1 hmac SHA1Init SHA1Update SHA1Final

    variable uid
    if {![info exists uid]} {
        set uid 0
    }
}

# -------------------------------------------------------------------------
# Management of sha1 implementations.

# 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 ::sha1::LoadAccelerator {name} {
    variable accel
    set r 0
    switch -exact -- $name {
        tcl {
            # Already present (this file)
            set r 1
        }
        critcl {
            if {![catch {package require tcllibc}]
                || ![catch {package require sha1c}]} {
                set r [expr {[info command ::sha1::sha1c] != {}}]
            }
        }
        cryptkit {
            if {![catch {package require cryptkit}]} {
                set r [expr {![catch {cryptkit::cryptInit}]}]
            }
        }
        trf {
            if {![catch {package require Trf}]} {
                set r [expr {![catch {::sha1 aa} msg]}]
            }
        }
        default {
            return -code error "invalid accelerator $key:\
                must be one of [join [KnownImplementations] {, }]"
        }
    }
    set accel($name) $r
    return $r
}

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

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

# ::sha1::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 ::sha1::KnownImplementations {} {
    return {critcl cryptkit trf tcl}
}

proc ::sha1::Names {} {
    return {
	critcl   {tcllibc based}
        cryptkit {cryptkit based}
        trf      {Trf based}
	tcl      {pure Tcl}
    }
}

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

proc ::sha1::SwitchTo {key} {
    variable accel
    variable active
    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\""
	}
    }

    if {![string equal $loaded ""]} {
        set active($loaded) 0
    }
    if {![string equal $key ""]} {
        set active($key) 1
    }

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

    set loaded $key
    return
}

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

# SHA1Init --
#
#   Create and initialize an SHA1 state variable. This will be
#   cleaned up when we call SHA1Final
#

proc ::sha1::SHA1Init {} {
    variable active
    variable uid
    set token [namespace current]::[incr uid]
    upvar #0 $token state

    # FIPS 180-1: 7 - Initialize the hash state
    array set state \
        [list \
             A [expr {int(0x67452301)}] \
             B [expr {int(0xEFCDAB89)}] \
             C [expr {int(0x98BADCFE)}] \
             D [expr {int(0x10325476)}] \
             E [expr {int(0xC3D2E1F0)}] \
             n 0 i "" ]
    if {$active(cryptkit)} {
        cryptkit::cryptCreateContext state(ckctx) CRYPT_UNUSED CRYPT_ALGO_SHA
    } elseif {$active(trf)} {
        set s {}
        switch -exact -- $::tcl_platform(platform) {
            windows { set s [open NUL w] }
            unix    { set s [open /dev/null w] }
        }
        if {$s != {}} {
            fconfigure $s -translation binary -buffering none
            ::sha1 -attach $s -mode write \
                -read-type variable \
                -read-destination [subst $token](trfread) \
                -write-type variable \
                -write-destination [subst $token](trfwrite)
            array set state [list trfread 0 trfwrite 0 trf $s]
        }
    }
    return $token
}

# SHA1Update --
#
#   This is called to add more data into the hash. You may call this
#   as many times as you require. Note that passing in "ABC" is equivalent
#   to passing these letters in as separate calls -- hence this proc 
#   permits hashing of chunked data
#
#   If we have a C-based implementation available, then we will use
#   it here in preference to the pure-Tcl implementation.
#
proc ::sha1::SHA1Update {token data} {
    variable active
    upvar #0 $token state

    if {$active(critcl)} {
        if {[info exists state(sha1c)]} {
            set state(sha1c) [sha1c $data $state(sha1c)]
        } else {
            set state(sha1c) [sha1c $data]
        }
        return
    } elseif {[info exists state(ckctx)]} {
        if {[string length $data] > 0} {
            cryptkit::cryptEncrypt $state(ckctx) $data
        }
        return
    } elseif {[info exists state(trf)]} {
        puts -nonewline $state(trf) $data
        return
    }

    # Update the state values
    incr state(n) [string length $data]
    append state(i) $data

    # Calculate the hash for any complete blocks
    set len [string length $state(i)]
    for {set n 0} {($n + 64) <= $len} {} {
        SHA1Transform $token [string range $state(i) $n [incr n 64]]
    }

    # Adjust the state for the blocks completed.
    set state(i) [string range $state(i) $n end]
    return
}

# SHA1Final --
#
#    This procedure is used to close the current hash and returns the
#    hash data. Once this procedure has been called the hash context
#    is freed and cannot be used again.
#
#    Note that the output is 160 bits represented as binary data.
#
proc ::sha1::SHA1Final {token} {
    upvar #0 $token state

    # Check for either of the C-compiled versions.
    if {[info exists state(sha1c)]} {
        set r $state(sha1c)
        unset state
        return $r
    } elseif {[info exists state(ckctx)]} {
        cryptkit::cryptEncrypt $state(ckctx) ""
        cryptkit::cryptGetAttributeString $state(ckctx) \
            CRYPT_CTXINFO_HASHVALUE r 20
        cryptkit::cryptDestroyContext $state(ckctx)
        # If nothing was hashed, we get no r variable set!
        if {[info exists r]} {
            unset state
            return $r
        }
    } elseif {[info exists state(trf)]} {
        close $state(trf)
        set r $state(trfwrite)
        unset state
        return $r
    }

    # Padding
    #
    set len [string length $state(i)]
    set pad [expr {56 - ($len % 64)}]
    if {$len % 64 > 56} {
        incr pad 64
    }
    if {$pad == 0} {
        incr pad 64
    }
    append state(i) [binary format a$pad \x80]

    # Append length in bits as big-endian wide int.
    set dlen [expr {8 * $state(n)}]
    append state(i) [binary format II 0 $dlen]

    # Calculate the hash for the remaining block.
    set len [string length $state(i)]
    for {set n 0} {($n + 64) <= $len} {} {
        SHA1Transform $token [string range $state(i) $n [incr n 64]]
    }

    # Output
    set r [bytes $state(A)][bytes $state(B)][bytes $state(C)][bytes $state(D)][bytes $state(E)]
    unset state
    return $r
}

# -------------------------------------------------------------------------
# HMAC Hashed Message Authentication (RFC 2104)
#
# hmac = H(K xor opad, H(K xor ipad, text))
#

# HMACInit --
#
#    This is equivalent to the SHA1Init procedure except that a key is
#    added into the algorithm
#
proc ::sha1::HMACInit {K} {

    # Key K is adjusted to be 64 bytes long. If K is larger, then use
    # the SHA1 digest of K and pad this instead.
    set len [string length $K]
    if {$len > 64} {
        set tok [SHA1Init]
        SHA1Update $tok $K
        set K [SHA1Final $tok]
        set len [string length $K]
    }
    set pad [expr {64 - $len}]
    append K [string repeat \0 $pad]

    # Cacluate the padding buffers.
    set Ki {}
    set Ko {}
    binary scan $K i16 Ks
    foreach k $Ks {
        append Ki [binary format i [expr {$k ^ 0x36363636}]]
        append Ko [binary format i [expr {$k ^ 0x5c5c5c5c}]]
    }

    set tok [SHA1Init]
    SHA1Update $tok $Ki;                 # initialize with the inner pad
    
    # preserve the Ko value for the final stage.
    # FRINK: nocheck
    set [subst $tok](Ko) $Ko

    return $tok
}

# HMACUpdate --
#
#    Identical to calling SHA1Update
#
proc ::sha1::HMACUpdate {token data} {
    SHA1Update $token $data
    return
}

# HMACFinal --
#
#    This is equivalent to the SHA1Final procedure. The hash context is
#    closed and the binary representation of the hash result is returned.
#
proc ::sha1::HMACFinal {token} {
    upvar #0 $token state

    set tok [SHA1Init];                 # init the outer hashing function
    SHA1Update $tok $state(Ko);         # prepare with the outer pad.
    SHA1Update $tok [SHA1Final $token]; # hash the inner result
    return [SHA1Final $tok]
}

# -------------------------------------------------------------------------
# Description:
#  This is the core SHA1 algorithm. It is a lot like the MD4 algorithm but
#  includes an extra round and a set of constant modifiers throughout.
#
set ::sha1::SHA1Transform_body {
    upvar #0 $token state

    # FIPS 180-1: 7a: Process Message in 16-Word Blocks
    binary scan $msg I* blocks
    set blockLen [llength $blocks]
    for {set i 0} {$i < $blockLen} {incr i 16} {
        set W [lrange $blocks $i [expr {$i+15}]]
        
        # FIPS 180-1: 7b: Expand the input into 80 words
        # For t = 16 to 79 
        #   let Wt = (Wt-3 ^ Wt-8 ^ Wt-14 ^ Wt-16) <<< 1
        set t3  12
        set t8   7
        set t14  1
        set t16 -1
        for {set t 16} {$t < 80} {incr t} {
            set x [expr {[lindex $W [incr t3]] ^ [lindex $W [incr t8]] ^ \
                             [lindex $W [incr t14]] ^ [lindex $W [incr t16]]}]
            lappend W [expr {int(($x << 1) | (($x >> 31) & 1))}]
        }
        
        # FIPS 180-1: 7c: Copy hash state.
        set A $state(A)
        set B $state(B)
        set C $state(C)
        set D $state(D)
        set E $state(E)

        # FIPS 180-1: 7d: Do permutation rounds
        # For t = 0 to 79 do
        #   TEMP = (A<<<5) + ft(B,C,D) + E + Wt + Kt;
        #   E = D; D = C; C = S30(B); B = A; A = TEMP;

        # Round 1: ft(B,C,D) = (B & C) | (~B & D) ( 0 <= t <= 19)
        for {set t 0} {$t < 20} {incr t} {
            set TEMP [F1 $A $B $C $D $E [lindex $W $t]]
            set E $D
            set D $C
            set C [rotl32 $B 30]
            set B $A
            set A $TEMP
        }

        # Round 2: ft(B,C,D) = (B ^ C ^ D) ( 20 <= t <= 39)
        for {} {$t < 40} {incr t} {
            set TEMP [F2 $A $B $C $D $E [lindex $W $t]]
            set E $D
            set D $C
            set C [rotl32 $B 30]
            set B $A
            set A $TEMP
        }

        # Round 3: ft(B,C,D) = ((B & C) | (B & D) | (C & D)) ( 40 <= t <= 59)
        for {} {$t < 60} {incr t} {
            set TEMP [F3 $A $B $C $D $E [lindex $W $t]]
            set E $D
            set D $C
            set C [rotl32 $B 30]
            set B $A
            set A $TEMP
         }

        # Round 4: ft(B,C,D) = (B ^ C ^ D) ( 60 <= t <= 79)
        for {} {$t < 80} {incr t} {
            set TEMP [F4 $A $B $C $D $E [lindex $W $t]]
            set E $D
            set D $C
            set C [rotl32 $B 30]
            set B $A
            set A $TEMP
        }

        # Then perform the following additions. (That is, increment each
        # of the four registers by the value it had before this block
        # was started.)
        incr state(A) $A
        incr state(B) $B
        incr state(C) $C
        incr state(D) $D
        incr state(E) $E
    }

    return
}

proc ::sha1::F1 {A B C D E W} {
    expr {(((($A << 5) & 0xffffffff) | (($A >> 27) & 0x1f)) \
               + ($D ^ ($B & ($C ^ $D))) + $E + $W + 0x5a827999) & 0xffffffff}
}

proc ::sha1::F2 {A B C D E W} {
    expr {(((($A << 5) & 0xffffffff) | (($A >> 27) & 0x1f)) \
               + ($B ^ $C ^ $D) + $E + $W + 0x6ed9eba1) & 0xffffffff}
}

proc ::sha1::F3 {A B C D E W} {
    expr {(((($A << 5) & 0xffffffff)| (($A >> 27) & 0x1f)) \
               + (($B & $C) | ($D & ($B | $C))) + $E + $W + 0x8f1bbcdc) & 0xffffffff}
}

proc ::sha1::F4 {A B C D E W} {
    expr {(((($A << 5) & 0xffffffff)| (($A >> 27) & 0x1f)) \
               + ($B ^ $C ^ $D) + $E + $W + 0xca62c1d6) & 0xffffffff}
}

proc ::sha1::rotl32 {v n} {
    return [expr {((($v << $n) \
                        | (($v >> (32 - $n)) \
                               & (0x7FFFFFFF >> (31 - $n))))) \
                      & 0xFFFFFFFF}]
}


# -------------------------------------------------------------------------
# 
# In order to get this code to go as fast as possible while leaving
# the main code readable we can substitute the above function bodies
# into the transform procedure. This inlines the code for us an avoids
# a procedure call overhead within the loops.
#
# We can do some minor tweaking to improve speed on Tcl < 8.5 where we
# know our arithmetic is limited to 64 bits. On > 8.5 we may have 
# unconstrained integer arithmetic and must avoid letting it run away.
#

regsub -all -line \
    {\[F1 \$A \$B \$C \$D \$E (\[.*?\])\]} \
    $::sha1::SHA1Transform_body \
    {[expr {(rotl32($A,5) + ($D ^ ($B \& ($C ^ $D))) + $E + \1 + 0x5a827999) \& 0xffffffff}]} \
    ::sha1::SHA1Transform_body_tmp

regsub -all -line \
    {\[F2 \$A \$B \$C \$D \$E (\[.*?\])\]} \
    $::sha1::SHA1Transform_body_tmp \
    {[expr {(rotl32($A,5) + ($B ^ $C ^ $D) + $E + \1 + 0x6ed9eba1) \& 0xffffffff}]} \
    ::sha1::SHA1Transform_body_tmp

regsub -all -line \
    {\[F3 \$A \$B \$C \$D \$E (\[.*?\])\]} \
    $::sha1::SHA1Transform_body_tmp \
    {[expr {(rotl32($A,5) + (($B \& $C) | ($D \& ($B | $C))) + $E + \1 + 0x8f1bbcdc) \& 0xffffffff}]} \
    ::sha1::SHA1Transform_body_tmp

regsub -all -line \
    {\[F4 \$A \$B \$C \$D \$E (\[.*?\])\]} \
    $::sha1::SHA1Transform_body_tmp \
    {[expr {(rotl32($A,5) + ($B ^ $C ^ $D) + $E + \1 + 0xca62c1d6) \& 0xffffffff}]} \
    ::sha1::SHA1Transform_body_tmp

regsub -all -line \
    {rotl32\(\$A,5\)} \
    $::sha1::SHA1Transform_body_tmp \
    {((($A << 5) \& 0xffffffff) | (($A >> 27) \& 0x1f))} \
    ::sha1::SHA1Transform_body_tmp

regsub -all -line \
    {\[rotl32 \$B 30\]} \
    $::sha1::SHA1Transform_body_tmp \
    {[expr {int(($B << 30) | (($B >> 2) \& 0x3fffffff))}]} \
    ::sha1::SHA1Transform_body_tmp
#
# Version 2 avoids a few truncations to 32 bits in non-essential places.
#
regsub -all -line \
    {\[F1 \$A \$B \$C \$D \$E (\[.*?\])\]} \
    $::sha1::SHA1Transform_body \
    {[expr {rotl32($A,5) + ($D ^ ($B \& ($C ^ $D))) + $E + \1 + 0x5a827999}]} \
    ::sha1::SHA1Transform_body_tmp2

regsub -all -line \
    {\[F2 \$A \$B \$C \$D \$E (\[.*?\])\]} \
    $::sha1::SHA1Transform_body_tmp2 \
    {[expr {rotl32($A,5) + ($B ^ $C ^ $D) + $E + \1 + 0x6ed9eba1}]} \
    ::sha1::SHA1Transform_body_tmp2

regsub -all -line \
    {\[F3 \$A \$B \$C \$D \$E (\[.*?\])\]} \
    $::sha1::SHA1Transform_body_tmp2 \
    {[expr {rotl32($A,5) + (($B \& $C) | ($D \& ($B | $C))) + $E + \1 + 0x8f1bbcdc}]} \
    ::sha1::SHA1Transform_body_tmp2

regsub -all -line \
    {\[F4 \$A \$B \$C \$D \$E (\[.*?\])\]} \
    $::sha1::SHA1Transform_body_tmp2 \
    {[expr {rotl32($A,5) + ($B ^ $C ^ $D) + $E + \1 + 0xca62c1d6}]} \
    ::sha1::SHA1Transform_body_tmp2

regsub -all -line \
    {rotl32\(\$A,5\)} \
    $::sha1::SHA1Transform_body_tmp2 \
    {(($A << 5) | (($A >> 27) \& 0x1f))} \
    ::sha1::SHA1Transform_body_tmp2

regsub -all -line \
    {\[rotl32 \$B 30\]} \
    $::sha1::SHA1Transform_body_tmp2 \
    {[expr {($B << 30) | (($B >> 2) \& 0x3fffffff)}]} \
    ::sha1::SHA1Transform_body_tmp2

if {[package vsatisfies [package provide Tcl] 8.5]} {
    proc ::sha1::SHA1Transform {token msg} $::sha1::SHA1Transform_body_tmp
} else {
    proc ::sha1::SHA1Transform {token msg} $::sha1::SHA1Transform_body_tmp2
}

unset ::sha1::SHA1Transform_body
unset ::sha1::SHA1Transform_body_tmp
unset ::sha1::SHA1Transform_body_tmp2

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

proc ::sha1::byte {n v} {expr {((0xFF << (8 * $n)) & $v) >> (8 * $n)}}
proc ::sha1::bytes {v} { 
    #format %c%c%c%c [byte 0 $v] [byte 1 $v] [byte 2 $v] [byte 3 $v]
    format %c%c%c%c \
        [expr {((0xFF000000 & $v) >> 24) & 0xFF}] \
        [expr {(0xFF0000 & $v) >> 16}] \
        [expr {(0xFF00 & $v) >> 8}] \
        [expr {0xFF & $v}]
}

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

proc ::sha1::Hex {data} {
    binary scan $data H* result
    return $result
}

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

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

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

# fileevent handler for chunked file hashing.
#
proc ::sha1::Chunk {token channel {chunksize 4096}} {
    upvar #0 $token state
    
    if {[eof $channel]} {
        fileevent $channel readable {}
        set state(reading) 0
    }
        
    SHA1Update $token [read $channel $chunksize]
}

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

proc ::sha1::sha1 {args} {
    array set opts {-hex 0 -filename {} -channel {} -chunksize 4096}
    if {[llength $args] == 1} {
        set opts(-hex) 1
    } else {
        while {[string match -* [set option [lindex $args 0]]]} {
            switch -glob -- $option {
                -hex       { set opts(-hex) 1 }
                -bin       { set opts(-hex) 0 }
                -file*     { set opts(-filename) [Pop args 1] }
                -channel   { set opts(-channel) [Pop args 1] }
                -chunksize { set opts(-chunksize) [Pop args 1] }
                default {
                    if {[llength $args] == 1} { break }
                    if {[string compare $option "--"] == 0} { Pop args; break }
                    set err [join [lsort [concat -bin [array names opts]]] ", "]
                    return -code error "bad option $option:\
                    must be one of $err"
                }
            }
            Pop args
        }
    }

    if {$opts(-filename) != {}} {
        set opts(-channel) [open $opts(-filename) r]
        fconfigure $opts(-channel) -translation binary
    }

    if {$opts(-channel) == {}} {

        if {[llength $args] != 1} {
            return -code error "wrong # args:\
                should be \"sha1 ?-hex? -filename file | string\""
        }
        set tok [SHA1Init]
        SHA1Update $tok [lindex $args 0]
        set r [SHA1Final $tok]

    } else {

        set tok [SHA1Init]
        # FRINK: nocheck
        set [subst $tok](reading) 1
        fileevent $opts(-channel) readable \
            [list [namespace origin Chunk] \
                 $tok $opts(-channel) $opts(-chunksize)]
        # FRINK: nocheck
        vwait [subst $tok](reading)
        set r [SHA1Final $tok]

        # If we opened the channel - we should close it too.
        if {$opts(-filename) != {}} {
            close $opts(-channel)
        }
    }
    
    if {$opts(-hex)} {
        set r [Hex $r]
    }
    return $r
}

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

proc ::sha1::hmac {args} {
    array set opts {-hex 1 -filename {} -channel {} -chunksize 4096}
    if {[llength $args] != 2} {
        while {[string match -* [set option [lindex $args 0]]]} {
            switch -glob -- $option {
                -key       { set opts(-key) [Pop args 1] }
                -hex       { set opts(-hex) 1 }
                -bin       { set opts(-hex) 0 }
                -file*     { set opts(-filename) [Pop args 1] }
                -channel   { set opts(-channel) [Pop args 1] }
                -chunksize { set opts(-chunksize) [Pop args 1] }
                default {
                    if {[llength $args] == 1} { break }
                    if {[string compare $option "--"] == 0} { Pop args; break }
                    set err [join [lsort [array names opts]] ", "]
                    return -code error "bad option $option:\
                    must be one of $err"
                }
            }
            Pop args
        }
    }

    if {[llength $args] == 2} {
        set opts(-key) [Pop args]
    }

    if {![info exists opts(-key)]} {
        return -code error "wrong # args:\
            should be \"hmac ?-hex? -key key -filename file | string\""
    }

    if {$opts(-filename) != {}} {
        set opts(-channel) [open $opts(-filename) r]
        fconfigure $opts(-channel) -translation binary
    }

    if {$opts(-channel) == {}} {

        if {[llength $args] != 1} {
            return -code error "wrong # args:\
                should be \"hmac ?-hex? -key key -filename file | string\""
        }
        set tok [HMACInit $opts(-key)]
        HMACUpdate $tok [lindex $args 0]
        set r [HMACFinal $tok]

    } else {

        set tok [HMACInit $opts(-key)]
        # FRINK: nocheck
        set [subst $tok](reading) 1
        fileevent $opts(-channel) readable \
            [list [namespace origin Chunk] \
                 $tok $opts(-channel) $opts(-chunksize)]
        # FRINK: nocheck
        vwait [subst $tok](reading)
        set r [HMACFinal $tok]

        # If we opened the channel - we should close it too.
        if {$opts(-filename) != {}} {
            close $opts(-channel)
        }
    }
    
    if {$opts(-hex)} {
        set r [Hex $r]
    }
    return $r
}

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

# Try and load a compiled extension to help.
namespace eval ::sha1 {
    variable e {}
    foreach e [KnownImplementations] {
	if {[LoadAccelerator $e]} {
	    SwitchTo $e
	    break
	}
    }
    unset e
}

package provide sha1 $::sha1::version

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

Added build/web/process_queue version [7bb2a1b520]. 









































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>

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

#! /usr/bin/env tclsh

set queue "/home/rkeene/devel/kitcreator/build/web/queue"
set outdir "/web/customers/kitcreator.rkeene.org/kits"

if {![file exists "${queue}.old"]} {
	if {![file exists $queue]} {
		exit 0
	}

	file rename "$queue" "${queue}.old"
}
set queue "${queue}.old"

set fd [open $queue r]
set data [read $fd]
close $fd

foreach line [split $data "\n"] {
	if {$line == ""} {
		continue
	}

	unset -nocomplain buildinfo

	array set buildinfo $line

	set outfile [file join $outdir $buildinfo(key) $buildinfo(filename)]

	# Skip if build completed
	if {[file exists $outfile]} {
		continue
	}

	# Skip if build failed
	if {[file exists $outfile.buildfail]} {
		continue
	}

	set workdir [file join $outdir $buildinfo(key) build]
	file delete -force $workdir
	file mkdir $workdir
	cd $workdir

	set fd [open ../filename w]
	puts $fd $buildinfo(filename)
	close $fd

	set tarball kitcreator-${buildinfo(kitcreator_version)}.tar.gz
	exec wget -q -O $tarball http://kitcreator.rkeene.org/fossil/tarball/${tarball}?uuid=${buildinfo(kitcreator_version)}
	exec gzip -dc $tarball | tar -xf -
	cd kitcreator-${buildinfo(kitcreator_version)}

	set script "./build/make-kit-${buildinfo(platform)}"
	set args [list]

	set ::env(KITCREATOR_PKGS) " [join $buildinfo(packages) " "] "

	foreach {option value} $buildinfo(options) {
		switch -- $option {
			"kitdll" {
				if {$value} {
					set ::env(KITCREATOR_PKGS) "$::env(KITCREATOR_PKGS) kitdll"
				}
			}
			"threaded" {
				if {$value} {
					lappend args "--enable-threads"
				}
			}
		}
	}

	catch {
		exec ./build/pre.sh
	}

	catch {
		exec $script $buildinfo(tcl_version) {*}$args > "${outfile}.log" 2>@1
	}

	catch {
		exec grep ^ {*}[glob */build.log] >> "${outfile}.log"
	}

	foreach file [list tclkit-$buildinfo(tcl_version) {*}[glob -nocomplain libtclkit*]] {
		switch -glob -- $file {
			"*.dylib" - "*.so" - "*.sl" - "*.dll" { }
			"tclkit-*" {}
			default {
				continue
			}
		}

		if {[file exists $file]} {
			file rename $file $outfile

			break
		}
	}

	if {![file exists $outfile]} {
		set fd [open $outfile.buildfail "w+"]
		puts $fd "$line"
		close $fd
	}

	cd $outdir

	file delete -force $workdir
}

file delete $queue

exit 0

Powered by Fossil · RSS