You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
134 lines
4.4 KiB
134 lines
4.4 KiB
# -*- tcl -*- |
|
# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from <pkg>-buildversion.txt |
|
# |
|
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. |
|
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. |
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
# (C) 2023 |
|
# |
|
# @@ Meta Begin |
|
# Application zzzload 999999.0a1.0 |
|
# Meta platform tcl |
|
# Meta license BSD |
|
# @@ Meta End |
|
|
|
|
|
|
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
## Requirements |
|
##e.g package require frobz |
|
|
|
package require Thread |
|
|
|
#EXPERIMENTAL. |
|
|
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
namespace eval zzzload { |
|
variable loader_tid "" ;#thread id |
|
proc stacktrace {} { |
|
#review |
|
set stack "Stack trace:\n" |
|
for {set i 1} {$i < [info level]} {incr i} { |
|
set lvl [info level -$i] |
|
set pname [lindex $lvl 0] |
|
append stack [string repeat " " $i]$pname |
|
|
|
if {![catch {info args $pname} pargs]} { |
|
foreach value [lrange $lvl 1 end] arg $pargs { |
|
|
|
if {$value eq ""} { |
|
if {$arg != 0} { |
|
info default $pname $arg value |
|
} |
|
} |
|
append stack " $arg='$value'" |
|
} |
|
} else { |
|
append stack " !unknown vars for $pname" |
|
} |
|
|
|
append stack \n |
|
} |
|
return $stack |
|
} |
|
proc pkg_require {pkgname args} { |
|
#experimental |
|
# loads a binary package in another thread - doesn't load an ordinary package in main thread. |
|
# has potential for startup time savings with binary modules that are slow to load, |
|
# but utility/practicality is dubious. |
|
|
|
variable loader_tid |
|
if {[set ver [package provide $pkgname]] ne ""} { |
|
#skip the whole shebazzle if it's already loaded |
|
return $ver |
|
} |
|
if {$loader_tid eq ""} { |
|
#propagate tm list, auto_path, and package prefer to the loader thread |
|
#so it can find the same packages as the parent interp. |
|
if {![catch {package require punk::lib}]} { |
|
set init_script [punk::lib::snapshot_package_paths] |
|
set loader_tid [thread::create -joinable -preserved $init_script] |
|
} else { |
|
#punk::lib not available — fall back to bare thread |
|
set loader_tid [thread::create -joinable -preserved] |
|
} |
|
} |
|
if {![tsv::exists zzzload_pkg $pkgname]} { |
|
#puts stderr "zzzload pkg_require $pkgname" |
|
#puts [stacktrace] |
|
tsv::set zzzload_pkg $pkgname "loading" |
|
tsv::set zzzload_pkg_mutex $pkgname [thread::mutex create] |
|
set cond [thread::cond create] |
|
tsv::set zzzload_pkg_cond $pkgname $cond |
|
thread::send -async $loader_tid [string map [list <pkg> $pkgname <cond> $cond] { |
|
if {![catch {package require <pkg>} returnver]} { |
|
tsv::set zzzload_pkg <pkg> $returnver |
|
} else { |
|
tsv::set zzzload_pkg <pkg> "failed" |
|
} |
|
thread::cond notify <cond> |
|
}] |
|
return "loading" |
|
} else { |
|
return [tsv::get zzzload_pkg $pkgname] |
|
} |
|
} |
|
proc pkg_wait {pkgname} { |
|
if {[set ver [package provide $pkgname]] ne ""} { |
|
return $ver |
|
} |
|
|
|
set pkgstate [tsv::get zzzload_pkg $pkgname] |
|
if {$pkgstate eq "loading"} { |
|
set mutex [tsv::get zzzload_pkg_mutex $pkgname] |
|
thread::mutex lock $mutex |
|
set cond [tsv::get zzzload_pkg_cond $pkgname] |
|
while {[tsv::get zzzload_pkg $pkgname] eq "loading"} { |
|
thread::cond wait $cond $mutex 3000 |
|
} |
|
set result [tsv::get zzzload_pkg $pkgname] |
|
thread::mutex unlock $mutex |
|
return $result |
|
} else { |
|
return $pkgstate |
|
} |
|
} |
|
proc shutdown {} { |
|
variable loader_tid |
|
if {[thread::exists $loader_tid]} { |
|
thread::release $loader_tid |
|
thread::join $loader_tid |
|
set loader_tid "" |
|
} |
|
} |
|
|
|
} |
|
|
|
|
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
## Ready |
|
package provide zzzload [namespace eval zzzload { |
|
variable version |
|
set version 999999.0a1.0 |
|
}] |
|
return |