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.
266 lines
9.5 KiB
266 lines
9.5 KiB
|
|
|
|
#JMN 2021 - Public Domain |
|
# |
|
#Warning - suppressing a package may have undesirable effects |
|
# |
|
#changes: |
|
#2024-08-03 - v 0.4 rename all lowercase - update for new commandstack 0.3 - packagesuppress still considered experimental |
|
#2021-09-16 |
|
# - Support cooperation with packageTrace which also renames the package command |
|
# - Add packagesuppress procs: deinit, enable, disable, clear |
|
# - Fix args handling to require -opt value pairs and remove mutual exclusivity |
|
# |
|
package provide packagesuppress [namespace eval packagesuppress { |
|
variable chan stderr |
|
variable was_already_loaded |
|
variable suppressed |
|
|
|
array set was_already_loaded [list] |
|
array set suppressed [list] |
|
|
|
set version 0.4 |
|
}] |
|
|
|
proc packagesuppress::help {} { |
|
return { |
|
Some packages, e.g Twapi on windows are slow to load (multiple seconds on even high end hardware) |
|
or they may have other undesirable interactions with other packages. |
|
packagesuppress allows easy temporary suppression of a package |
|
Enable suppression of a particular package using 'packagesuppress::suppress pkgname' |
|
Disable suppression of a particular package using 'packagesuppress::unsuppress pkgname' |
|
} |
|
} |
|
|
|
proc packagesuppress::suppress {pkgname args} { |
|
#puts stdout "suppress $pkgname $args" |
|
variable suppressed |
|
variable suppressed_reason |
|
variable was_already_loaded |
|
|
|
set force 0 |
|
set quiet 0 |
|
set hard 0 |
|
set argc [llength $args] |
|
set defaults [dict create] |
|
set known_opts [list -force -quiet -hard -reason] |
|
|
|
dict set defaults -force 0 |
|
dict set defaults -hard 0 |
|
dict set defaults -quiet 0 |
|
#do not set a default for -reason - we need to distinguish empty string from not-supplied. |
|
|
|
if {([llength $args] %2) != 0} { |
|
error "(packagesuppress::suppress) ERROR: uneven number of args. Argments must be of form -option value" |
|
} |
|
|
|
foreach {k v} $args { |
|
if {$k ni $known_opts} { |
|
error "((pattern::cmd::util::col) ERROR: option '$k' not in known options: '$known_opts'" |
|
} |
|
} |
|
set opts [dict merge $defaults $args] |
|
|
|
set force [dict get $opts -force] |
|
set hard [dict get $opts -hard] |
|
set quiet [dict get $opts -quiet] |
|
|
|
set sup [dict create] |
|
|
|
dict set sup force $force |
|
dict set sup hard $hard |
|
dict set sup quiet $quiet |
|
if {[dict exists $opts -reason]} { |
|
#set it even if empty string! |
|
dict set sup reason [dict get $opts -reason] |
|
} |
|
|
|
|
|
|
|
if {[catch {package present $pkgname}]} { |
|
set was_already_loaded($pkgname) 0 |
|
set suppressed($pkgname) $sup |
|
} else { |
|
set was_already_loaded($pkgname) 1 |
|
if {$force} { |
|
set suppressed($pkgname) $sup |
|
} |
|
|
|
if {$hard} { |
|
package forget $pkgname ;#forget it now and reload on unsuppress |
|
set suppressed($pkgname) $sup |
|
} |
|
|
|
if {!$quiet} { |
|
puts stderr "packagesuppress not suppressing $pkgname because already loaded. use '-force 1' to suppress anyway, '-hard 1' to forget until unsuppressed, use '-quiet 1' to avoid this output." |
|
} |
|
return already_loaded_so_unsuppressed |
|
} |
|
} |
|
proc packagesuppress::unsuppress {pkgname} { |
|
variable suppressed |
|
variable was_already_loaded |
|
|
|
if {[info exists was_already_loaded($pkgname)]} { |
|
unset was_already_loaded($pkgname) |
|
if {[info exists suppressed($pkgname)]} { |
|
set is_hard [dict get [set suppressed($pkgname)] hard] |
|
if {$is_hard eq "hard"} { |
|
package require $pkgname |
|
} |
|
} |
|
} |
|
|
|
if {[info exists suppressed($pkgname)]} { |
|
unset suppressed($pkgname) |
|
} |
|
} |
|
|
|
|
|
namespace eval packagesuppress::util { |
|
|
|
|
|
|
|
|
|
#from: http://wiki.tcl.tk/8766 (Introspection on aliases) |
|
#usedby: metaface-1.1.6+ |
|
#required because aliases can be renamed. |
|
#A renamed alias will still return it's target with 'interp alias {} oldname' |
|
# - so given newname - we require which_alias to return the same info. |
|
proc get_alias_target {cmd} { |
|
uplevel 1 [list ::trace add execution $cmd enterstep ::error] |
|
catch {uplevel 1 $cmd} res |
|
uplevel 1 [list ::trace remove execution $cmd enterstep ::error] |
|
#puts stdout "which_alias $cmd returning '$res'" |
|
if {[string match "invalid command*" $res]} { |
|
set target "" |
|
} else { |
|
set target $res |
|
} |
|
return $target |
|
} |
|
|
|
} |
|
|
|
proc packagesuppress::init {} { |
|
variable suppressed |
|
variable rename_action_taken ;#record what we renamed the 'package' command to so it can be undone on deinit/disable |
|
|
|
variable cooperative_name_originalcommand |
|
uplevel 1 { |
|
package require commandstack 0.3 |
|
set package_command [namespace which package] |
|
set stackrecord [commandstack::rename_command -renamer packagesuppress $package_command {sub args} { |
|
set next $COMMANDSTACKNEXT |
|
if {$sub eq "require"} { |
|
set pkgname [lindex $args 0] |
|
if {[info exists ::packagesuppress::suppressed($pkgname)]} { |
|
#mimic the original package error by keeping 'can't find package $pkgname' - but add our own tail to give the user a hint as to what's going on. |
|
set standard_msg "can't find package $pkgname" |
|
set suppression_record [dict get [set ::packagesuppress::suppressed($pkgname)]] |
|
set quiet [dict get $suppression_record quiet] |
|
|
|
if {[dict exists $suppression_record reason]} { |
|
set txt [dict get $suppression_record reason] |
|
if {[string length $txt]} { |
|
set reason " - $txt" |
|
} else { |
|
set reason "" ;# Make indistinguishable from the standard error message |
|
} |
|
} else { |
|
set reason " - suppressed by package packagesuppress" |
|
} |
|
if {!$quiet} { |
|
puts stderr "skipping package $pkgname $reason - use 'package suppress $pkgname -quiet 1' to avoid this output" |
|
} |
|
error "$standard_msg$reason" |
|
} else { |
|
#tailcall %next% $sub {*}$args |
|
if {$next ne $COMMANDSTACKNEXT_ORIGINAL} { |
|
puts stderr "(packagesuppress package) DEBUG1 - command changed since start: %next% is now $next" |
|
} |
|
tailcall $next $sub {*}$args |
|
} |
|
} elseif {$sub eq "suppress"} { |
|
set pkgname [lindex $args 0] |
|
packagesuppress::suppress $pkgname {*}[lrange $args 1 end] |
|
} elseif {$sub eq "unsuppress"} { |
|
set pkgname [lindex $args 0] |
|
packagesuppress::unsuppress $pkgname |
|
} elseif {$sub eq "suppressed"} { |
|
upvar #0 packagesuppress::suppressed suppressed |
|
if {[llength $args] == 0} { |
|
return [array names suppressed] |
|
} else { |
|
if {[array exists suppressed([lindex $args 0])} { |
|
set suppression_record $suppressed([lindex $args 0]) |
|
return [list [lindex $args 0] $suppression_record] |
|
} else { |
|
return [list] |
|
} |
|
} |
|
} else { |
|
if {$next ne $COMMANDSTACKNEXT_ORIGINAL} { |
|
puts stderr "(packagesuppress package) DEBUG2 - command changed since start: %next% is now $next" |
|
} |
|
tailcall $next $sub {*}$args |
|
} |
|
}] |
|
if {[set stored_target [dict get $stackrecord implementation]] ne ""} { |
|
puts stderr "packagesuppress::init renamed $package_command to $stored_target using commandstack::rename_command and is providing an override" |
|
} else { |
|
puts stderr "packagesuppress::init failed to rename $package_command using commandstack::rename_command" |
|
} |
|
} |
|
} |
|
|
|
#disable and clear state |
|
proc packagesuppress::deinit {} { |
|
clear |
|
disable |
|
} |
|
proc packagesuppress::disable {} { |
|
::commandstack::remove_rename {::package packagesuppress} |
|
} |
|
proc packagesuppress::enable {} { |
|
#init doesn't clear state - so this is effectively an alias |
|
tailcall packagesuppress::init |
|
} |
|
#clear state of suppressed packages |
|
proc packagesuppress::clear {} { |
|
variable suppressed |
|
array unset suppressed |
|
} |
|
packagesuppress::init |
|
|
|
|
|
|
|
#an alternative approach.. todo - review |
|
proc packagesuppress::suppress2 {pkgname} { |
|
variable was_already_loaded |
|
variable suppressed |
|
|
|
if {[catch {package present $pkgname}]} { |
|
set suppressed($pkgname) 1 |
|
set was_already_loaded($pkgname) 0 |
|
package ifneeded $pkgname 1000 [subst {error "can't find package $pkgname - suppressed by packagesuppress"}] |
|
} else { |
|
set was_already_loaded($pkgname) 1 |
|
} |
|
} |
|
|
|
proc packagesuppress::unsuppress2 {pkgname} { |
|
variable was_already_loaded |
|
if {![info exists was_already_loaded($pkgname)]} { |
|
package forget $pkgname |
|
} |
|
variable suppressed |
|
if {[info exists suppressed($pkgname)]} { |
|
unset suppressed($pkgname) |
|
} |
|
|
|
} |
|
|
|
|
|
|
|
|