common.tcl at [de52915810]

File client/web/common.tcl artifact 09d7dce52a part of check-in de52915810


#! /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]
}

}