teapotclient.tcl at [40f0c560a5]

File client/lib/teapotclient0.1/teapotclient.tcl artifact db3d2ea33e part of check-in 40f0c560a5


#! /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 http
package require fileutil

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)]} {
			return $::env(HOME)
		}

		catch {
			set ::env(HOME) [file normalize ~]
		}
		if {[info 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)
	}

	set pkgcachedir [file join [__get_homedir] ".teapot-client" "cachedir"]

        # 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 download_extensions {rootdir servers extensions os cpu {existingExts "Tcl Tk"}} {
		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 lib $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]
				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 $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]
		
		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]
	}

	proc setcachedir {dir} {
		set ::teapotclient::pkgcachedir $dir
	}
}

package provide teapotclient 0.1