#! /usr/bin/env tclsh
# This file has no license. It is in the public domain.
# -- Roy Keene <tcl@rkeene.org> [20081025T1400Q]
namespace eval ::teapotclient {}
package require Tcl
package require md5
package require http
package require fileutil
set ::teapotclient::have_vfszip 0
catch {
package require vfs::zip
set ::teapotclient::have_vfszip 1
}
namespace eval ::teapotclient {}
namespace eval ::teapotclient {
proc __get_tmpdir {} {
foreach checkenv [list TMPDIR TEMP TMP TEMPDIR] {
if {[info exists ::env($checkenv)]} {
return $::env($checkenv)
}
}
return "/tmp"
}
proc __get_homedir {} {
if {[info exists ::env(HOME)]} {
if {[file exists $::env(HOME)]} {
return $::env(HOME)
}
}
catch {
set ::env(HOME) [file normalize ~]
}
if {[info exists ::env(HOME)]} {
if {[file exists $::env(HOME)]} {
return $::env(HOME)
}
}
set ::env(HOME) [file join [__get_tmpdir] FAKEHOME_$tcl_platform(user)]
catch {
file mkdir $::env(HOME)
}
return $::env(HOME)
}
proc __unzip {dir file} {
file mkdir $dir
if {$::teapotclient::have_vfszip} {
set mntfd [vfs::zip::Mount $file $file]
foreach filetail [glob -nocomplain -tails -directory $file *] {
set srcfile [file join $file $filetail]
set destdir [file dirname [file join $dir $filetail]]
file copy -force -- $srcfile $destdir
}
vfs::zip::Unmount $mntfd $file
} else {
exec unzip -d $dir -n -qq $file
}
}
set pkgcachedir [file join [__get_homedir] ".teapot-client" "cachedir"]
# Conversions from Teapot-style names to local ones
set osTeapotToLocal(tcl) [list *]
set osTeapotToLocal(linux-*) [list linux]
set osTeapotToLocal(win32) [list windows]
set osTeapotToLocal(solaris*) [list solaris sunos]
set osTeapotToLocal(freebsd) [list freebsd_*]
set osTeapotToLocal(irix) [list irix_*]
set cpuTeapotToLocal(ix86) [list x86 intel i?86 i86pc]
set cpuTeapotToLocal(sparc) [list sun4*]
set cpuTeapotToLocal(universal) [list *]
set cpuTeapotToLocal(powerpc) [list ppc]
proc download_extensions {rootdir servers extensions os cpu {existingExts ""}} {
foreach chkdefext [list Tcl Tk] {
if {[lsearch -exact $existingExts $chkdefext] == -1} {
lappend existingExts $chkdefext
}
}
foreach server $servers {
foreach {pkg pkginfo} [get_extensions $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 $extension$ver]
file mkdir $pkgdir $::teapotclient::pkgcachedir
set url "http://$server/package/name/$extension/ver/$ver/arch/$arch/file"
set urlcachefile [file join $::teapotclient::pkgcachedir [::md5::md5 -hex $url]]
if {![file exists $urlcachefile]} {
set tmpfd [open $urlcachefile w]
fconfigure $tmpfd -encoding binary -translation binary -buffering none
set token [::http::geturl $url -binary true -channel $tmpfd]
::http::cleanup $token
close $tmpfd
}
set retarr($extension) [list $ver $arch $server]
switch -regexp -- [::fileutil::fileType $urlcachefile] {
"(^| )zip($| )" {
catch {
__unzip $pkgdir $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 $rootdir $servers $fetchDeps $os $cpu $existingExts]
array set retarr $addRet
}
return [array get retarr]
}
proc get_extensions {server {limitos "*"} {limitcpu "*"}} {
upvar ::teapotclient::osTeapotToLocal osTeapotToLocal
upvar ::teapotclient::cpuTeapotToLocal cpuTeapotToLocal
file mkdir $::teapotclient::pkgcachedir
set cachefile [file join $::teapotclient::pkgcachedir TEAPOTINFO-[::md5::md5 -hex $server]]
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 localvariants} [array get osTeapotToLocal] {
foreach local $localvariants {
if {[string match -nocase $limitos $local] || [string match -nocase $local $limitos]} {
if {[string match -nocase $teapot $arch_os] || [string match -nocase $arch_os $teapot]} {
set isCompatOS 1
break
}
}
}
}
}
if {!$isCompatOS} {
continue
}
set isCompatCPU 0
if {$arch == "tcl"} {
set isCompatCPU 1
} elseif {[string match -nocase $limitcpu $arch_cpu]} {
set isCompatCPU 1
} else {
foreach {teapot localvariants} [array get cpuTeapotToLocal] {
foreach local $localvariants {
if {[string match -nocase $limitcpu $local] || [string match -nocase $local $limitcpu]} {
if {[string match -nocase $teapot $arch_cpu] || [string match -nocase $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]
}
proc setcachedir {dir} {
set ::teapotclient::pkgcachedir $dir
}
}
package provide teapotclient 0.1