38 changed files with 18811 additions and 28146 deletions
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
@ -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,761 +0,0 @@
|
||||
# -*- tcl -*- |
||||
# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'pmix make' or bin/punkmake to update from <pkg>-buildversion.txt |
||||
# module template: shellspy/src/decktemplates/vendor/punk/modules/template_module-0.0.3.tm |
||||
# |
||||
# 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) 2024 JMN |
||||
# (C) 2009 Path Thoyts <patthyts@users.sourceforge.net> |
||||
# |
||||
# @@ Meta Begin |
||||
# Application punk::zip 0.1.0 |
||||
# Meta platform tcl |
||||
# Meta license <unspecified> |
||||
# @@ Meta End |
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# doctools header |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
#*** !doctools |
||||
#[manpage_begin shellspy_module_punk::zip 0 0.1.0] |
||||
#[copyright "2024"] |
||||
#[titledesc {Module API}] [comment {-- Name section and table of contents description --}] |
||||
#[moddesc {-}] [comment {-- Description at end of page heading --}] |
||||
#[require punk::zip] |
||||
#[keywords module] |
||||
#[description] |
||||
#[para] - |
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
#*** !doctools |
||||
#[section Overview] |
||||
#[para] overview of punk::zip |
||||
#[subsection Concepts] |
||||
#[para] - |
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Requirements |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
#*** !doctools |
||||
#[subsection dependencies] |
||||
#[para] packages used by punk::zip |
||||
#[list_begin itemized] |
||||
|
||||
package require Tcl 8.6- |
||||
package require punk::args |
||||
#*** !doctools |
||||
#[item] [package {Tcl 8.6}] |
||||
#[item] [package {punk::args}] |
||||
|
||||
#*** !doctools |
||||
#[list_end] |
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
#*** !doctools |
||||
#[section API] |
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# oo::class namespace |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
#tcl::namespace::eval punk::zip::class { |
||||
#*** !doctools |
||||
#[subsection {Namespace punk::zip::class}] |
||||
#[para] class definitions |
||||
#if {[tcl::info::commands [tcl::namespace::current]::interface_sample1] eq ""} { |
||||
#*** !doctools |
||||
#[list_begin enumerated] |
||||
|
||||
# oo::class create interface_sample1 { |
||||
# #*** !doctools |
||||
# #[enum] CLASS [class interface_sample1] |
||||
# #[list_begin definitions] |
||||
|
||||
# method test {arg1} { |
||||
# #*** !doctools |
||||
# #[call class::interface_sample1 [method test] [arg arg1]] |
||||
# #[para] test method |
||||
# puts "test: $arg1" |
||||
# } |
||||
|
||||
# #*** !doctools |
||||
# #[list_end] [comment {-- end definitions interface_sample1}] |
||||
# } |
||||
|
||||
#*** !doctools |
||||
#[list_end] [comment {--- end class enumeration ---}] |
||||
#} |
||||
#} |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# Base namespace |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
tcl::namespace::eval punk::zip { |
||||
tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase |
||||
#variable xyz |
||||
|
||||
#*** !doctools |
||||
#[subsection {Namespace punk::zip}] |
||||
#[para] Core API functions for punk::zip |
||||
#[list_begin definitions] |
||||
|
||||
proc Path_a_atorbelow_b {path_a path_b} { |
||||
return [expr {[StripPath $path_b $path_a] ne $path_a}] |
||||
} |
||||
proc Path_a_at_b {path_a path_b} { |
||||
return [expr {[StripPath $path_a $path_b] eq "." }] |
||||
} |
||||
|
||||
proc Path_strip_alreadynormalized_prefixdepth {path prefix} { |
||||
if {$prefix eq ""} { |
||||
return $path |
||||
} |
||||
set pathparts [file split $path] |
||||
set prefixparts [file split $prefix] |
||||
if {[llength $prefixparts] >= [llength $pathparts]} { |
||||
return "" |
||||
} |
||||
return [file join \ |
||||
{*}[lrange \ |
||||
$pathparts \ |
||||
[llength $prefixparts] \ |
||||
end]] |
||||
} |
||||
|
||||
#StripPath - borrowed from tcllib fileutil |
||||
# ::fileutil::stripPath -- |
||||
# |
||||
# If the specified path references/is a path in prefix (or prefix itself) it |
||||
# is made relative to prefix. Otherwise it is left unchanged. |
||||
# In the case of it being prefix itself the result is the string '.'. |
||||
# |
||||
# Arguments: |
||||
# prefix prefix to strip from the path. |
||||
# path path to modify |
||||
# |
||||
# Results: |
||||
# path The (possibly) modified path. |
||||
|
||||
if {[string equal $::tcl_platform(platform) windows]} { |
||||
# Windows. While paths are stored with letter-case preserved al |
||||
# comparisons have to be done case-insensitive. For reference see |
||||
# SF Tcllib Bug 2499641. |
||||
|
||||
proc StripPath {prefix path} { |
||||
# [file split] is used to generate a canonical form for both |
||||
# paths, for easy comparison, and also one which is easy to modify |
||||
# using list commands. |
||||
|
||||
set prefix [file split $prefix] |
||||
set npath [file split $path] |
||||
|
||||
if {[string equal -nocase $prefix $npath]} { |
||||
return "." |
||||
} |
||||
|
||||
if {[string match -nocase "${prefix} *" $npath]} { |
||||
set path [eval [linsert [lrange $npath [llength $prefix] end] 0 file join ]] |
||||
} |
||||
return $path |
||||
} |
||||
} else { |
||||
proc StripPath {prefix path} { |
||||
# [file split] is used to generate a canonical form for both |
||||
# paths, for easy comparison, and also one which is easy to modify |
||||
# using list commands. |
||||
|
||||
set prefix [file split $prefix] |
||||
set npath [file split $path] |
||||
|
||||
if {[string equal $prefix $npath]} { |
||||
return "." |
||||
} |
||||
|
||||
if {[string match "${prefix} *" $npath]} { |
||||
set path [eval [linsert [lrange $npath [llength $prefix] end] 0 file join ]] |
||||
} |
||||
return $path |
||||
} |
||||
} |
||||
|
||||
proc Timet_to_dos {time_t} { |
||||
#*** !doctools |
||||
#[call [fun Timet_to_dos] [arg time_t]] |
||||
#[para] convert a unix timestamp into a DOS timestamp for ZIP times. |
||||
#[example { |
||||
# DOS timestamps are 32 bits split into bit regions as follows: |
||||
# 24 16 8 0 |
||||
# +-+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+ |
||||
# |Y|Y|Y|Y|Y|Y|Y|m| |m|m|m|d|d|d|d|d| |h|h|h|h|h|m|m|m| |m|m|m|s|s|s|s|s| |
||||
# +-+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+ |
||||
#}] |
||||
set s [clock format $time_t -format {%Y %m %e %k %M %S}] |
||||
scan $s {%d %d %d %d %d %d} year month day hour min sec |
||||
expr {(($year-1980) << 25) | ($month << 21) | ($day << 16) |
||||
| ($hour << 11) | ($min << 5) | ($sec >> 1)} |
||||
} |
||||
|
||||
proc walk {args} { |
||||
#*** !doctools |
||||
#[call [fun walk] [arg ?options?] [arg base]] |
||||
#[para] Walk a directory tree rooted at base |
||||
#[para] the -excludes list can be a set of glob expressions to match against files and avoid |
||||
#[para] e.g |
||||
#[example { |
||||
# punk::zip::walk -exclude {CVS/* *~.#*} library |
||||
#}] |
||||
|
||||
set argd [punk::args::get_dict { |
||||
*proc -name punk::zip::walk |
||||
-excludes -default "" -help "list of glob expressions to match against files and exclude" |
||||
-subpath -default "" |
||||
*values -min 1 -max -1 |
||||
base |
||||
fileglobs -default {*} -multiple 1 |
||||
} $args] |
||||
set base [dict get $argd values base] |
||||
set fileglobs [dict get $argd values fileglobs] |
||||
set subpath [dict get $argd opts -subpath] |
||||
set excludes [dict get $argd opts -excludes] |
||||
|
||||
|
||||
set imatch [list] |
||||
foreach fg $fileglobs { |
||||
lappend imatch [file join $subpath $fg] |
||||
} |
||||
|
||||
set result {} |
||||
#set imatch [file join $subpath $match] |
||||
set files [glob -nocomplain -tails -types f -directory $base -- {*}$imatch] |
||||
foreach file $files { |
||||
set excluded 0 |
||||
foreach glob $excludes { |
||||
if {[string match $glob $file]} { |
||||
set excluded 1 |
||||
break |
||||
} |
||||
} |
||||
if {!$excluded} {lappend result $file} |
||||
} |
||||
foreach dir [glob -nocomplain -tails -types d -directory $base -- [file join $subpath *]] { |
||||
set subdir_entries [walk -subpath $dir -excludes $excludes $base {*}$fileglobs] |
||||
if {[llength $subdir_entries]>0} { |
||||
#NOTE: trailing slash required for entries to be recognised as 'file type' = "directory" |
||||
#This is true for 2024 Tcl9 mounted zipfs at least. zip utilities such as 7zip seem(icon correct) to recognize dirs with or without trailing slash |
||||
#Although there are attributes on some systems to specify if entry is a directory - it appears trailing slash should always be used for folder names. |
||||
set result [list {*}$result "$dir/" {*}$subdir_entries] |
||||
} |
||||
} |
||||
return $result |
||||
} |
||||
|
||||
|
||||
proc extract_zip_prefix {infile outfile} { |
||||
set inzip [open $infile r] |
||||
fconfigure $inzip -encoding iso8859-1 -translation binary |
||||
if {[file exists $outfile]} { |
||||
error "outfile $outfile already exists - please remove first" |
||||
} |
||||
chan seek $inzip 0 end |
||||
set insize [tell $inzip] ;#faster (including seeks) than calling out to filesystem using file size - but should be equivalent |
||||
chan seek $inzip 0 start |
||||
#only scan last 64k - cover max signature size?? review |
||||
if {$insize < 65559} { |
||||
set tailsearch_start 0 |
||||
} else { |
||||
set tailsearch_start [expr {$insize - 65559}] |
||||
} |
||||
chan seek $inzip $tailsearch_start start |
||||
set scan [read $inzip] |
||||
#EOCD - End Of Central Directory record |
||||
set start_of_end [string last "\x50\x4b\x05\x06" $scan] |
||||
puts stdout "==>start_of_end: $start_of_end" |
||||
|
||||
if {$start_of_end == -1} { |
||||
#no zip cdr - consider entire file to be the zip prefix |
||||
set baseoffset $insize |
||||
} else { |
||||
set filerelative_eocd_posn [expr {$start_of_end + $tailsearch_start}] |
||||
chan seek $inzip $filerelative_eocd_posn |
||||
set cdir_record_plus [read $inzip] ;#can have trailing data |
||||
binary scan $cdir_record_plus issssiis eocd(signature) eocd(disknbr) eocd(ctrldirdisk) \ |
||||
eocd(numondisk) eocd(totalnum) eocd(dirsize) eocd(diroffset) eocd(comment_len) |
||||
#rule out a false positive from within a nonzip (e.g plain exe) |
||||
#There exists for example a PK\5\6 in a plain tclsh, but it doesn't appear to be zip related. |
||||
#It doesn't seem to occur near the end - so perhaps not an issue - but we'll do some basic checks anyway |
||||
#we only support single disk - so we'll validate a bit more by requiring disknbr and ctrldirdisk to be zeros |
||||
#todo - just search for Pk\5\6\0\0\0\0 in the first place? //review |
||||
if {$eocd(disknbr) + $eocd(ctrldirdisk) != 0} { |
||||
#review - should keep searching? |
||||
#for now we assume not a zip |
||||
set baseoffset $insize |
||||
} else { |
||||
#use the central dir size to jump back tko start of central dir |
||||
#determine if diroffset is file or archive relative |
||||
|
||||
set filerelative_cdir_start [expr {$filerelative_eocd_posn - $eocd(dirsize)}] |
||||
puts stdout "---> [read $inzip 4]" |
||||
if {$filerelative_cdir_start > $eocd(diroffset)} { |
||||
#easy case - 'archive' offset - (and one of the reasons I prefer archive-offset - it makes finding the 'prefix' easier |
||||
#though we are assuming zip offsets are not corrupted |
||||
set baseoffset [expr {$filerelative_cdir_start - $eocd(diroffset)}] |
||||
} else { |
||||
#hard case - either no prefix - or offsets have been adjusted to be file relative. |
||||
#we could scan from top (ugly) - and with binary prefixes we could get false positives in the data that look like PK\3\4 headers |
||||
#we could either work out the format for all possible executables that could be appended (across all platforms) and understand where they end? |
||||
#or we just look for the topmost PK\3\4 header pointed to by a CDR record - and assume the CDR is complete |
||||
|
||||
#step one - read all the CD records and find the highest pointed to local file record (which isn't necessarily the first - but should get us above most if not all of the zip data) |
||||
#we can't assume they're ordered in any particular way - so we in theory have to look at them all. |
||||
set baseoffset "unknown" |
||||
chan seek $inzip $filerelative_cdir_start start |
||||
#binary scan $cdir_record_plus issssiis eocd(signature) eocd(disknbr) eocd(ctrldirdisk) \ |
||||
# eocd(numondisk) eocd(totalnum) eocd(dirsize) eocd(diroffset) eocd(comment_len) |
||||
#load the whole central dir into cdir |
||||
|
||||
#todo! loop through all cdr file headers - find highest offset? |
||||
#tclZipfs.c just looks at first file header in Central Directory |
||||
#looking at all entries would be more robust - but we won't work harder than tclZipfs.c for now //REVIEW |
||||
|
||||
set cdirdata [read $inzip $eocd(dirsize)] |
||||
binary scan $cdirdata issssssiiisssssii cdir(signature) cdir(_vermadeby) cdir(_verneeded) cdir(gpbitflag) cdir(compmethod) cdir(lastmodifiedtime) cdir(lastmodifieddate)\ |
||||
cdir(uncompressedcrc32) cdir(compressedsize) cdir(uncompressedsize) cdir(filenamelength) cdir(extrafieldlength) cdir(filecommentlength) cdir(disknbr)\ |
||||
cdir(internalfileattributes) cdir(externalfileatributes) cdir(relativeoffset) |
||||
|
||||
#since we're in this branch - we assume cdir(relativeoffset) is from the start of the file |
||||
chan seek $inzip $cdir(relativeoffset) |
||||
#let's at least check that we landed on a local file header.. |
||||
set local_file_header_beginning [read $inzip 28]; #local_file_header without the file name and extra field |
||||
binary scan $local_file_header_beginning isssssiiiss lfh(signature) lfh(_verneeded) lfh(gpbitflag) lfh(compmethod) lfh(lastmodifiedtime) lfh(lastmodifieddate)\ |
||||
lfh(uncompressedcrc32) lfh(compressedsize) lfh(uncompressedsize) lfh(filenamelength) lfh(extrafieldlength) |
||||
#dec2hex 67324752 = 4034B50 = PK\3\4 |
||||
puts stdout "1st local file header sig: $lfh(signature)" |
||||
if {$lfh(signature) == 67324752} { |
||||
#looks like a local file header |
||||
#use our cdir(relativeoffset) as the start of the zip-data (//review - possible embedded password + end marker preceeding this) |
||||
set baseoffset $cdir(relativeoffset) |
||||
} |
||||
} |
||||
puts stdout "filerel_cdirstart: $filerelative_cdir_start recorded_offset: $eocd(diroffset)" |
||||
} |
||||
} |
||||
puts stdout "baseoffset: $baseoffset" |
||||
#expect CDFH PK\1\2 |
||||
#above the CD - we expect a bunch of PK\3\4 records - (possibly not all of them pointed to by the CDR) |
||||
#above that we expect: *possibly* a stored password with trailing marker - then the prefixed exe/script |
||||
|
||||
if {![string is integer -strict $baseoffset]} { |
||||
error "unable to determine zip baseoffset of file $infile" |
||||
} |
||||
|
||||
if {$baseoffset < $insize} { |
||||
set out [open $outfile w] |
||||
fconfigure $out -encoding iso8859-1 -translation binary |
||||
chan seek $inzip 0 start |
||||
chan copy $inzip $out -size $baseoffset |
||||
close $out |
||||
close $inzip |
||||
} else { |
||||
close $inzip |
||||
file copy $infile $outfile |
||||
} |
||||
} |
||||
|
||||
|
||||
|
||||
# Mkzipfile -- |
||||
# |
||||
# FIX ME: should handle the current offset for non-seekable channels |
||||
# |
||||
proc Mkzipfile {zipchan base path {comment ""}} { |
||||
#*** !doctools |
||||
#[call [fun Mkzipfile] [arg zipchan] [arg base] [arg path] [arg ?comment?]] |
||||
#[para] Add a single file to a zip archive |
||||
#[para] The zipchan channel should already be open and binary. |
||||
#[para] You can provide a -comment for the file. |
||||
#[para] The return value is the central directory record that will need to be used when finalizing the zip archive. |
||||
|
||||
set fullpath [file join $base $path] |
||||
set mtime [Timet_to_dos [file mtime $fullpath]] |
||||
set utfpath [encoding convertto utf-8 $path] |
||||
set utfcomment [encoding convertto utf-8 $comment] |
||||
set flags [expr {(1<<11)}] ;# utf-8 comment and path |
||||
set method 0 ;# store 0, deflate 8 |
||||
set attr 0 ;# text or binary (default binary) |
||||
set version 20 ;# minumum version req'd to extract |
||||
set extra "" |
||||
set crc 0 |
||||
set size 0 |
||||
set csize 0 |
||||
set data "" |
||||
set seekable [expr {[tell $zipchan] != -1}] |
||||
if {[file isdirectory $fullpath]} { |
||||
set attrex 0x41ff0010 ;# 0o040777 (drwxrwxrwx) |
||||
#set attrex 0x40000010 |
||||
} elseif {[file executable $fullpath]} { |
||||
set attrex 0x81ff0080 ;# 0o100777 (-rwxrwxrwx) |
||||
} else { |
||||
set attrex 0x81b60020 ;# 0o100666 (-rw-rw-rw-) |
||||
if {[file extension $fullpath] in {".tcl" ".txt" ".c"}} { |
||||
set attr 1 ;# text |
||||
} |
||||
} |
||||
|
||||
if {[file isfile $fullpath]} { |
||||
set size [file size $fullpath] |
||||
if {!$seekable} {set flags [expr {$flags | (1 << 3)}]} |
||||
} |
||||
|
||||
|
||||
set offset [tell $zipchan] |
||||
set local [binary format a4sssiiiiss PK\03\04 \ |
||||
$version $flags $method $mtime $crc $csize $size \ |
||||
[string length $utfpath] [string length $extra]] |
||||
append local $utfpath $extra |
||||
puts -nonewline $zipchan $local |
||||
|
||||
if {[file isfile $fullpath]} { |
||||
# If the file is under 2MB then zip in one chunk, otherwize we use |
||||
# streaming to avoid requiring excess memory. This helps to prevent |
||||
# storing re-compressed data that may be larger than the source when |
||||
# handling PNG or JPEG or nested ZIP files. |
||||
if {$size < 0x00200000} { |
||||
set fin [open $fullpath rb] |
||||
set data [read $fin] |
||||
set crc [zlib crc32 $data] |
||||
set cdata [zlib deflate $data] |
||||
if {[string length $cdata] < $size} { |
||||
set method 8 |
||||
set data $cdata |
||||
} |
||||
close $fin |
||||
set csize [string length $data] |
||||
puts -nonewline $zipchan $data |
||||
} else { |
||||
set method 8 |
||||
set fin [open $fullpath rb] |
||||
set zlib [zlib stream deflate] |
||||
while {![eof $fin]} { |
||||
set data [read $fin 4096] |
||||
set crc [zlib crc32 $data $crc] |
||||
$zlib put $data |
||||
if {[string length [set zdata [$zlib get]]]} { |
||||
incr csize [string length $zdata] |
||||
puts -nonewline $zipchan $zdata |
||||
} |
||||
} |
||||
close $fin |
||||
$zlib finalize |
||||
set zdata [$zlib get] |
||||
incr csize [string length $zdata] |
||||
puts -nonewline $zipchan $zdata |
||||
$zlib close |
||||
} |
||||
|
||||
if {$seekable} { |
||||
# update the header if the output is seekable |
||||
set local [binary format a4sssiiii PK\03\04 \ |
||||
$version $flags $method $mtime $crc $csize $size] |
||||
set current [tell $zipchan] |
||||
seek $zipchan $offset |
||||
puts -nonewline $zipchan $local |
||||
seek $zipchan $current |
||||
} else { |
||||
# Write a data descriptor record |
||||
set ddesc [binary format a4iii PK\7\8 $crc $csize $size] |
||||
puts -nonewline $zipchan $ddesc |
||||
} |
||||
} |
||||
|
||||
#PK\x01\x02 Cdentral directory file header |
||||
#set v1 0x0317 ;#upper byte 03 -> UNIX lower byte 23 -> 2.3 |
||||
set v1 0x0017 ;#upper byte 00 -> MS_DOS and OS/2 (FAT/VFAT/FAT32 file systems) |
||||
|
||||
set hdr [binary format a4ssssiiiisssssii PK\01\02 $v1 \ |
||||
$version $flags $method $mtime $crc $csize $size \ |
||||
[string length $utfpath] [string length $extra]\ |
||||
[string length $utfcomment] 0 $attr $attrex $offset] |
||||
append hdr $utfpath $extra $utfcomment |
||||
return $hdr |
||||
} |
||||
|
||||
#### REVIEW!!! |
||||
#JMN - review - this looks to be offset relative to start of file - (same as 2024 Tcl 'mkzip mkimg') |
||||
# we probably want offsets to start of archive for exe/script-prefixed zips.on windows (editability with 7z,peazip) |
||||
#### |
||||
|
||||
# zip::mkzip -- |
||||
# |
||||
# eg: zip my.zip -directory Subdir -runtime unzipsfx.exe *.txt |
||||
# |
||||
proc mkzip {args} { |
||||
#*** !doctools |
||||
#[call [fun mkzip] [arg ?options?] [arg filename]] |
||||
#[para] Create a zip archive in 'filename' |
||||
#[para] If a file already exists, an error will be raised. |
||||
set argd [punk::args::get_dict { |
||||
*proc -name punk::zip::mkzip -help "Create a zip archive in 'filename'" |
||||
*opts |
||||
-return -default "pretty" -choices {pretty list none} -help "mkzip can return a list of the files and folders added to the archive |
||||
the option -return pretty is the default and uses the punk::lib pdict/plist system |
||||
to return a formatted list for the terminal |
||||
" |
||||
-zipkit -default 0 -type none -help "" |
||||
-runtime -default "" -help "specify a prefix file |
||||
e.g punk::zip::mkzip -runtime unzipsfx.exe -directory subdir output.zip |
||||
will create a self-extracting zip archive from the subdir/ folder. |
||||
" |
||||
-comment -default "" -help "An optional comment for the archive" |
||||
-directory -default "" -help "The new zip archive will scan for contents within this folder or current directory if not provided" |
||||
-base -default "" -help "The new zip archive will be rooted in this directory if provided |
||||
it must be a parent of -directory" |
||||
-exclude -default {CVS/* */CVS/* *~ ".#*" "*/.#*"} |
||||
*values -min 1 -max -1 |
||||
filename -default "" -help "name of zipfile to create" |
||||
globs -default {*} -multiple 1 -help "list of glob patterns to match. |
||||
Only directories with matching files will be included in the archive" |
||||
} $args] |
||||
|
||||
set filename [dict get $argd values filename] |
||||
if {$filename eq ""} { |
||||
error "mkzip filename cannot be empty string" |
||||
} |
||||
if {[regexp {[?*]} $filename]} { |
||||
#catch a likely error where filename is omitted and first glob pattern is misinterpreted as zipfile name |
||||
error "mkzip filename should not contain glob characters ? *" |
||||
} |
||||
if {[file exists $filename]} { |
||||
error "mkzip filename:$filename already exists" |
||||
} |
||||
dict for {k v} [dict get $argd opts] { |
||||
switch -- $k { |
||||
-comment { |
||||
dict set argd opts $k [encoding convertto utf-8 $v] |
||||
} |
||||
-directory - -base { |
||||
dict set argd opts $k [file normalize $v] |
||||
} |
||||
} |
||||
} |
||||
|
||||
array set opts [dict get $argd opts] |
||||
|
||||
|
||||
if {$opts(-directory) ne ""} { |
||||
if {$opts(-base) ne ""} { |
||||
#-base and -directory have been normalized already |
||||
if {![Path_a_atorbelow_b $opts(-directory) $opts(-base)]} { |
||||
error "punk::zip::mkzip -base $opts(-base) must be above -directory $opts(-directory)" |
||||
} |
||||
set base $opts(-base) |
||||
set relpath [Path_strip_alreadynormalized_prefixdepth $opts(-directory) $opts(-base)] |
||||
} else { |
||||
set base $opts(-directory) |
||||
set relpath "" |
||||
} |
||||
set paths [walk -exclude $opts(-exclude) -subpath $relpath -- $base {*}[dict get $argd values globs]] |
||||
|
||||
set norm_filename [file normalize $filename] |
||||
set norm_dir [file normalize $opts(-directory)] ;#we only care if filename below -directory (which is where we start scanning) |
||||
if {[Path_a_atorbelow_b $norm_filename $norm_dir]} { |
||||
#check that we aren't adding the zipfile to itself |
||||
#REVIEW - now that we open zipfile after scanning - this isn't really a concern! |
||||
#keep for now in case we can add an -update or a -force facility (or in case we modify to add to zip as we scan for members?) |
||||
#In the case of -force - we may want to delay replacement of original until scan is done? |
||||
|
||||
#try to avoid looping on all paths and performing (somewhat) expensive file normalizations on each |
||||
#1st step is to check the patterns and see if our zipfile is already excluded - in which case we need not check the paths |
||||
set self_globs_match 0 |
||||
foreach g [dict get $argd values globs] { |
||||
if {[string match $g [file tail $filename]]} { |
||||
set self_globs_match 1 |
||||
break |
||||
} |
||||
} |
||||
if {$self_globs_match} { |
||||
#still dangerous |
||||
set self_excluded 0 |
||||
foreach e $opts(-exclude) { |
||||
if {[string match $e [file tail $filename]]} { |
||||
set self_excluded 1 |
||||
break |
||||
} |
||||
} |
||||
if {!$self_excluded} { |
||||
#still dangerous - likely to be in resultset - check each path |
||||
#puts stderr "zip file $filename is below directory $opts(-directory)" |
||||
set self_is_matched 0 |
||||
set i 0 |
||||
foreach p $paths { |
||||
set norm_p [file normalize [file join $opts(-directory) $p]] |
||||
if {[Path_a_at_b $norm_filename $norm_p]} { |
||||
set self_is_matched 1 |
||||
break |
||||
} |
||||
incr i |
||||
} |
||||
if {$self_is_matched} { |
||||
puts stderr "WARNING - zipfile being created '$filename' was matched. Excluding this file. Relocate the zip, or use -exclude patterns to avoid this message" |
||||
set paths [lremove $paths $i] |
||||
} |
||||
} |
||||
} |
||||
} |
||||
} else { |
||||
set paths [list] |
||||
set dir [pwd] |
||||
if {$opts(-base) ne ""} { |
||||
if {![Path_a_atorbelow_b $dir $opts(-base)]} { |
||||
error "punk::zip::mkzip -base $opts(-base) must be above current directory" |
||||
} |
||||
set relpath [Path_strip_alreadynormalized_prefixdepth [file normalize $dir] [file normalize $opts(-base)]] |
||||
} else { |
||||
set relpath "" |
||||
} |
||||
set base $opts(-base) |
||||
|
||||
set matches [glob -nocomplain -type f -- {*}[dict get $argd values globs]] |
||||
foreach m $matches { |
||||
if {$m eq $filename} { |
||||
#puts stderr "--> excluding $filename" |
||||
continue |
||||
} |
||||
set isok 1 |
||||
foreach e [concat $opts(-exclude) $filename] { |
||||
if {[string match $e $m]} { |
||||
set isok 0 |
||||
break |
||||
} |
||||
} |
||||
if {$isok} { |
||||
lappend paths [file join $relpath $m] |
||||
} |
||||
} |
||||
} |
||||
|
||||
if {![llength $paths]} { |
||||
return "" |
||||
} |
||||
|
||||
set zf [open $filename wb] |
||||
if {$opts(-runtime) ne ""} { |
||||
set rt [open $opts(-runtime) rb] |
||||
fcopy $rt $zf |
||||
close $rt |
||||
} elseif {$opts(-zipkit)} { |
||||
#TODO - update to zipfs ? |
||||
#see modpod |
||||
set zkd "#!/usr/bin/env tclkit\n\# This is a zip-based Tcl Module\n" |
||||
append zkd "package require vfs::zip\n" |
||||
append zkd "vfs::zip::Mount \[info script\] \[info script\]\n" |
||||
append zkd "if {\[file exists \[file join \[info script\] main.tcl\]\]} {\n" |
||||
append zkd " source \[file join \[info script\] main.tcl\]\n" |
||||
append zkd "}\n" |
||||
append zkd \x1A |
||||
puts -nonewline $zf $zkd |
||||
} |
||||
|
||||
#todo - subtract this from the endrec offset.. and any ... ? |
||||
set dataStartOffset [tell $zf] ;#the overall file offset of the start of data section //JMN 2024 |
||||
|
||||
set count 0 |
||||
set cd "" |
||||
|
||||
set members [list] |
||||
foreach path $paths { |
||||
#puts $path |
||||
lappend members $path |
||||
append cd [Mkzipfile $zf $base $path] ;#path already includes relpath |
||||
incr count |
||||
} |
||||
set cdoffset [tell $zf] |
||||
set endrec [binary format a4ssssiis PK\05\06 0 0 \ |
||||
$count $count [string length $cd] $cdoffset\ |
||||
[string length $opts(-comment)]] |
||||
append endrec $opts(-comment) |
||||
puts -nonewline $zf $cd |
||||
puts -nonewline $zf $endrec |
||||
close $zf |
||||
|
||||
set result "" |
||||
switch -exact -- $opts(-return) { |
||||
list { |
||||
set result $members |
||||
} |
||||
pretty { |
||||
if {[info commands showlist] ne ""} { |
||||
set result [plist -channel none members] |
||||
} else { |
||||
set result $members |
||||
} |
||||
} |
||||
none { |
||||
set result "" |
||||
} |
||||
} |
||||
return $result |
||||
} |
||||
|
||||
|
||||
#*** !doctools |
||||
#[list_end] [comment {--- end definitions namespace punk::zip ---}] |
||||
} |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# Secondary API namespace |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
tcl::namespace::eval punk::zip::lib { |
||||
tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase |
||||
tcl::namespace::path [tcl::namespace::parent] |
||||
#*** !doctools |
||||
#[subsection {Namespace punk::zip::lib}] |
||||
#[para] Secondary functions that are part of the API |
||||
#[list_begin definitions] |
||||
|
||||
#proc utility1 {p1 args} { |
||||
# #*** !doctools |
||||
# #[call lib::[fun utility1] [arg p1] [opt {?option value...?}]] |
||||
# #[para]Description of utility1 |
||||
# return 1 |
||||
#} |
||||
|
||||
|
||||
|
||||
#*** !doctools |
||||
#[list_end] [comment {--- end definitions namespace punk::zip::lib ---}] |
||||
} |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
#*** !doctools |
||||
#[section Internal] |
||||
#tcl::namespace::eval punk::zip::system { |
||||
#*** !doctools |
||||
#[subsection {Namespace punk::zip::system}] |
||||
#[para] Internal functions that are not part of the API |
||||
|
||||
|
||||
|
||||
#} |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Ready |
||||
package provide punk::zip [tcl::namespace::eval punk::zip { |
||||
variable pkg punk::zip |
||||
variable version |
||||
set version 0.1.0 |
||||
}] |
||||
return |
||||
|
||||
#*** !doctools |
||||
#[manpage_end] |
||||
|
||||
@ -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" |
||||
} |
||||
} |
||||
|
||||
} |
||||
|
||||
Binary file not shown.
Binary file not shown.
Binary file not shown.
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
File diff suppressed because it is too large
Load Diff
Binary file not shown.
Loading…
Reference in new issue