31 changed files with 12640 additions and 11455 deletions
@ -1,487 +1,487 @@
|
||||
|
||||
tcl::namespace::eval punk::config { |
||||
variable loaded |
||||
variable startup ;#include env overrides |
||||
variable running |
||||
variable punk_env_vars |
||||
variable other_env_vars |
||||
|
||||
variable vars |
||||
|
||||
namespace export {[a-z]*} |
||||
|
||||
#todo - XDG_DATA_HOME etc |
||||
#https://specifications.freedesktop.org/basedir-spec/latest/ |
||||
# see also: http://hiphish.github.io/blog/2020/08/30/dotfiles-were-a-mistake/ |
||||
|
||||
proc init {} { |
||||
variable defaults |
||||
variable startup |
||||
variable running |
||||
variable punk_env_vars |
||||
variable punk_env_vars_config |
||||
variable other_env_vars |
||||
variable other_env_vars_config |
||||
|
||||
set exename "" |
||||
catch { |
||||
#catch for safe interps |
||||
#safe base will return empty string, ordinary safe interp will raise error |
||||
set exename [tcl::info::nameofexecutable] |
||||
} |
||||
if {$exename ne ""} { |
||||
set exefolder [file dirname $exename] |
||||
#default file logs to logs folder at same level as exe if writable, or empty string |
||||
set log_folder [file normalize $exefolder/../logs] ;#~2ms |
||||
#tcl::dict::set startup scriptlib $exefolder/scriptlib |
||||
#tcl::dict::set startup apps $exefolder/../../punkapps |
||||
|
||||
#todo - use punk main.tcl location instead - exefolder doesn't work if system tclsh used etc |
||||
set default_scriptlib $exefolder/scriptlib |
||||
set default_apps $exefolder/../../punkapps |
||||
if {[file isdirectory $log_folder] && [file writable $log_folder]} { |
||||
#tcl::dict::set startup logfile_stdout $log_folder/repl-exec-stdout.txt |
||||
#tcl::dict::set startup logfile_stderr $log_folder/repl-exec-stderr.txt |
||||
set default_logfile_stdout $log_folder/repl-exec-stdout.txt |
||||
set default_logfile_stderr $log_folder/repl-exec-stderr.txt |
||||
} else { |
||||
set default_logfile_stdout "" |
||||
set default_logfile_stderr "" |
||||
} |
||||
} else { |
||||
#probably a safe interp - which cannot access info nameofexecutable even if access given to the location via punk::island |
||||
#review - todo? |
||||
#tcl::dict::set startup scriptlib "" |
||||
#tcl::dict::set startup apps "" |
||||
set default_scriptlib "" |
||||
set default_apps "" |
||||
set default_logfile_stdout "" |
||||
set default_logfile_stderr "" |
||||
} |
||||
|
||||
# auto_exec_mechanism ;#whether to use exec instead of experimental shellfilter::run |
||||
|
||||
#optional channel transforms on stdout/stderr. |
||||
#can sometimes be useful to distinguish eventloop stdout/stderr writes compared to those triggered directly from repl commands |
||||
#If no distinction necessary - should use default_color_<chan> |
||||
#The counterpart: default_color_<chan>_repl is a transform that is added and removed with each repl evaluation. |
||||
#startup color_stdout - parameters as suitable for punk::ansi::a+ (test with 'punk::ansi::a?') e.g "cyan bold" ;#not a good idea to default |
||||
set default_color_stdout brightwhite ;#stdout colour including background calls (after etc) |
||||
set default_color_stdout_repl "" ;#stdout colour applied during direct repl call only |
||||
#This wraps the stderr stream as it comes in with Ansi - probably best to default to empty.. but it's useful. |
||||
#set default_color_stderr "red bold" |
||||
#set default_color_stderr "web-lightsalmon" |
||||
set default_color_stderr yellow ;#limit to basic colours for wider terminal support. yellow = term-olive |
||||
set default_color_stderr_repl "" ;#during repl call only |
||||
|
||||
set homedir "" |
||||
if {[catch { |
||||
#depending on which build of tcl - some safe interps prior to bugfix https://core.tcl-lang.org/tcl/info/3aa487993f will return a homedir value in an unmodified safe interp |
||||
#other 'safe' interps may have explicitly made this available - we shouldn't override that decision here using interp issafe so we can't compensate for versions which shouldn't really be returning this in the safe interp |
||||
set homedir [file home] |
||||
} errM]} { |
||||
#tcl 8.6 doesn't have file home.. try again |
||||
if {[info exists ::env(HOME)]} { |
||||
set homedir $::env(HOME) |
||||
} |
||||
} |
||||
|
||||
|
||||
# per user xdg vars |
||||
# --- |
||||
set default_xdg_config_home "" ;#config data - portable |
||||
set default_xdg_data_home "" ;#data the user likely to want to be portable |
||||
set default_xdg_cache_home "" ;#local cache |
||||
set default_xdg_state_home "" ;#persistent user data such as logs, but not as important or as portable as those in xdg_data_home |
||||
# --- |
||||
set default_xdg_data_dirs "" ;#non-user specific |
||||
#xdg_config_dirs ? |
||||
#xdg_runtime_dir ? |
||||
|
||||
|
||||
#review. we are assuming if we can't get a home dir - then all the xdg vars including xdg_data_dirs aren't likely to be useful (as presumably filesystem access is absent) |
||||
#(safe interp generally won't have access to ::env either) |
||||
#This coupling doesn't necessarily hold - its possible the relevant env vars were copied to a safe interp - although that would be a policy that would make disabling 'info home' inconsistent. |
||||
if {$homedir ne ""} { |
||||
if {"windows" eq $::tcl_platform(platform)} { |
||||
#as much as I'd prefer to use ~/.local/share and ~/.config to keep them more consistent with unixlike platforms - the vast majority of apps put them where microsoft wants them. |
||||
#we have a choice of LOCALAPPDATA vs APPDATA (local to machine vs potentially roaming/redirected in a corporate environment) |
||||
#using the roaming location should not impact users who aren't using a domain controller but is potentially much more convenient for those who do. |
||||
if {[info exists ::env(APPDATA)]} { |
||||
set default_xdg_config_home $::env(APPDATA) |
||||
set default_xdg_data_home $::env(APPDATA) |
||||
} |
||||
|
||||
#The xdg_cache_home should be kept local |
||||
if {[info exists ::env(LOCALAPPDATA)]} { |
||||
set default_xdg_cache_home $::env(LOCALAPPDATA) |
||||
set default_xdg_state_home $::env(LOCALAPPDATA) |
||||
} |
||||
|
||||
if {[info exists ::env(PROGRAMDATA)]} { |
||||
#- equiv env(ALLUSERSPROFILE) ? |
||||
set default_xdg_data_dirs $::env(PROGRAMDATA) |
||||
} |
||||
|
||||
} else { |
||||
#follow defaults as specified on freedesktop.org e.g https://specifications.freedesktop.org/basedir-spec/latest/ar01s03.html |
||||
set default_xdg_config_home [file join $homedir .config] |
||||
set default_xdg_data_home [file join $homedir .local share] |
||||
set default_xdg_cache_home [file join $homedir .cache] |
||||
set default_xdg_state_home [file join $homedir .local state] |
||||
set default_xdg_data_dirs /usr/local/share |
||||
} |
||||
} |
||||
|
||||
set defaults [dict create\ |
||||
apps $default_apps\ |
||||
config ""\ |
||||
configset ".punkshell"\ |
||||
scriptlib $default_scriptlib\ |
||||
color_stdout $default_color_stdout\ |
||||
color_stdout_repl $default_color_stdout_repl\ |
||||
color_stderr $default_color_stderr\ |
||||
color_stderr_repl $default_color_stderr_repl\ |
||||
logfile_stdout $default_logfile_stdout\ |
||||
logfile_stderr $default_logfile_stderr\ |
||||
logfile_active 0\ |
||||
syslog_stdout "127.0.0.1:514"\ |
||||
syslog_stderr "127.0.0.1:514"\ |
||||
syslog_active 0\ |
||||
auto_exec_mechanism exec\ |
||||
auto_noexec 0\ |
||||
xdg_config_home $default_xdg_config_home\ |
||||
xdg_data_home $default_xdg_data_home\ |
||||
xdg_cache_home $default_xdg_cache_home\ |
||||
xdg_state_home $default_xdg_state_home\ |
||||
xdg_data_dirs $default_xdg_data_dirs\ |
||||
theme_posh_override ""\ |
||||
posh_theme ""\ |
||||
posh_themes_path ""\ |
||||
] |
||||
|
||||
set startup $defaults |
||||
#load values from saved config file - $xdg_config_home/punk/punk.config ? |
||||
#typically we want env vars to override the stored config - as env vars conventionally used on some commandlines. |
||||
#that's possibly ok for the PUNK_ vars |
||||
#however.. others like the xdg vars and NOCOLOR may apply to other apps.. and we may want to override them from the saved config? |
||||
#making some env vars override saved config values and some not would be potentially confusing. may need one/more specific settings or env vars to determine which takes precedence? |
||||
#simpler is probably just to let env vars take precedence - and warn when saving or viewing config that the saved values are being overridden |
||||
#- requiring user to manually unset any unwanted env vars when launching? |
||||
|
||||
#we are likely to want the saved configs for subshells/decks to override them however. |
||||
|
||||
#todo - load/save config file |
||||
|
||||
#todo - define which configvars are settable in env |
||||
#list of varname varinfo where varinfo is a sub dictionary (type key is mandatory, with value from: string,pathlist,boolean) |
||||
set punk_env_vars_config [dict create \ |
||||
PUNK_APPS {type pathlist}\ |
||||
PUNK_CONFIG {type string}\ |
||||
PUNK_CONFIGSET {type string}\ |
||||
PUNK_SCRIPTLIB {type string}\ |
||||
PUNK_AUTO_EXEC_MECHANISM {type string}\ |
||||
PUNK_AUTO_NOEXEC {type string default 0 help "set 1 to set Tcl's ::auto_noexec true.\nStops 'unknown' from running external programs"}\ |
||||
PUNK_COLOR_STDERR {type string help "stderr colour transform. Use 'punk::ansi::a?' to see colour names"}\ |
||||
PUNK_COLOR_STDERR_REPL {type string help "stderr colour transform only while command running (not active during 'after')"}\ |
||||
PUNK_COLOR_STDOUT {type string help "stdout colour transform. Use 'punk::ansi::a?' to see colour names"}\ |
||||
PUNK_COLOR_STDOUT_REPL {type string help "stdout colour transform only while command running (not active during 'after')"}\ |
||||
PUNK_LOGFILE_STDOUT {type string}\ |
||||
PUNK_LOGFILE_STDERR {type string}\ |
||||
PUNK_LOGFILE_ACTIVE {type string}\ |
||||
PUNK_SYSLOG_STDOUT {type string}\ |
||||
PUNK_SYSLOG_STDERR {type string}\ |
||||
PUNK_SYSLOG_ACTIVE {type string}\ |
||||
PUNK_THEME_POSH_OVERRIDE {type string}\ |
||||
] |
||||
set punk_env_vars [dict keys $punk_env_vars_config] |
||||
|
||||
#override with env vars if set |
||||
foreach {evar varinfo} $punk_env_vars_config { |
||||
if {[info exists ::env($evar)]} { |
||||
set vartype [dict get $varinfo type] |
||||
set f [set ::env($evar)] |
||||
if {$f ne "default"} { |
||||
#e.g PUNK_SCRIPTLIB -> scriptlib |
||||
set varname [tcl::string::tolower [tcl::string::range $evar 5 end]] |
||||
if {$vartype eq "pathlist"} { |
||||
#colon vs semicolon path sep is problematic for windows environments where unix-like systems such as cygwin/wsl are used and a variable may be set for either the native path separator or the unix-like system |
||||
#Even without the colon vs semicolon issue, native vs unix-like paths on windows mixed environment systems can cause grief. |
||||
#For now at least, we will simply respect the platform pathSeparator and hope the user manages the environment variables appropriately. |
||||
#some programs do automatic translation - which is a nice idea in principle - but is also prone to error as we don't know if it's already occurred or not depending on how things are launched. |
||||
#An example of where this sort of thing can go wrong is env(TCLLIBPATH) - which is defined as a space separated list not requiring further splitting |
||||
# - but some programs have been known to split this value on colon anyway, which breaks things on windows. |
||||
set paths [split $f $::tcl_platform(pathSeparator)] |
||||
set final [list] |
||||
#eliminate empty values (leading or trailing or extraneous separators) |
||||
foreach p $paths { |
||||
if {[tcl::string::trim $p] ne ""} { |
||||
lappend final $p |
||||
} |
||||
} |
||||
tcl::dict::set startup $varname $final |
||||
} else { |
||||
tcl::dict::set startup $varname $f |
||||
} |
||||
} |
||||
} |
||||
} |
||||
|
||||
# https://no-color.org |
||||
#if {[info exists ::env(NO_COLOR)]} { |
||||
# if {$::env(NO_COLOR) ne ""} { |
||||
# set colour_disabled 1 |
||||
# } |
||||
#} |
||||
set other_env_vars_config [dict create\ |
||||
NO_COLOR {type string}\ |
||||
XDG_CONFIG_HOME {type string}\ |
||||
XDG_DATA_HOME {type string}\ |
||||
XDG_CACHE_HOME {type string}\ |
||||
XDG_STATE_HOME {type string}\ |
||||
XDG_DATA_DIRS {type pathlist}\ |
||||
POSH_THEME {type string}\ |
||||
POSH_THEMES_PATH {type string}\ |
||||
TCLLIBPATH {type string}\ |
||||
] |
||||
lassign [split [info tclversion] .] tclmajorv tclminorv |
||||
#don't rely on lseq or punk::lib for now.. |
||||
set relevant_minors [list] |
||||
for {set i 0} {$i <= $tclminorv} {incr i} { |
||||
lappend relevant_minors $i |
||||
} |
||||
foreach minor $relevant_minors { |
||||
set vname TCL${tclmajorv}_${minor}_TM_PATH |
||||
if {$minor eq $tclminorv || [info exists ::env($vname)]} { |
||||
dict set other_env_vars_config $vname {type string} |
||||
} |
||||
} |
||||
set other_env_vars [dict keys $other_env_vars_config] |
||||
|
||||
foreach {evar varinfo} $other_env_vars_config { |
||||
if {[info exists ::env($evar)]} { |
||||
set vartype [dict get $varinfo type] |
||||
set f [set ::env($evar)] |
||||
if {$f ne "default"} { |
||||
set varname [tcl::string::tolower $evar] |
||||
if {$vartype eq "pathlist"} { |
||||
set paths [split $f $::tcl_platform(pathSeparator)] |
||||
set final [list] |
||||
#eliminate empty values (leading or trailing or extraneous separators) |
||||
foreach p $paths { |
||||
if {[tcl::string::trim $p] ne ""} { |
||||
lappend final $p |
||||
} |
||||
} |
||||
tcl::dict::set startup $varname $final |
||||
} else { |
||||
tcl::dict::set startup $varname $f |
||||
} |
||||
} |
||||
} |
||||
} |
||||
|
||||
|
||||
#unset -nocomplain vars |
||||
|
||||
#todo |
||||
set running [tcl::dict::create] |
||||
set running [tcl::dict::merge $running $startup] |
||||
} |
||||
init |
||||
|
||||
#todo |
||||
proc Apply {config} { |
||||
puts stderr "punk::config::Apply partially implemented" |
||||
set configname [string map {-config ""} $config] |
||||
if {$configname in {startup running}} { |
||||
upvar ::punk::config::$configname applyconfig |
||||
|
||||
if {[dict exists $applyconfig auto_noexec]} { |
||||
set auto [dict get $applyconfig auto_noexec] |
||||
if {![string is boolean -strict $auto]} { |
||||
error "config::Apply error - invalid data for auto_noexec:'$auto' - expected boolean" |
||||
} |
||||
if {$auto} { |
||||
set ::auto_noexec 1 |
||||
} else { |
||||
#puts "auto_noexec false" |
||||
unset -nocomplain ::auto_noexec |
||||
} |
||||
} |
||||
|
||||
} else { |
||||
error "no config named '$config' found" |
||||
} |
||||
return "apply done" |
||||
} |
||||
Apply startup |
||||
|
||||
#todo - consider how to divide up settings, categories, 'devices', decks etc |
||||
proc get_running_global {varname} { |
||||
variable running |
||||
if {[dict exists $running $varname]} { |
||||
return [dict get $running $varname] |
||||
} |
||||
error "No such global configuration item '$varname' found in running config" |
||||
} |
||||
proc get_startup_global {varname} { |
||||
variable startup |
||||
if {[dict exists $startup $varname]} { |
||||
return [dict get $startup $varname] |
||||
} |
||||
error "No such global configuration item '$varname' found in startup config" |
||||
} |
||||
|
||||
proc get {whichconfig {globfor *}} { |
||||
variable startup |
||||
variable running |
||||
switch -- $whichconfig { |
||||
config - startup - startup-config - startup-configuration { |
||||
#show *startup* config - different behaviour may be confusing to those used to router startup and running configs |
||||
set configdata $startup |
||||
} |
||||
running - running-config - running-configuration { |
||||
set configdata $running |
||||
} |
||||
default { |
||||
error "Unknown config name '$whichconfig' - try startup or running" |
||||
} |
||||
} |
||||
if {$globfor eq "*"} { |
||||
return $configdata |
||||
} else { |
||||
set keys [dict keys $configdata [string tolower $globfor]] |
||||
set filtered [dict create] |
||||
foreach k $keys { |
||||
dict set filtered $k [dict get $configdata $k] |
||||
} |
||||
return $filtered |
||||
} |
||||
} |
||||
|
||||
proc configure {args} { |
||||
set argdef { |
||||
@id -id ::punk::config::configure |
||||
@cmd -name punk::config::configure -help\ |
||||
"UNIMPLEMENTED" |
||||
@values -min 1 -max 1 |
||||
whichconfig -type string -choices {startup running stop} |
||||
} |
||||
set argd [punk::args::get_dict $argdef $args] |
||||
return "unimplemented - $argd" |
||||
} |
||||
|
||||
proc show {whichconfig {globfor *}} { |
||||
#todo - tables for console |
||||
set configdata [punk::config::get $whichconfig $globfor] |
||||
return [punk::lib::showdict $configdata] |
||||
} |
||||
|
||||
|
||||
|
||||
#e.g |
||||
# copy running-config startup-config |
||||
# copy startup-config test-config.cfg |
||||
# copy backup-config.cfg running-config |
||||
#review - consider the merge vs overwrite feature of some routers.. where copy to running-config does a merge rather than an overwrite |
||||
#This is to allow partial configs to be loaded to running, whereas a save of running to any target is always a complete configuration |
||||
proc copy {args} { |
||||
set argdef { |
||||
@id -id ::punk::config::copy |
||||
@cmd -name punk::config::copy -help\ |
||||
"Copy a partial or full configuration from one config to another |
||||
If a target config has additional settings, then the source config can be considered to be partial with regards to the target. |
||||
" |
||||
-type -default "" -choices {replace merge} -help\ |
||||
"Defaults to merge when target is running-config |
||||
Defaults to replace when source is running-config" |
||||
@values -min 2 -max 2 |
||||
fromconfig -help\ |
||||
"running or startup or file name (not fully implemented)" |
||||
toconfig -help\ |
||||
"running or startup or file name (not fully implemented)" |
||||
} |
||||
set argd [punk::args::get_dict $argdef $args] |
||||
set fromconfig [dict get $argd values fromconfig] |
||||
set toconfig [dict get $argd values toconfig] |
||||
set fromconfig [string map {-config ""} $fromconfig] |
||||
set toconfig [string map {-config ""} $toconfig] |
||||
|
||||
set copytype [dict get $argd opts -type] |
||||
|
||||
|
||||
#todo - warn & prompt if doing merge copy to startup |
||||
switch -exact -- $fromconfig-$toconfig { |
||||
running-startup { |
||||
if {$copytype eq ""} { |
||||
set copytype replace ;#full configuration |
||||
} |
||||
if {$copytype eq "replace"} { |
||||
error "punk::config::copy error. full configuration copy from running to startup config not yet supported" |
||||
} else { |
||||
error "punk::config::copy error. merge configuration copy from running to startup config not yet supported" |
||||
} |
||||
} |
||||
startup-running { |
||||
#default type merge - even though it's not always what is desired |
||||
if {$copytype eq ""} { |
||||
set copytype merge ;#load in a partial configuration |
||||
} |
||||
|
||||
#warn/prompt either way |
||||
if {$copytype eq "replace"} { |
||||
#some routers require use of a separate command for this branch. |
||||
#presumably to ensure the user doesn't accidentally load partials onto a running system |
||||
# |
||||
error "punk::config::copy error. full configuration copy from startup to overwrite running config not supported" |
||||
} else { |
||||
error "punk::config::copy error. merge copy from possibly partial configuration: startup to running config not currently supported" |
||||
} |
||||
} |
||||
default { |
||||
error "punk::config::copy error. copy must from running to startup or startup to running. File sources/targets not yet supported" |
||||
} |
||||
} |
||||
} |
||||
|
||||
|
||||
|
||||
|
||||
|
||||
} |
||||
|
||||
|
||||
|
||||
|
||||
|
||||
#todo - move to cli? |
||||
::tcl::namespace::eval punk::config { |
||||
#todo - something better - 'previous' rather than reverting to startup |
||||
proc channelcolors {{onoff {}}} { |
||||
variable running |
||||
variable startup |
||||
|
||||
if {![string length $onoff]} { |
||||
return [list stdout [dict get $running color_stdout] stderr [dict get $running color_stderr]] |
||||
} else { |
||||
if {![string is boolean $onoff]} { |
||||
error "channelcolors: invalid value $onoff - expected boolean: true|false|on|off|1|0|yes|no" |
||||
} |
||||
if {$onoff} { |
||||
dict set running color_stdout [dict get $startup color_stdout] |
||||
dict set running color_stderr [dict get $startup color_stderr] |
||||
} else { |
||||
dict set running color_stdout "" |
||||
dict set running color_stderr "" |
||||
} |
||||
} |
||||
return [list stdout [dict get $running color_stdout] stderr [dict get $running color_stderr]] |
||||
} |
||||
} |
||||
|
||||
package provide punk::config [tcl::namespace::eval punk::config { |
||||
variable version |
||||
set version 0.1 |
||||
|
||||
|
||||
tcl::namespace::eval punk::config { |
||||
variable loaded |
||||
variable startup ;#include env overrides |
||||
variable running |
||||
variable punk_env_vars |
||||
variable other_env_vars |
||||
|
||||
variable vars |
||||
|
||||
namespace export {[a-z]*} |
||||
|
||||
#todo - XDG_DATA_HOME etc |
||||
#https://specifications.freedesktop.org/basedir-spec/latest/ |
||||
# see also: http://hiphish.github.io/blog/2020/08/30/dotfiles-were-a-mistake/ |
||||
|
||||
proc init {} { |
||||
variable defaults |
||||
variable startup |
||||
variable running |
||||
variable punk_env_vars |
||||
variable punk_env_vars_config |
||||
variable other_env_vars |
||||
variable other_env_vars_config |
||||
|
||||
set exename "" |
||||
catch { |
||||
#catch for safe interps |
||||
#safe base will return empty string, ordinary safe interp will raise error |
||||
set exename [tcl::info::nameofexecutable] |
||||
} |
||||
if {$exename ne ""} { |
||||
set exefolder [file dirname $exename] |
||||
#default file logs to logs folder at same level as exe if writable, or empty string |
||||
set log_folder [file normalize $exefolder/../logs] ;#~2ms |
||||
#tcl::dict::set startup scriptlib $exefolder/scriptlib |
||||
#tcl::dict::set startup apps $exefolder/../../punkapps |
||||
|
||||
#todo - use punk main.tcl location instead - exefolder doesn't work if system tclsh used etc |
||||
set default_scriptlib $exefolder/scriptlib |
||||
set default_apps $exefolder/../../punkapps |
||||
if {[file isdirectory $log_folder] && [file writable $log_folder]} { |
||||
#tcl::dict::set startup logfile_stdout $log_folder/repl-exec-stdout.txt |
||||
#tcl::dict::set startup logfile_stderr $log_folder/repl-exec-stderr.txt |
||||
set default_logfile_stdout $log_folder/repl-exec-stdout.txt |
||||
set default_logfile_stderr $log_folder/repl-exec-stderr.txt |
||||
} else { |
||||
set default_logfile_stdout "" |
||||
set default_logfile_stderr "" |
||||
} |
||||
} else { |
||||
#probably a safe interp - which cannot access info nameofexecutable even if access given to the location via punk::island |
||||
#review - todo? |
||||
#tcl::dict::set startup scriptlib "" |
||||
#tcl::dict::set startup apps "" |
||||
set default_scriptlib "" |
||||
set default_apps "" |
||||
set default_logfile_stdout "" |
||||
set default_logfile_stderr "" |
||||
} |
||||
|
||||
# auto_exec_mechanism ;#whether to use exec instead of experimental shellfilter::run |
||||
|
||||
#optional channel transforms on stdout/stderr. |
||||
#can sometimes be useful to distinguish eventloop stdout/stderr writes compared to those triggered directly from repl commands |
||||
#If no distinction necessary - should use default_color_<chan> |
||||
#The counterpart: default_color_<chan>_repl is a transform that is added and removed with each repl evaluation. |
||||
#startup color_stdout - parameters as suitable for punk::ansi::a+ (test with 'punk::ansi::a?') e.g "cyan bold" ;#not a good idea to default |
||||
set default_color_stdout brightwhite ;#stdout colour including background calls (after etc) |
||||
set default_color_stdout_repl "" ;#stdout colour applied during direct repl call only |
||||
#This wraps the stderr stream as it comes in with Ansi - probably best to default to empty.. but it's useful. |
||||
#set default_color_stderr "red bold" |
||||
#set default_color_stderr "web-lightsalmon" |
||||
set default_color_stderr yellow ;#limit to basic colours for wider terminal support. yellow = term-olive |
||||
set default_color_stderr_repl "" ;#during repl call only |
||||
|
||||
set homedir "" |
||||
if {[catch { |
||||
#depending on which build of tcl - some safe interps prior to bugfix https://core.tcl-lang.org/tcl/info/3aa487993f will return a homedir value in an unmodified safe interp |
||||
#other 'safe' interps may have explicitly made this available - we shouldn't override that decision here using interp issafe so we can't compensate for versions which shouldn't really be returning this in the safe interp |
||||
set homedir [file home] |
||||
} errM]} { |
||||
#tcl 8.6 doesn't have file home.. try again |
||||
if {[info exists ::env(HOME)]} { |
||||
set homedir $::env(HOME) |
||||
} |
||||
} |
||||
|
||||
|
||||
# per user xdg vars |
||||
# --- |
||||
set default_xdg_config_home "" ;#config data - portable |
||||
set default_xdg_data_home "" ;#data the user likely to want to be portable |
||||
set default_xdg_cache_home "" ;#local cache |
||||
set default_xdg_state_home "" ;#persistent user data such as logs, but not as important or as portable as those in xdg_data_home |
||||
# --- |
||||
set default_xdg_data_dirs "" ;#non-user specific |
||||
#xdg_config_dirs ? |
||||
#xdg_runtime_dir ? |
||||
|
||||
|
||||
#review. we are assuming if we can't get a home dir - then all the xdg vars including xdg_data_dirs aren't likely to be useful (as presumably filesystem access is absent) |
||||
#(safe interp generally won't have access to ::env either) |
||||
#This coupling doesn't necessarily hold - its possible the relevant env vars were copied to a safe interp - although that would be a policy that would make disabling 'info home' inconsistent. |
||||
if {$homedir ne ""} { |
||||
if {"windows" eq $::tcl_platform(platform)} { |
||||
#as much as I'd prefer to use ~/.local/share and ~/.config to keep them more consistent with unixlike platforms - the vast majority of apps put them where microsoft wants them. |
||||
#we have a choice of LOCALAPPDATA vs APPDATA (local to machine vs potentially roaming/redirected in a corporate environment) |
||||
#using the roaming location should not impact users who aren't using a domain controller but is potentially much more convenient for those who do. |
||||
if {[info exists ::env(APPDATA)]} { |
||||
set default_xdg_config_home $::env(APPDATA) |
||||
set default_xdg_data_home $::env(APPDATA) |
||||
} |
||||
|
||||
#The xdg_cache_home should be kept local |
||||
if {[info exists ::env(LOCALAPPDATA)]} { |
||||
set default_xdg_cache_home $::env(LOCALAPPDATA) |
||||
set default_xdg_state_home $::env(LOCALAPPDATA) |
||||
} |
||||
|
||||
if {[info exists ::env(PROGRAMDATA)]} { |
||||
#- equiv env(ALLUSERSPROFILE) ? |
||||
set default_xdg_data_dirs $::env(PROGRAMDATA) |
||||
} |
||||
|
||||
} else { |
||||
#follow defaults as specified on freedesktop.org e.g https://specifications.freedesktop.org/basedir-spec/latest/ar01s03.html |
||||
set default_xdg_config_home [file join $homedir .config] |
||||
set default_xdg_data_home [file join $homedir .local share] |
||||
set default_xdg_cache_home [file join $homedir .cache] |
||||
set default_xdg_state_home [file join $homedir .local state] |
||||
set default_xdg_data_dirs /usr/local/share |
||||
} |
||||
} |
||||
|
||||
set defaults [dict create\ |
||||
apps $default_apps\ |
||||
config ""\ |
||||
configset ".punkshell"\ |
||||
scriptlib $default_scriptlib\ |
||||
color_stdout $default_color_stdout\ |
||||
color_stdout_repl $default_color_stdout_repl\ |
||||
color_stderr $default_color_stderr\ |
||||
color_stderr_repl $default_color_stderr_repl\ |
||||
logfile_stdout $default_logfile_stdout\ |
||||
logfile_stderr $default_logfile_stderr\ |
||||
logfile_active 0\ |
||||
syslog_stdout "127.0.0.1:514"\ |
||||
syslog_stderr "127.0.0.1:514"\ |
||||
syslog_active 0\ |
||||
auto_exec_mechanism exec\ |
||||
auto_noexec 0\ |
||||
xdg_config_home $default_xdg_config_home\ |
||||
xdg_data_home $default_xdg_data_home\ |
||||
xdg_cache_home $default_xdg_cache_home\ |
||||
xdg_state_home $default_xdg_state_home\ |
||||
xdg_data_dirs $default_xdg_data_dirs\ |
||||
theme_posh_override ""\ |
||||
posh_theme ""\ |
||||
posh_themes_path ""\ |
||||
] |
||||
|
||||
set startup $defaults |
||||
#load values from saved config file - $xdg_config_home/punk/punk.config ? |
||||
#typically we want env vars to override the stored config - as env vars conventionally used on some commandlines. |
||||
#that's possibly ok for the PUNK_ vars |
||||
#however.. others like the xdg vars and NOCOLOR may apply to other apps.. and we may want to override them from the saved config? |
||||
#making some env vars override saved config values and some not would be potentially confusing. may need one/more specific settings or env vars to determine which takes precedence? |
||||
#simpler is probably just to let env vars take precedence - and warn when saving or viewing config that the saved values are being overridden |
||||
#- requiring user to manually unset any unwanted env vars when launching? |
||||
|
||||
#we are likely to want the saved configs for subshells/decks to override them however. |
||||
|
||||
#todo - load/save config file |
||||
|
||||
#todo - define which configvars are settable in env |
||||
#list of varname varinfo where varinfo is a sub dictionary (type key is mandatory, with value from: string,pathlist,boolean) |
||||
set punk_env_vars_config [dict create \ |
||||
PUNK_APPS {type pathlist}\ |
||||
PUNK_CONFIG {type string}\ |
||||
PUNK_CONFIGSET {type string}\ |
||||
PUNK_SCRIPTLIB {type string}\ |
||||
PUNK_AUTO_EXEC_MECHANISM {type string}\ |
||||
PUNK_AUTO_NOEXEC {type string default 0 help "set 1 to set Tcl's ::auto_noexec true.\nStops 'unknown' from running external programs"}\ |
||||
PUNK_COLOR_STDERR {type string help "stderr colour transform. Use 'punk::ansi::a?' to see colour names"}\ |
||||
PUNK_COLOR_STDERR_REPL {type string help "stderr colour transform only while command running (not active during 'after')"}\ |
||||
PUNK_COLOR_STDOUT {type string help "stdout colour transform. Use 'punk::ansi::a?' to see colour names"}\ |
||||
PUNK_COLOR_STDOUT_REPL {type string help "stdout colour transform only while command running (not active during 'after')"}\ |
||||
PUNK_LOGFILE_STDOUT {type string}\ |
||||
PUNK_LOGFILE_STDERR {type string}\ |
||||
PUNK_LOGFILE_ACTIVE {type string}\ |
||||
PUNK_SYSLOG_STDOUT {type string}\ |
||||
PUNK_SYSLOG_STDERR {type string}\ |
||||
PUNK_SYSLOG_ACTIVE {type string}\ |
||||
PUNK_THEME_POSH_OVERRIDE {type string}\ |
||||
] |
||||
set punk_env_vars [dict keys $punk_env_vars_config] |
||||
|
||||
#override with env vars if set |
||||
foreach {evar varinfo} $punk_env_vars_config { |
||||
if {[info exists ::env($evar)]} { |
||||
set vartype [dict get $varinfo type] |
||||
set f [set ::env($evar)] |
||||
if {$f ne "default"} { |
||||
#e.g PUNK_SCRIPTLIB -> scriptlib |
||||
set varname [tcl::string::tolower [tcl::string::range $evar 5 end]] |
||||
if {$vartype eq "pathlist"} { |
||||
#colon vs semicolon path sep is problematic for windows environments where unix-like systems such as cygwin/wsl are used and a variable may be set for either the native path separator or the unix-like system |
||||
#Even without the colon vs semicolon issue, native vs unix-like paths on windows mixed environment systems can cause grief. |
||||
#For now at least, we will simply respect the platform pathSeparator and hope the user manages the environment variables appropriately. |
||||
#some programs do automatic translation - which is a nice idea in principle - but is also prone to error as we don't know if it's already occurred or not depending on how things are launched. |
||||
#An example of where this sort of thing can go wrong is env(TCLLIBPATH) - which is defined as a space separated list not requiring further splitting |
||||
# - but some programs have been known to split this value on colon anyway, which breaks things on windows. |
||||
set paths [split $f $::tcl_platform(pathSeparator)] |
||||
set final [list] |
||||
#eliminate empty values (leading or trailing or extraneous separators) |
||||
foreach p $paths { |
||||
if {[tcl::string::trim $p] ne ""} { |
||||
lappend final $p |
||||
} |
||||
} |
||||
tcl::dict::set startup $varname $final |
||||
} else { |
||||
tcl::dict::set startup $varname $f |
||||
} |
||||
} |
||||
} |
||||
} |
||||
|
||||
# https://no-color.org |
||||
#if {[info exists ::env(NO_COLOR)]} { |
||||
# if {$::env(NO_COLOR) ne ""} { |
||||
# set colour_disabled 1 |
||||
# } |
||||
#} |
||||
set other_env_vars_config [dict create\ |
||||
NO_COLOR {type string}\ |
||||
XDG_CONFIG_HOME {type string}\ |
||||
XDG_DATA_HOME {type string}\ |
||||
XDG_CACHE_HOME {type string}\ |
||||
XDG_STATE_HOME {type string}\ |
||||
XDG_DATA_DIRS {type pathlist}\ |
||||
POSH_THEME {type string}\ |
||||
POSH_THEMES_PATH {type string}\ |
||||
TCLLIBPATH {type string}\ |
||||
] |
||||
lassign [split [info tclversion] .] tclmajorv tclminorv |
||||
#don't rely on lseq or punk::lib for now.. |
||||
set relevant_minors [list] |
||||
for {set i 0} {$i <= $tclminorv} {incr i} { |
||||
lappend relevant_minors $i |
||||
} |
||||
foreach minor $relevant_minors { |
||||
set vname TCL${tclmajorv}_${minor}_TM_PATH |
||||
if {$minor eq $tclminorv || [info exists ::env($vname)]} { |
||||
dict set other_env_vars_config $vname {type string} |
||||
} |
||||
} |
||||
set other_env_vars [dict keys $other_env_vars_config] |
||||
|
||||
foreach {evar varinfo} $other_env_vars_config { |
||||
if {[info exists ::env($evar)]} { |
||||
set vartype [dict get $varinfo type] |
||||
set f [set ::env($evar)] |
||||
if {$f ne "default"} { |
||||
set varname [tcl::string::tolower $evar] |
||||
if {$vartype eq "pathlist"} { |
||||
set paths [split $f $::tcl_platform(pathSeparator)] |
||||
set final [list] |
||||
#eliminate empty values (leading or trailing or extraneous separators) |
||||
foreach p $paths { |
||||
if {[tcl::string::trim $p] ne ""} { |
||||
lappend final $p |
||||
} |
||||
} |
||||
tcl::dict::set startup $varname $final |
||||
} else { |
||||
tcl::dict::set startup $varname $f |
||||
} |
||||
} |
||||
} |
||||
} |
||||
|
||||
|
||||
#unset -nocomplain vars |
||||
|
||||
#todo |
||||
set running [tcl::dict::create] |
||||
set running [tcl::dict::merge $running $startup] |
||||
} |
||||
init |
||||
|
||||
#todo |
||||
proc Apply {config} { |
||||
puts stderr "punk::config::Apply partially implemented" |
||||
set configname [string map {-config ""} $config] |
||||
if {$configname in {startup running}} { |
||||
upvar ::punk::config::$configname applyconfig |
||||
|
||||
if {[dict exists $applyconfig auto_noexec]} { |
||||
set auto [dict get $applyconfig auto_noexec] |
||||
if {![string is boolean -strict $auto]} { |
||||
error "config::Apply error - invalid data for auto_noexec:'$auto' - expected boolean" |
||||
} |
||||
if {$auto} { |
||||
set ::auto_noexec 1 |
||||
} else { |
||||
#puts "auto_noexec false" |
||||
unset -nocomplain ::auto_noexec |
||||
} |
||||
} |
||||
|
||||
} else { |
||||
error "no config named '$config' found" |
||||
} |
||||
return "apply done" |
||||
} |
||||
Apply startup |
||||
|
||||
#todo - consider how to divide up settings, categories, 'devices', decks etc |
||||
proc get_running_global {varname} { |
||||
variable running |
||||
if {[dict exists $running $varname]} { |
||||
return [dict get $running $varname] |
||||
} |
||||
error "No such global configuration item '$varname' found in running config" |
||||
} |
||||
proc get_startup_global {varname} { |
||||
variable startup |
||||
if {[dict exists $startup $varname]} { |
||||
return [dict get $startup $varname] |
||||
} |
||||
error "No such global configuration item '$varname' found in startup config" |
||||
} |
||||
|
||||
proc get {whichconfig {globfor *}} { |
||||
variable startup |
||||
variable running |
||||
switch -- $whichconfig { |
||||
config - startup - startup-config - startup-configuration { |
||||
#show *startup* config - different behaviour may be confusing to those used to router startup and running configs |
||||
set configdata $startup |
||||
} |
||||
running - running-config - running-configuration { |
||||
set configdata $running |
||||
} |
||||
default { |
||||
error "Unknown config name '$whichconfig' - try startup or running" |
||||
} |
||||
} |
||||
if {$globfor eq "*"} { |
||||
return $configdata |
||||
} else { |
||||
set keys [dict keys $configdata [string tolower $globfor]] |
||||
set filtered [dict create] |
||||
foreach k $keys { |
||||
dict set filtered $k [dict get $configdata $k] |
||||
} |
||||
return $filtered |
||||
} |
||||
} |
||||
|
||||
proc configure {args} { |
||||
set argdef { |
||||
@id -id ::punk::config::configure |
||||
@cmd -name punk::config::configure -help\ |
||||
"UNIMPLEMENTED" |
||||
@values -min 1 -max 1 |
||||
whichconfig -type string -choices {startup running stop} |
||||
} |
||||
set argd [punk::args::get_dict $argdef $args] |
||||
return "unimplemented - $argd" |
||||
} |
||||
|
||||
proc show {whichconfig {globfor *}} { |
||||
#todo - tables for console |
||||
set configdata [punk::config::get $whichconfig $globfor] |
||||
return [punk::lib::showdict $configdata] |
||||
} |
||||
|
||||
|
||||
|
||||
#e.g |
||||
# copy running-config startup-config |
||||
# copy startup-config test-config.cfg |
||||
# copy backup-config.cfg running-config |
||||
#review - consider the merge vs overwrite feature of some routers.. where copy to running-config does a merge rather than an overwrite |
||||
#This is to allow partial configs to be loaded to running, whereas a save of running to any target is always a complete configuration |
||||
proc copy {args} { |
||||
set argdef { |
||||
@id -id ::punk::config::copy |
||||
@cmd -name punk::config::copy -help\ |
||||
"Copy a partial or full configuration from one config to another |
||||
If a target config has additional settings, then the source config can be considered to be partial with regards to the target. |
||||
" |
||||
-type -default "" -choices {replace merge} -help\ |
||||
"Defaults to merge when target is running-config |
||||
Defaults to replace when source is running-config" |
||||
@values -min 2 -max 2 |
||||
fromconfig -help\ |
||||
"running or startup or file name (not fully implemented)" |
||||
toconfig -help\ |
||||
"running or startup or file name (not fully implemented)" |
||||
} |
||||
set argd [punk::args::get_dict $argdef $args] |
||||
set fromconfig [dict get $argd values fromconfig] |
||||
set toconfig [dict get $argd values toconfig] |
||||
set fromconfig [string map {-config ""} $fromconfig] |
||||
set toconfig [string map {-config ""} $toconfig] |
||||
|
||||
set copytype [dict get $argd opts -type] |
||||
|
||||
|
||||
#todo - warn & prompt if doing merge copy to startup |
||||
switch -exact -- $fromconfig-$toconfig { |
||||
running-startup { |
||||
if {$copytype eq ""} { |
||||
set copytype replace ;#full configuration |
||||
} |
||||
if {$copytype eq "replace"} { |
||||
error "punk::config::copy error. full configuration copy from running to startup config not yet supported" |
||||
} else { |
||||
error "punk::config::copy error. merge configuration copy from running to startup config not yet supported" |
||||
} |
||||
} |
||||
startup-running { |
||||
#default type merge - even though it's not always what is desired |
||||
if {$copytype eq ""} { |
||||
set copytype merge ;#load in a partial configuration |
||||
} |
||||
|
||||
#warn/prompt either way |
||||
if {$copytype eq "replace"} { |
||||
#some routers require use of a separate command for this branch. |
||||
#presumably to ensure the user doesn't accidentally load partials onto a running system |
||||
# |
||||
error "punk::config::copy error. full configuration copy from startup to overwrite running config not supported" |
||||
} else { |
||||
error "punk::config::copy error. merge copy from possibly partial configuration: startup to running config not currently supported" |
||||
} |
||||
} |
||||
default { |
||||
error "punk::config::copy error. copy must from running to startup or startup to running. File sources/targets not yet supported" |
||||
} |
||||
} |
||||
} |
||||
|
||||
|
||||
|
||||
|
||||
|
||||
} |
||||
|
||||
|
||||
|
||||
|
||||
|
||||
#todo - move to cli? |
||||
::tcl::namespace::eval punk::config { |
||||
#todo - something better - 'previous' rather than reverting to startup |
||||
proc channelcolors {{onoff {}}} { |
||||
variable running |
||||
variable startup |
||||
|
||||
if {![string length $onoff]} { |
||||
return [list stdout [dict get $running color_stdout] stderr [dict get $running color_stderr]] |
||||
} else { |
||||
if {![string is boolean $onoff]} { |
||||
error "channelcolors: invalid value $onoff - expected boolean: true|false|on|off|1|0|yes|no" |
||||
} |
||||
if {$onoff} { |
||||
dict set running color_stdout [dict get $startup color_stdout] |
||||
dict set running color_stderr [dict get $startup color_stderr] |
||||
} else { |
||||
dict set running color_stdout "" |
||||
dict set running color_stderr "" |
||||
} |
||||
} |
||||
return [list stdout [dict get $running color_stdout] stderr [dict get $running color_stderr]] |
||||
} |
||||
} |
||||
|
||||
package provide punk::config [tcl::namespace::eval punk::config { |
||||
variable version |
||||
set version 0.1 |
||||
|
||||
}] |
||||
@ -1,164 +1,163 @@
|
||||
#punkapps app manager |
||||
# deck cli |
||||
|
||||
namespace eval punk::mod::cli { |
||||
namespace export help list run |
||||
namespace ensemble create |
||||
|
||||
# namespace ensemble configure [namespace current] -unknown punk::mod::cli::_unknown |
||||
if 0 { |
||||
proc _unknown {ns args} { |
||||
puts stderr "punk::mod::cli::_unknown '$ns' '$args'" |
||||
puts stderr "punk::mod::cli::help $args" |
||||
puts stderr "arglen:[llength $args]" |
||||
punk::mod::cli::help {*}$args |
||||
} |
||||
} |
||||
|
||||
#cli must have _init method - usually used to load commandsets lazily |
||||
# |
||||
variable initialised 0 |
||||
proc _init {args} { |
||||
variable initialised |
||||
if {$initialised} { |
||||
return |
||||
} |
||||
#... |
||||
set initialised 1 |
||||
} |
||||
|
||||
proc help {args} { |
||||
set basehelp [punk::mix::base help {*}$args] |
||||
#namespace export |
||||
return $basehelp |
||||
} |
||||
proc getraw {appname} { |
||||
upvar ::punk::config::running running_config |
||||
set app_folders [dict get $running_config apps] |
||||
#todo search each app folder |
||||
set bases [::list] |
||||
set versions [::list] |
||||
set mains [::list] |
||||
set appinfo [::list bases {} mains {} versions {}] |
||||
|
||||
foreach containerfolder $app_folders { |
||||
lappend bases $containerfolder |
||||
if {[file exists $containerfolder]} { |
||||
if {[file exists $containerfolder/$appname/main.tcl]} { |
||||
#exact match - only return info for the exact one specified |
||||
set namematches $appname |
||||
set parts [split $appname -] |
||||
} else { |
||||
set namematches [glob -nocomplain -dir $containerfolder -type d -tail ${appname}-*] |
||||
set namematches [lsort $namematches] ;#todo - -ascii? -dictionary? natsort? |
||||
} |
||||
foreach nm $namematches { |
||||
set mainfile $containerfolder/$nm/main.tcl |
||||
set parts [split $nm -] |
||||
if {[llength $parts] == 1} { |
||||
set ver "" |
||||
} else { |
||||
set ver [lindex $parts end] |
||||
} |
||||
if {$ver ni $versions} { |
||||
lappend versions $ver |
||||
lappend mains $ver $mainfile |
||||
} else { |
||||
puts stderr "punk::apps::app version '$ver' of app '$appname' already encountered at $mainfile. (will use earliest encountered in running-config apps and ignore others of same version)" |
||||
} |
||||
} |
||||
} else { |
||||
puts stderr "punk::apps::app missing apps_folder:'$containerfolder' Ensure apps_folder is set in punk::config" |
||||
} |
||||
} |
||||
dict set appinfo versions $versions |
||||
#todo - natsort! |
||||
set sorted_versions [lsort $versions] |
||||
set latest [lindex $sorted_versions 0] |
||||
if {$latest eq "" && [llength $sorted_versions] > 1} { |
||||
set latest [lindex $sorted_versions 1 |
||||
} |
||||
dict set appinfo latest $latest |
||||
|
||||
dict set appinfo bases $bases |
||||
dict set appinfo mains $mains |
||||
return $appinfo |
||||
} |
||||
|
||||
proc list {{glob *}} { |
||||
upvar ::punk::config::running running_config |
||||
set apps_folder [dict get $running_config apps] |
||||
if {[file exists $apps_folder]} { |
||||
if {[file exists $apps_folder/$glob]} { |
||||
#tailcall source $apps_folder/$glob/main.tcl |
||||
return $glob |
||||
} |
||||
set apps [glob -nocomplain -dir $apps_folder -type d -tail $glob] |
||||
if {[llength $apps] == 0} { |
||||
if {[string first * $glob] <0 && [string first ? $glob] <0} { |
||||
#no glob chars supplied - only launch if exact match for name part |
||||
set namematches [glob -nocomplain -dir $apps_folder -type d -tail ${glob}-*] |
||||
set namematches [lsort $namematches] ;#todo - -ascii? -dictionary? natsort? |
||||
if {[llength $namematches] > 0} { |
||||
set latest [lindex $namematches end] |
||||
lassign $latest nm ver |
||||
#tailcall source $apps_folder/$latest/main.tcl |
||||
} |
||||
} |
||||
} |
||||
|
||||
return $apps |
||||
} |
||||
} |
||||
|
||||
#todo - way to launch as separate process |
||||
# solo-opts only before appname - args following appname are passed to the app |
||||
proc run {args} { |
||||
set nameposn [lsearch -not $args -*] |
||||
if {$nameposn < 0} { |
||||
error "punkapp::run unable to determine application name" |
||||
} |
||||
set appname [lindex $args $nameposn] |
||||
set controlargs [lrange $args 0 $nameposn-1] |
||||
set appargs [lrange $args $nameposn+1 end] |
||||
|
||||
set appinfo [punk::mod::cli::getraw $appname] |
||||
if {[llength [dict get $appinfo versions]]} { |
||||
set ver [dict get $appinfo latest] |
||||
puts stdout "info: $appinfo" |
||||
set ::argc [llength $appargs] |
||||
set ::argv $appargs |
||||
source [dict get $appinfo mains $ver] |
||||
if {"-hideconsole" in $controlargs} { |
||||
puts stderr "attempting console hide" |
||||
#todo - something better - a callback when window mapped? |
||||
after 500 {::punkapp::hide_console} |
||||
} |
||||
return $appinfo |
||||
} else { |
||||
error "punk::mod::cli unable to run '$appname'. main.tcl not found in [dict get $appinfo bases]" |
||||
} |
||||
} |
||||
|
||||
|
||||
} |
||||
|
||||
namespace eval punk::mod::cli { |
||||
proc _cli {args} { |
||||
#don't use tailcall - base uses info level to determine caller |
||||
::punk::mix::base::_cli {*}$args |
||||
} |
||||
variable default_command help |
||||
package require punk::mix::base |
||||
package require punk::overlay |
||||
punk::overlay::custom_from_base [namespace current] ::punk::mix::base |
||||
} |
||||
|
||||
package provide punk::mod [namespace eval punk::mod { |
||||
variable version |
||||
set version 0.1 |
||||
|
||||
}] |
||||
|
||||
|
||||
|
||||
#punkapps app manager |
||||
# deck cli |
||||
|
||||
namespace eval punk::mod::cli { |
||||
namespace export help list run |
||||
namespace ensemble create |
||||
|
||||
# namespace ensemble configure [namespace current] -unknown punk::mod::cli::_unknown |
||||
if 0 { |
||||
proc _unknown {ns args} { |
||||
puts stderr "punk::mod::cli::_unknown '$ns' '$args'" |
||||
puts stderr "punk::mod::cli::help $args" |
||||
puts stderr "arglen:[llength $args]" |
||||
punk::mod::cli::help {*}$args |
||||
} |
||||
} |
||||
|
||||
#cli must have _init method - usually used to load commandsets lazily |
||||
# |
||||
variable initialised 0 |
||||
proc _init {args} { |
||||
variable initialised |
||||
if {$initialised} { |
||||
return |
||||
} |
||||
#... |
||||
set initialised 1 |
||||
} |
||||
|
||||
proc help {args} { |
||||
set basehelp [punk::mix::base help {*}$args] |
||||
#namespace export |
||||
return $basehelp |
||||
} |
||||
proc getraw {appname} { |
||||
upvar ::punk::config::running running_config |
||||
set app_folders [dict get $running_config apps] |
||||
#todo search each app folder |
||||
set bases [::list] |
||||
set versions [::list] |
||||
set mains [::list] |
||||
set appinfo [::list bases {} mains {} versions {}] |
||||
|
||||
foreach containerfolder $app_folders { |
||||
lappend bases $containerfolder |
||||
if {[file exists $containerfolder]} { |
||||
if {[file exists $containerfolder/$appname/main.tcl]} { |
||||
#exact match - only return info for the exact one specified |
||||
set namematches $appname |
||||
set parts [split $appname -] |
||||
} else { |
||||
set namematches [glob -nocomplain -dir $containerfolder -type d -tail ${appname}-*] |
||||
set namematches [lsort $namematches] ;#todo - -ascii? -dictionary? natsort? |
||||
} |
||||
foreach nm $namematches { |
||||
set mainfile $containerfolder/$nm/main.tcl |
||||
set parts [split $nm -] |
||||
if {[llength $parts] == 1} { |
||||
set ver "" |
||||
} else { |
||||
set ver [lindex $parts end] |
||||
} |
||||
if {$ver ni $versions} { |
||||
lappend versions $ver |
||||
lappend mains $ver $mainfile |
||||
} else { |
||||
puts stderr "punk::apps::app version '$ver' of app '$appname' already encountered at $mainfile. (will use earliest encountered in running-config apps and ignore others of same version)" |
||||
} |
||||
} |
||||
} else { |
||||
puts stderr "punk::apps::app missing apps_folder:'$containerfolder' Ensure apps_folder is set in punk::config" |
||||
} |
||||
} |
||||
dict set appinfo versions $versions |
||||
#todo - natsort! |
||||
set sorted_versions [lsort $versions] |
||||
set latest [lindex $sorted_versions 0] |
||||
if {$latest eq "" && [llength $sorted_versions] > 1} { |
||||
set latest [lindex $sorted_versions 1] |
||||
} |
||||
dict set appinfo latest $latest |
||||
|
||||
dict set appinfo bases $bases |
||||
dict set appinfo mains $mains |
||||
return $appinfo |
||||
} |
||||
|
||||
proc list {{glob *}} { |
||||
upvar ::punk::config::running running_config |
||||
set apps_folder [dict get $running_config apps] |
||||
if {[file exists $apps_folder]} { |
||||
if {[file exists $apps_folder/$glob]} { |
||||
#tailcall source $apps_folder/$glob/main.tcl |
||||
return $glob |
||||
} |
||||
set apps [glob -nocomplain -dir $apps_folder -type d -tail $glob] |
||||
if {[llength $apps] == 0} { |
||||
if {[string first * $glob] <0 && [string first ? $glob] <0} { |
||||
#no glob chars supplied - only launch if exact match for name part |
||||
set namematches [glob -nocomplain -dir $apps_folder -type d -tail ${glob}-*] |
||||
set namematches [lsort $namematches] ;#todo - -ascii? -dictionary? natsort? |
||||
if {[llength $namematches] > 0} { |
||||
set latest [lindex $namematches end] |
||||
lassign $latest nm ver |
||||
#tailcall source $apps_folder/$latest/main.tcl |
||||
} |
||||
} |
||||
} |
||||
|
||||
return $apps |
||||
} |
||||
} |
||||
|
||||
#todo - way to launch as separate process |
||||
# solo-opts only before appname - args following appname are passed to the app |
||||
proc run {args} { |
||||
set nameposn [lsearch -not $args -*] |
||||
if {$nameposn < 0} { |
||||
error "punkapp::run unable to determine application name" |
||||
} |
||||
set appname [lindex $args $nameposn] |
||||
set controlargs [lrange $args 0 $nameposn-1] |
||||
set appargs [lrange $args $nameposn+1 end] |
||||
|
||||
set appinfo [punk::mod::cli::getraw $appname] |
||||
if {[llength [dict get $appinfo versions]]} { |
||||
set ver [dict get $appinfo latest] |
||||
puts stdout "info: $appinfo" |
||||
set ::argc [llength $appargs] |
||||
set ::argv $appargs |
||||
source [dict get $appinfo mains $ver] |
||||
if {"-hideconsole" in $controlargs} { |
||||
puts stderr "attempting console hide" |
||||
#todo - something better - a callback when window mapped? |
||||
after 500 {::punkapp::hide_console} |
||||
} |
||||
return $appinfo |
||||
} else { |
||||
error "punk::mod::cli unable to run '$appname'. main.tcl not found in [dict get $appinfo bases]" |
||||
} |
||||
} |
||||
|
||||
|
||||
} |
||||
|
||||
namespace eval punk::mod::cli { |
||||
proc _cli {args} { |
||||
#don't use tailcall - base uses info level to determine caller |
||||
::punk::mix::base::_cli {*}$args |
||||
} |
||||
variable default_command help |
||||
package require punk::mix::base |
||||
package require punk::overlay |
||||
punk::overlay::custom_from_base [namespace current] ::punk::mix::base |
||||
} |
||||
|
||||
package provide punk::mod [namespace eval punk::mod { |
||||
variable version |
||||
set version 0.1 |
||||
}] |
||||
|
||||
|
||||
|
||||
|
||||
@ -1,239 +1,239 @@
|
||||
#utilities for punk apps to call |
||||
|
||||
package provide punkapp [namespace eval punkapp { |
||||
variable version |
||||
set version 0.1 |
||||
}] |
||||
|
||||
namespace eval punkapp { |
||||
variable result |
||||
variable waiting "no" |
||||
proc hide_dot_window {} { |
||||
#alternative to wm withdraw . |
||||
#see https://wiki.tcl-lang.org/page/wm+withdraw |
||||
wm geometry . 1x1+0+0 |
||||
wm overrideredirect . 1 |
||||
wm transient . |
||||
} |
||||
proc is_toplevel {w} { |
||||
if {![llength [info commands winfo]]} { |
||||
return 0 |
||||
} |
||||
expr {[winfo toplevel $w] eq $w && ![catch {$w cget -menu}]} |
||||
} |
||||
proc get_toplevels {{w .}} { |
||||
if {![llength [info commands winfo]]} { |
||||
return [list] |
||||
} |
||||
set list {} |
||||
if {[is_toplevel $w]} { |
||||
lappend list $w |
||||
} |
||||
foreach w [winfo children $w] { |
||||
lappend list {*}[get_toplevels $w] |
||||
} |
||||
return $list |
||||
} |
||||
|
||||
proc make_toplevel_next {prefix} { |
||||
set top [get_toplevel_next $prefix] |
||||
return [toplevel $top] |
||||
} |
||||
#possible race condition if multiple calls made without actually creating the toplevel, or gap if highest existing closed in the meantime |
||||
#todo - reserve_toplevel_next ? keep list of toplevels considered 'allocated' even if never created or already destroyed? what usecase? |
||||
#can call wm withdraw to to reserve newly created toplevel. To stop re-use of existing names after destruction would require a list or at least a record of highest created for each prefix |
||||
proc get_toplevel_next {prefix} { |
||||
set base [string trim $prefix .] ;# .myapp -> myapp .myapp.somewindow -> myapp.somewindow . -> "" |
||||
|
||||
|
||||
|
||||
} |
||||
proc exit {{toplevel ""}} { |
||||
variable waiting |
||||
variable result |
||||
variable default_result |
||||
set toplevels [get_toplevels] |
||||
if {[string length $toplevel]} { |
||||
set wposn [lsearch $toplevels $toplevel] |
||||
if {$wposn > 0} { |
||||
destroy $toplevel |
||||
} |
||||
} else { |
||||
#review |
||||
if {[package provide punk::repl::codethread] ne "" && [punk::repl::codethread::is_running]} { |
||||
puts stderr "punkapp::exit called without toplevel - showing console" |
||||
show_console |
||||
return 0 |
||||
} else { |
||||
puts stderr "punkapp::exit called without toplevel - exiting" |
||||
if {$waiting ne "no"} { |
||||
if {[info exists result(shell)]} { |
||||
set temp [set result(shell)] |
||||
unset result(shell) |
||||
set waiting $temp |
||||
} else { |
||||
set waiting "" |
||||
} |
||||
} else { |
||||
::exit |
||||
} |
||||
} |
||||
} |
||||
|
||||
set controllable [get_user_controllable_toplevels] |
||||
if {![llength $controllable]} { |
||||
if {[package provide punk::repl::codethread] ne "" && [punk::repl::codethread::is_running]} { |
||||
show_console |
||||
} else { |
||||
if {$waiting ne "no"} { |
||||
if {[info exists result(shell)]} { |
||||
set temp [set result(shell)] |
||||
unset result(shell) |
||||
set waiting $temp |
||||
} elseif {[info exists result($toplevel)]} { |
||||
set temp [set result($toplevel)] |
||||
unset result($toplevel) |
||||
set waiting $temp |
||||
} elseif {[info exists default_result]} { |
||||
set temp $default_result |
||||
unset default_result |
||||
set waiting $temp |
||||
} else { |
||||
set waiting "" |
||||
} |
||||
} else { |
||||
::exit |
||||
} |
||||
} |
||||
} |
||||
} |
||||
proc close_window {toplevel} { |
||||
wm withdraw $toplevel |
||||
if {![llength [get_user_controllable_toplevels]]} { |
||||
punkapp::exit $toplevel |
||||
} |
||||
destroy $toplevel |
||||
} |
||||
proc wait {args} { |
||||
variable waiting |
||||
variable default_result |
||||
if {[dict exists $args -defaultresult]} { |
||||
set default_result [dict get $args -defaultresult] |
||||
} |
||||
foreach t [punkapp::get_toplevels] { |
||||
if {[wm protocol $t WM_DELETE_WINDOW] eq ""} { |
||||
wm protocol $t WM_DELETE_WINDOW [list punkapp::close_window $t] |
||||
} |
||||
} |
||||
if {[package provide punk::repl::codethread] ne "" && [punk::repl::codethread::is_running]} { |
||||
puts stderr "repl eventloop seems to be running - punkapp::wait not required" |
||||
} else { |
||||
if {$waiting eq "no"} { |
||||
set waiting "waiting" |
||||
vwait ::punkapp::waiting |
||||
return $::punkapp::waiting |
||||
} |
||||
} |
||||
} |
||||
|
||||
#A window can be 'visible' according to this - but underneath other windows etc |
||||
#REVIEW - change name? |
||||
proc get_visible_toplevels {{w .}} { |
||||
if {![llength [info commands winfo]]} { |
||||
return [list] |
||||
} |
||||
set list [get_toplevels $w] |
||||
set mapped [lmap v $list {expr {[winfo ismapped $v] ? $v : {}}}] |
||||
set mapped [concat {*}$mapped] ;#ignore {} |
||||
set visible [list] |
||||
foreach m $mapped { |
||||
if {[wm overrideredirect $m] == 0 } { |
||||
lappend visible $m |
||||
} else { |
||||
if {[winfo height $m] >1 && [winfo width $m] > 1} { |
||||
#technically even a 1x1 is visible.. but in practice even a 10x10 is hardly likely to be noticeable when overrideredirect == 1 |
||||
#as a convention - 1x1 with no controls is used to make a window invisible so we'll treat anything larger as visible |
||||
lappend visible $m |
||||
} |
||||
} |
||||
} |
||||
return $visible |
||||
} |
||||
proc get_user_controllable_toplevels {{w .}} { |
||||
set visible [get_visible_toplevels $w] |
||||
set controllable [list] |
||||
foreach v $visible { |
||||
if {[wm overrideredirect $v] == 0} { |
||||
lappend controllable $v |
||||
} |
||||
} |
||||
#only return visible windows with overrideredirect == 0 because there exists some user control. |
||||
#todo - review.. consider checking if position is outside screen areas? Technically controllable.. but not easily |
||||
return $controllable |
||||
} |
||||
proc hide_console {args} { |
||||
set opts [dict create -force 0] |
||||
if {([llength $args] % 2) != 0} { |
||||
error "hide_console expects pairs of arguments. e.g -force 1" |
||||
} |
||||
#set known_opts [dict keys $defaults] |
||||
foreach {k v} $args { |
||||
switch -- $k { |
||||
-force { |
||||
dict set opts $k $v |
||||
} |
||||
default { |
||||
error "Unrecognised options '$k' known options: [dict keys $opts]" |
||||
} |
||||
} |
||||
} |
||||
set force [dict get $opts -force] |
||||
|
||||
if {!$force} { |
||||
if {![llength [get_user_controllable_toplevels]]} { |
||||
puts stderr "Cannot hide console while no user-controllable windows available" |
||||
return 0 |
||||
} |
||||
} |
||||
if {$::tcl_platform(platform) eq "windows"} { |
||||
#hide won't work for certain consoles cush as conemu,wezterm - and doesn't really make sense for tabbed windows anyway. |
||||
#It would be nice if we could tell the console window to hide just the relevant tab - or the whole window if only one tab present - but this is unlikely to be possible in any standard way. |
||||
#an ordinary cmd.exe or pwsh.exe or powershell.exe window can be hidden ok though. |
||||
#(but with wezterm - process is cmd.exe - but it has style popup and can't be hidden with a twapi::hide_window call) |
||||
package require twapi |
||||
set h [twapi::get_console_window] |
||||
set pid [twapi::get_window_process $h] |
||||
set pinfo [twapi::get_process_info $pid -name] |
||||
set pname [dict get $pinfo -name] |
||||
set wstyle [twapi::get_window_style $h] |
||||
#tclkitsh/tclsh? |
||||
if {($pname in [list cmd.exe pwsh.exe powershell.exe] || [string match punk*.exe $pname]) && "popup" ni $wstyle} { |
||||
twapi::hide_window $h |
||||
return 1 |
||||
} else { |
||||
puts stderr "punkapp::hide_console unable to hide this type of console window" |
||||
return 0 |
||||
} |
||||
} else { |
||||
#todo |
||||
puts stderr "punkapp::hide_console unimplemented on this platform (todo)" |
||||
return 0 |
||||
} |
||||
} |
||||
|
||||
proc show_console {} { |
||||
if {$::tcl_platform(platform) eq "windows"} { |
||||
package require twapi |
||||
if {![catch {set h [twapi::get_console_window]} errM]} { |
||||
twapi::show_window $h -activate -normal |
||||
} else { |
||||
#no console - assume launched from something like wish? |
||||
catch {console show} |
||||
} |
||||
} else { |
||||
#todo |
||||
puts stderr "punkapp::show_console unimplemented on this platform" |
||||
} |
||||
} |
||||
|
||||
} |
||||
#utilities for punk apps to call |
||||
|
||||
package provide punkapp [namespace eval punkapp { |
||||
variable version |
||||
set version 0.1 |
||||
}] |
||||
|
||||
namespace eval punkapp { |
||||
variable result |
||||
variable waiting "no" |
||||
proc hide_dot_window {} { |
||||
#alternative to wm withdraw . |
||||
#see https://wiki.tcl-lang.org/page/wm+withdraw |
||||
wm geometry . 1x1+0+0 |
||||
wm overrideredirect . 1 |
||||
wm transient . |
||||
} |
||||
proc is_toplevel {w} { |
||||
if {![llength [info commands winfo]]} { |
||||
return 0 |
||||
} |
||||
expr {[winfo toplevel $w] eq $w && ![catch {$w cget -menu}]} |
||||
} |
||||
proc get_toplevels {{w .}} { |
||||
if {![llength [info commands winfo]]} { |
||||
return [list] |
||||
} |
||||
set list {} |
||||
if {[is_toplevel $w]} { |
||||
lappend list $w |
||||
} |
||||
foreach w [winfo children $w] { |
||||
lappend list {*}[get_toplevels $w] |
||||
} |
||||
return $list |
||||
} |
||||
|
||||
proc make_toplevel_next {prefix} { |
||||
set top [get_toplevel_next $prefix] |
||||
return [toplevel $top] |
||||
} |
||||
#possible race condition if multiple calls made without actually creating the toplevel, or gap if highest existing closed in the meantime |
||||
#todo - reserve_toplevel_next ? keep list of toplevels considered 'allocated' even if never created or already destroyed? what usecase? |
||||
#can call wm withdraw to to reserve newly created toplevel. To stop re-use of existing names after destruction would require a list or at least a record of highest created for each prefix |
||||
proc get_toplevel_next {prefix} { |
||||
set base [string trim $prefix .] ;# .myapp -> myapp .myapp.somewindow -> myapp.somewindow . -> "" |
||||
|
||||
|
||||
|
||||
} |
||||
proc exit {{toplevel ""}} { |
||||
variable waiting |
||||
variable result |
||||
variable default_result |
||||
set toplevels [get_toplevels] |
||||
if {[string length $toplevel]} { |
||||
set wposn [lsearch $toplevels $toplevel] |
||||
if {$wposn > 0} { |
||||
destroy $toplevel |
||||
} |
||||
} else { |
||||
#review |
||||
if {[package provide punk::repl::codethread] ne "" && [punk::repl::codethread::is_running]} { |
||||
puts stderr "punkapp::exit called without toplevel - showing console" |
||||
show_console |
||||
return 0 |
||||
} else { |
||||
puts stderr "punkapp::exit called without toplevel - exiting" |
||||
if {$waiting ne "no"} { |
||||
if {[info exists result(shell)]} { |
||||
set temp [set result(shell)] |
||||
unset result(shell) |
||||
set waiting $temp |
||||
} else { |
||||
set waiting "" |
||||
} |
||||
} else { |
||||
::exit |
||||
} |
||||
} |
||||
} |
||||
|
||||
set controllable [get_user_controllable_toplevels] |
||||
if {![llength $controllable]} { |
||||
if {[package provide punk::repl::codethread] ne "" && [punk::repl::codethread::is_running]} { |
||||
show_console |
||||
} else { |
||||
if {$waiting ne "no"} { |
||||
if {[info exists result(shell)]} { |
||||
set temp [set result(shell)] |
||||
unset result(shell) |
||||
set waiting $temp |
||||
} elseif {[info exists result($toplevel)]} { |
||||
set temp [set result($toplevel)] |
||||
unset result($toplevel) |
||||
set waiting $temp |
||||
} elseif {[info exists default_result]} { |
||||
set temp $default_result |
||||
unset default_result |
||||
set waiting $temp |
||||
} else { |
||||
set waiting "" |
||||
} |
||||
} else { |
||||
::exit |
||||
} |
||||
} |
||||
} |
||||
} |
||||
proc close_window {toplevel} { |
||||
wm withdraw $toplevel |
||||
if {![llength [get_user_controllable_toplevels]]} { |
||||
punkapp::exit $toplevel |
||||
} |
||||
destroy $toplevel |
||||
} |
||||
proc wait {args} { |
||||
variable waiting |
||||
variable default_result |
||||
if {[dict exists $args -defaultresult]} { |
||||
set default_result [dict get $args -defaultresult] |
||||
} |
||||
foreach t [punkapp::get_toplevels] { |
||||
if {[wm protocol $t WM_DELETE_WINDOW] eq ""} { |
||||
wm protocol $t WM_DELETE_WINDOW [list punkapp::close_window $t] |
||||
} |
||||
} |
||||
if {[package provide punk::repl::codethread] ne "" && [punk::repl::codethread::is_running]} { |
||||
puts stderr "repl eventloop seems to be running - punkapp::wait not required" |
||||
} else { |
||||
if {$waiting eq "no"} { |
||||
set waiting "waiting" |
||||
vwait ::punkapp::waiting |
||||
return $::punkapp::waiting |
||||
} |
||||
} |
||||
} |
||||
|
||||
#A window can be 'visible' according to this - but underneath other windows etc |
||||
#REVIEW - change name? |
||||
proc get_visible_toplevels {{w .}} { |
||||
if {![llength [info commands winfo]]} { |
||||
return [list] |
||||
} |
||||
set list [get_toplevels $w] |
||||
set mapped [lmap v $list {expr {[winfo ismapped $v] ? $v : {}}}] |
||||
set mapped [concat {*}$mapped] ;#ignore {} |
||||
set visible [list] |
||||
foreach m $mapped { |
||||
if {[wm overrideredirect $m] == 0 } { |
||||
lappend visible $m |
||||
} else { |
||||
if {[winfo height $m] >1 && [winfo width $m] > 1} { |
||||
#technically even a 1x1 is visible.. but in practice even a 10x10 is hardly likely to be noticeable when overrideredirect == 1 |
||||
#as a convention - 1x1 with no controls is used to make a window invisible so we'll treat anything larger as visible |
||||
lappend visible $m |
||||
} |
||||
} |
||||
} |
||||
return $visible |
||||
} |
||||
proc get_user_controllable_toplevels {{w .}} { |
||||
set visible [get_visible_toplevels $w] |
||||
set controllable [list] |
||||
foreach v $visible { |
||||
if {[wm overrideredirect $v] == 0} { |
||||
lappend controllable $v |
||||
} |
||||
} |
||||
#only return visible windows with overrideredirect == 0 because there exists some user control. |
||||
#todo - review.. consider checking if position is outside screen areas? Technically controllable.. but not easily |
||||
return $controllable |
||||
} |
||||
proc hide_console {args} { |
||||
set opts [dict create -force 0] |
||||
if {([llength $args] % 2) != 0} { |
||||
error "hide_console expects pairs of arguments. e.g -force 1" |
||||
} |
||||
#set known_opts [dict keys $defaults] |
||||
foreach {k v} $args { |
||||
switch -- $k { |
||||
-force { |
||||
dict set opts $k $v |
||||
} |
||||
default { |
||||
error "Unrecognised options '$k' known options: [dict keys $opts]" |
||||
} |
||||
} |
||||
} |
||||
set force [dict get $opts -force] |
||||
|
||||
if {!$force} { |
||||
if {![llength [get_user_controllable_toplevels]]} { |
||||
puts stderr "Cannot hide console while no user-controllable windows available" |
||||
return 0 |
||||
} |
||||
} |
||||
if {$::tcl_platform(platform) eq "windows"} { |
||||
#hide won't work for certain consoles cush as conemu,wezterm - and doesn't really make sense for tabbed windows anyway. |
||||
#It would be nice if we could tell the console window to hide just the relevant tab - or the whole window if only one tab present - but this is unlikely to be possible in any standard way. |
||||
#an ordinary cmd.exe or pwsh.exe or powershell.exe window can be hidden ok though. |
||||
#(but with wezterm - process is cmd.exe - but it has style popup and can't be hidden with a twapi::hide_window call) |
||||
package require twapi |
||||
set h [twapi::get_console_window] |
||||
set pid [twapi::get_window_process $h] |
||||
set pinfo [twapi::get_process_info $pid -name] |
||||
set pname [dict get $pinfo -name] |
||||
set wstyle [twapi::get_window_style $h] |
||||
#tclkitsh/tclsh? |
||||
if {($pname in [list cmd.exe pwsh.exe powershell.exe] || [string match punk*.exe $pname]) && "popup" ni $wstyle} { |
||||
twapi::hide_window $h |
||||
return 1 |
||||
} else { |
||||
puts stderr "punkapp::hide_console unable to hide this type of console window" |
||||
return 0 |
||||
} |
||||
} else { |
||||
#todo |
||||
puts stderr "punkapp::hide_console unimplemented on this platform (todo)" |
||||
return 0 |
||||
} |
||||
} |
||||
|
||||
proc show_console {} { |
||||
if {$::tcl_platform(platform) eq "windows"} { |
||||
package require twapi |
||||
if {![catch {set h [twapi::get_console_window]} errM]} { |
||||
twapi::show_window $h -activate -normal |
||||
} else { |
||||
#no console - assume launched from something like wish? |
||||
catch {console show} |
||||
} |
||||
} else { |
||||
#todo |
||||
puts stderr "punkapp::show_console unimplemented on this platform" |
||||
} |
||||
} |
||||
|
||||
} |
||||
|
||||
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
Binary file not shown.
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
Binary file not shown.
Binary file not shown.
Loading…
Reference in new issue