#! /usr/bin/env tclsh
# This file has no license. It is in the public domain.
# -- Roy Keene <tcl@rkeene.org> [20081025T1400Q]
package require md5
package require Tclx
namespace eval ::customkit {}
namespace eval ::customkit {
set starkitdir "/home/rkeene/devel/starkit2exe"
set tclkitsdir "$starkitdir/tclkits"
set findkit "$starkitdir/support/find-tclkit"
set sdx "$starkitdir/support/sdx-1nrl.kit"
set pkgcachedir "/tmp/DELETEME_customkit_[string tolower [md5::md5 -hex [list [info script] [id user]]]].cache"
# Generate a mapping of Tclkits to user viewable and referencable keys
array set Mapping [list]
catch {
foreach file [glob -nocomplain -directory $tclkitsdir *] {
set work [split [file tail $file] -]
set file_tclver [lindex $work 1]
set file_os [lindex $work 2]
set file_cpu [lindex $work 3]
set file_exts [list Itcl Mk4tcl]
if {[lindex $work 0] != "tclkitnotk"} {
lappend file_exts "Tk"
}
unset -nocomplain file_info
array set file_info {}
catch {
file stat $file file_info
unset file_info(atime)
}
set key [string tolower [md5::md5 -hex [list $file [array get file_info] [expr [clock seconds] / 86400]]]]
set Mapping($key) [list $file $file_tclver $file_os $file_cpu $file_exts]
}
}
# Descriptive mappings
set OSDesc(macosx) "Mac OS X"
set OSDesc(macos) "Mac OS Classic"
set OSDesc(freebsd) "FreeBSD"
set OSDesc(openbsd) "OpenBSD"
set OSDesc(netbsd) "NetBSD"
set OSDesc(hpux) "HP/UX"
set OSDesc(irix) "IRIX"
set OSDesc(aix) "AIX"
set CPUDesc(ppc) "PowerPC"
set CPUDesc(m68k) "Motorola 68K"
set CPUDesc(x86_64) "AMD64"
set CPUDesc(parisc) "PA-RISC"
set CPUDesc(sun4m) "SPARC"
set CPUDesc(sun4u) "UltraSPARC"
set CPUDesc(armv9) "ARM v9"
# Conversions from Teapot-style names to local ones
set osTeapotToLocal(tcl) *
set osTeapotToLocal(linux-*) linux
set osTeapotToLocal(win32) windows
set osTeapotToLocal(solaris*) solaris
set osTeapotToLocal(freebsd) freebsd_*
set osTeapotToLocal(irix) irix_*
set cpuTeapotToLocal(ix86) x86
set cpuTeapotToLocal(sparc) sun4*
set cpuTeapotToLocal(universal) *
set cpuTeapotToLocal(powerpc) ppc
proc get_descs_from_mapping {} {
upvar ::customkit::Mapping Mapping
set descs [list]
foreach key [array names Mapping] {
set tclver [lindex $Mapping($key) 1]
set os [lindex $Mapping($key) 2]
set cpu [lindex $Mapping($key) 3]
set exts [lindex $Mapping($key) 4]
set os [descOSLocalToEnglish $os]
set cpu [descCPULocalToEnglish $cpu]
set desc "Tcl v$tclver for $os on the $cpu architecture"
if {[lsearch -exact $exts "Tk"] == -1} {
append desc " (no Tk)"
}
lappend descs [list $desc $key]
}
return $descs
}
proc descOSLocalToEnglish {os} {
upvar ::customkit::OSDesc OSDesc
set work [split $os _]
set os_extra [join [lrange $work 1 end]]
set os [lindex $work 0]
if {[info exists OSDesc($os)]} {
set os "$OSDesc($os) $os_extra"
} else {
set os "[string totitle $os] $os_extra"
}
set os [string trim $os]
return $os
}
proc descCPULocalToEnglish {cpu} {
upvar ::customkit::CPUDesc CPUDesc
set new_cpu [list]
foreach cpu [split $cpu +] {
if {[info exists CPUDesc($cpu)]} {
set cpu $CPUDesc($cpu)
}
lappend new_cpu $cpu
}
set cpu [join $new_cpu {, }]
}
proc download_extensions_teapot {rootdir servers extensions os cpu {existingExts "Tcl Tk"}} {
package require http
package require fileutil
foreach server $servers {
foreach {pkg pkginfo} [get_extensions_teapot $server $os $cpu] {
foreach pkginstance $pkginfo {
lappend pkginstance $server
lappend pkgdata($pkg) $pkginstance
}
}
}
foreach pkg [array names pkgdata] {
set pkgdata($pkg) [lsort -decreasing -dictionary $pkgdata($pkg)]
}
array set extDependencies [list]
foreach extension $extensions {
set extension [file tail $extension]
if {![info exists pkgdata($extension)]} {
continue
}
set pkginfo [lindex $pkgdata($extension) 0]
set ver [lindex $pkginfo 0]
set arch [lindex $pkginfo 1]
set server [lindex $pkginfo 2]
set pkgdir [file join $rootdir lib $extension$ver]
file mkdir $pkgdir $::customkit::pkgcachedir
set url "http://$server/package/name/$extension/ver/$ver/arch/$arch/file"
set urlcachefile [file join $::customkit::pkgcachedir [::md5::md5 -hex $url]]
if {![file exists $urlcachefile]} {
set tmpfd [open $urlcachefile w]
set token [::http::geturl $url -channel $tmpfd]
::http::cleanup $token
close $tmpfd
}
set retarr($extension) [list $ver $arch $server]
switch -regexp -- [::fileutil::fileType $urlcachefile] {
"(^| )zip($| )" {
catch {
exec unzip -d $pkgdir -n -qq $urlcachefile
}
# Process $pkgdir/teapot.txt
set teapot [file join $pkgdir teapot.txt]
if {[file exists $teapot]} {
set fd [open $teapot r]
for {gets $fd line} {![eof $fd]} {gets $fd line} {
if {[string match "Meta require *" $line]} {
set depinfo [lindex $line 2]
set dep [lindex $depinfo 0]
set depextra [lrange $depinfo 1 end]
lappend extDependencies($dep) $depextra
}
}
close $fd
}
}
"(^| )text($| )" {
unset -nocomplain fd
set extfile [file join $pkgdir ${extension}.tcl]
set idxfile [file join $pkgdir pkgIndex.tcl]
catch {
file copy -force -- $urlcachefile $extfile
set fd [open $idxfile w]
puts $fd "package ifneeded $extension $ver \[list source \[file join \$dir [file tail $extfile]\]\]"
}
catch {
close $fd
}
# Process $extfile
set fd [open $extfile r]
for {gets $fd line} {![eof $fd]} {gets $fd line} {
if {[string match "# Meta require *" $line]} {
set depinfo [lindex $line 3]
set dep [lindex $depinfo 0]
set depextra [lrange $depinfo 1 end]
lappend extDependencies($dep) $depextra
}
}
close $fd
}
}
}
foreach {dep depinfo} [array get extDependencies] {
set depReq -1
foreach depinstinfo $depinfo {
set depver [lindex $depinstinfo 0]
set depinstinfo [lrange $depinstinfo 1 end]
foreach {var val} $depinstinfo {
switch -- $var {
"-platform" {
if {$val != $os} {
if {$depReq == -1} {
set depReq 0
}
}
}
}
}
}
if {$depReq == 0} {
continue
}
if {[lsearch $existingExts $dep] == -1} {
lappend existingExts $dep
lappend fetchDeps $dep
}
}
if {[info exists fetchDeps]} {
set addRet [download_extensions_teapot $rootdir $servers $fetchDeps $os $cpu $existingExts]
array set retarr $addRet
}
return [array get retarr]
}
proc get_extensions_teapot {server {limitos "*"} {limitcpu "*"}} {
upvar ::customkit::osTeapotToLocal osTeapotToLocal
upvar ::customkit::cpuTeapotToLocal cpuTeapotToLocal
set cachefile "/tmp/DELETEME_teapot_cache_[string tolower [md5::md5 -hex [list [info script] $server [id user]]]].tmp"
set currtime [clock seconds]
if {[file exists $cachefile]} {
catch {
set fd [open $cachefile r]
set data [read $fd]
close $fd
set datatime [lindex $data 0]
if {($currtime - $datatime) < 86400} {
set children [lindex $data 1]
}
}
}
if {![info exists children]} {
package require http
set url "http://[join [list $server package list] /]"
set token [::http::geturl $url]
if {[::http::ncode $token] != "200"} {
return [list]
}
set data [::http::data $token]
::http::cleanup $token
set work [join [split $data \n] { }]
regexp {\[\[TPM\[\[(.*)\]\]MPT\]\]} $work -> children
catch {
set fd [open $cachefile w]
puts $fd [list $currtime $children]
close $fd
}
}
foreach child $children {
set type [lindex $child 0]
if {$type != "package"} {
continue
}
set pkg [lindex $child 1]
set ver [lindex $child 2]
set arch [lindex $child 3]
set arch_work [split $arch -]
set arch_os [join [lrange $arch_work 0 end-1] -]
set arch_cpu [lindex $arch_work end]
if {$arch == "source"} {
continue
}
set isCompatOS 0
if {$arch == "tcl"} {
set isCompatOS 1
} elseif {[string match $limitos $arch_os]} {
set isCompatOS 1
} else {
foreach {teapot local} [array get osTeapotToLocal] {
if {[string match $limitos $local] || [string match $local $limitos]} {
if {[string match $teapot $arch_os] || [string match $arch_os $teapot]} {
set isCompatOS 1
break
}
}
}
}
if {!$isCompatOS} {
continue
}
set isCompatCPU 0
if {$arch == "tcl"} {
set isCompatCPU 1
} elseif {[string match $limitcpu $arch_cpu]} {
set isCompatCPU 1
} else {
foreach {teapot local} [array get cpuTeapotToLocal] {
if {[string match $limitcpu $local] || [string match $local $limitcpu]} {
if {[string match $teapot $arch_cpu] || [string match $arch_cpu $teapot]} {
set isCompatCPU 1
break
}
}
}
}
if {!$isCompatCPU} {
continue
}
lappend pkginfo($pkg) [list $ver $arch]
}
foreach pkg [array names pkginfo] {
set pkginfo($pkg) [lsort -decreasing -dictionary $pkginfo($pkg)]
}
return [array get pkginfo]
}
}