jn
/
punkshell
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity
Browse Source

make.tcl and console rawmode fixes

master
Julian Noble 3 months ago
parent
4b66dc28dc
commit
963a5a788b
49 changed files with 3621 additions and 3995 deletions
Whitespace
Show all changes Ignore whitespace when comparing lines Ignore changes in amount of whitespace Ignore changes in whitespace at EOL
Split View
Diff Options
Show Stats Download Patch File Download Diff File
  1. 3
      .gitignore
  2. 1046
      bin/fetchruntime.cmd
  3. 612
      bin/fetchruntime_old.cmd
  4. 43
      bin/runtime.cmd
  5. 4
      bin/sdx.bat
  6. BIN
      bin/sdx.kit
  7. 57
      scriptlib/stdout_per_second.tcl
  8. 201
      scriptlib/utils/pwsh/consolemode.ps1
  9. 91
      scriptlib/utils/pwsh/consolemode_enableraw.ps1
  10. 144
      scriptlib/utils/pwsh/consolemode_server.ps1
  11. 244
      scriptlib/utils/pwsh/consolemode_server_async.2ps1
  12. 262
      scriptlib/utils/pwsh/consolemode_server_async.ps1
  13. 266
      scriptlib/utils/pwsh/consolemode_server_async1.ps1
  14. 1
      scriptlib/utils/pwsh/echotest.ps1
  15. 5
      src/bootsupport/modules/punk/args-0.2.tm
  16. 2
      src/bootsupport/modules/punk/args/tclcore-0.1.0.tm
  17. 556
      src/bootsupport/modules/punk/console-0.1.1.tm
  18. 58
      src/bootsupport/modules/punk/libunknown-0.1.tm
  19. 64
      src/bootsupport/modules/punk/repl-0.1.2.tm
  20. BIN
      src/bootsupport/modules_tcl8/Thread-2.8.9.tm
  21. 3
      src/bootsupport/modules_tcl8/include_modules.config
  22. BIN
      src/bootsupport/modules_tcl8/thread/platform/win32_x86_64_tcl8-2.8.9.tm
  23. BIN
      src/bootsupport/modules_tcl8/win32_x86_64_tcl8-2.8.9.tm
  24. 14
      src/lib/app-punk/repl.tcl
  25. 1
      src/lib/app-punkshell/punkshell.tcl
  26. 157
      src/make.tcl
  27. 5
      src/modules/punk/args-999999.0a1.0.tm
  28. 2
      src/modules/punk/args/tclcore-999999.0a1.0.tm
  29. 556
      src/modules/punk/console-999999.0a1.0.tm
  30. 58
      src/modules/punk/libunknown-0.1.tm
  31. 39
      src/modules/punk/mix/templates/utility/scriptappwrappers/multishell.cmd
  32. 64
      src/modules/punk/repl-999999.0a1.0.tm
  33. 157
      src/project_layouts/custom/_project/punk.basic/src/make.tcl
  34. 5
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args-0.2.tm
  35. 2
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args/tclcore-0.1.0.tm
  36. 556
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/console-0.1.1.tm
  37. 58
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/libunknown-0.1.tm
  38. 64
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/repl-0.1.2.tm
  39. 157
      src/project_layouts/custom/_project/punk.project-0.1/src/make.tcl
  40. 5
      src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/args-0.2.tm
  41. 2
      src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/args/tclcore-0.1.0.tm
  42. 556
      src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/console-0.1.1.tm
  43. 58
      src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/libunknown-0.1.tm
  44. 64
      src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/repl-0.1.2.tm
  45. 157
      src/project_layouts/custom/_project/punk.shell-0.1/src/make.tcl
  46. 4
      src/runtime/mapvfs.config
  47. 1
      src/scriptapps/bin/readme.txt
  48. 743
      src/scriptapps/example_out.bat
  49. 25
      src/scriptapps/example_wrap.toml

3
.gitignore vendored
Unescape View File

@ -1,5 +1,6 @@
*.lastrun
/*.lastrun
/*.ps1
#/bin/
/bin/*

1046
bin/fetchruntime.cmd
View File

File diff suppressed because it is too large Load Diff

612
bin/fetchruntime_old.cmd
Unescape View File

@ -1,612 +0,0 @@
: "punk MULTISHELL - shebangless polyglot for Tcl Perl sh bash cmd pwsh powershell" + "[rename set s;proc Hide x {proc $x args {}};Hide :]" + "\$(function : {<#pwsh#>})" + "perlhide" + qw^
set -- "$@" "a=[Hide <#;Hide set;s 1 list]"; set -- : "$@";$1 = @'
: heredoc1 - hide from powershell using @ and squote above. close sqote for unix shells + ' \
: .bat/.cmd launch section, leading colon hides from cmd, trailing slash hides next line from tcl + \
: "[Hide @GOTO; Hide =begin; Hide @REM] #not necessary but can help avoid errs in testing" +
: << 'HEREDOC1B_HIDE_FROM_BASH_AND_SH'
: STRONG SUGGESTION: DO NOT MODIFY FIRST LINE OF THIS SCRIPT - except for first double quoted section.
: shebang line is not required on unix or windows and will reduce functionality and/or portability.
: Even comment lines can be part of the functionality of this script (both on unix and windows) - modify with care.
@GOTO :skip_perl_pod_start ^;
=begin excludeperl
: skip_perl_pod_start
: Continuation char at end of this line and rem with curly-braces used to exlude Tcl from the whole cmd block \
: {
@REM ############################################################################################################################
@REM THIS IS A POLYGLOT SCRIPT - supporting payloads in Tcl, bash, sh and/or powershelll (powershell.exe or pwsh.exe)
@REM It should remain portable between unix-like OSes & windows if the proper structure is maintained.
@REM ############################################################################################################################
@REM On windows, change the value of nextshell to one of the listed 2 digit values if desired, and add code within payload sections for tcl,sh,bash,powershell as appropriate.
@REM This wrapper can be edited manually (carefully!) - or sh,bash,tcl,powershell scripts can be wrapped using the Tcl-based punkshell system
@REM e.g from within a running punkshell: pmix scriptwrap.multishell <inputfilepath> -outputfolder <folderpath>
@REM On unix-like systems, call with sh, bash or tclsh. (powershell untested on unix - and requires wscript if security elevation is used)
@REM Due to lack of shebang (#! line) Unix-like systems will probably (hopefully) default to sh if the script is called without an interpreter - but it may depend on the shell in use when called.
@REM If you find yourself really wanting/needing to add a shebang line - do so on the basis that the script will exist on unix-like systems only.
@SETLOCAL EnableExtensions EnableDelayedExpansion
@SET "validshells= ^(10^) 'pwsh' ^(11^) 'sh' (^12^) 'bash' (^13^) 'tclsh' (^14^) 'perl'"
@SET "shells[10]=pwsh"
@SET "shells[11]=sh"
@set "shells[12]=bash"
@SET "shells[13]=tclsh"
@SET "shells[14]=perl"
: <nextshell>
@SET "nextshell=10"
: </nextshell>
@rem asadmin is for automatic elevation to administrator. Separate window will be created (seems unavoidable with current elevation mechanism) and user will still get security prompt (probably reasonable).
: <asadmin>
@SET "asadmin=0"
: </asadmin>
@REM nextshell set to index for validshells .eg 10 for pwsh
@REM @ECHO nextshell is %nextshell%
@SET "selected=!shells[%nextshell%]!"
@REM @ECHO selected %selected%
@CALL SET "keyRemoved=%%validshells:'!selected!'=%%"
@REM @ECHO keyremoved %keyRemoved%
@REM Note that 'powershell' e.g v5 is just a fallback for when pwsh is not available
@REM ## ### ### ### ### ### ### ### ### ### ### ### ### ###
@REM -- cmd/batch file section (ignored on unix but should be left in place)
@REM -- This section intended mainly to launch the next shell (and to escalate privileges if necessary)
@REM -- Avoid customising this if you are not familiar with batch scripting. cmd/batch script can be useful, but is probably the least expressive language and most error prone.
@REM -- For example - as this file needs to use unix-style lf line-endings - the label scanner is susceptible to the 512Byte boundary issue: https://www.dostips.com/forum/viewtopic.php?t=8988#p58888
@REM -- This label issue can be triggered/abused in files with crlf line endings too - but it is less likely to happen accidentaly.
@REm -- See also: https://stackoverflow.com/questions/4094699/how-does-the-windows-command-interpreter-cmd-exe-parse-scripts/4095133#4095133
@REM ############################################################################################################################
@REM -- Due to this issue -seemingly trivial edits of the batch file section can break the script! (for Windows anyway)
@REM -- Even something as simple as adding or removing an @REM
@REM -- From within punkshell - use:
@REM -- pmix scriptwrap.checkoutput <filepath>
@REM -- to check your templates or final wrapped scripts for byte boundary issues
@REM -- It will report any labels that are on boundaries
@REM -- This is why the nextshell value above is a 2 digit key instead of a string - so that editing the value doesn't change the byte offsets.
@REM -- Editing your sh,bash,tcl,pwsh payloads is much less likely to cause an issue. There is the possibility of the final batch :exit_multishell label spanning a boundary - so testing using pmix scriptwrap.checkoutput is still recommended.
@REM -- Alternatively, as you should do anyway - test the final script on windows
@REM -- Aside from adding comments/whitespace to tweak the location of labels - you can try duplicating the label (e.g just add the label on a line above) but this is not guaranteed to work in all situations.
@REM -- '@REM' is a safer comment mechanism than a leading colon - which is used sparingly here.
@REM -- A colon anywhere in the script that happens to land on a 512 Byte boundary (from file start or from a callsite) could be misinterpreted as a label
@REM -- It is unknown what versions of cmd interpreters behave this way - and pmix scriptwrap.checkoutput doesn't check all such boundaries.
@REm -- For this reason, batch labels should be chosen to be relatively unlikely to collide with other strings in the file, and simple names such as :exit or :end should probably be avoided
@REM ############################################################################################################################
@REM -- custom windows payloads should be in powershell,tclsh (or sh/bash if available) code sections
@REM ## ### ### ### ### ### ### ### ### ### ### ### ### ###
@SET "winpath=%~dp0"
@SET "fname=%~nx0"
@REM @ECHO fname %fname%
@REM @ECHO winpath %winpath%
@REM @ECHO commandlineascalled %0
@REM @ECHO commandlineresolved %~f0
@CALL :getNormalizedScriptTail nftail
@REM @ECHO normalizedscripttail %nftail%
@CALL :getFileTail %0 clinetail
@REM @ECHO clinetail %clinetail%
@CALL :stringToUpper %~nx0 capscripttail
@REM @ECHO capscriptname: %capscripttail%
@IF "%nftail%"=="%capscripttail%" (
@ECHO forcing asadmin=1 due to file name on filesystem being uppercase
@SET "asadmin=1"
) else (
@CALL :stringToUpper %clinetail% capcmdlinetail
@REM @ECHO capcmdlinetail !capcmdlinetail!
IF "%clinetail%"=="!capcmdlinetail!" (
@ECHO forcing asadmin=1 due to cmdline scriptname in uppercase
@set "asadmin=1"
)
)
@SET "vbsGetPrivileges=%temp%\punk_bat_elevate_%fname%.vbs"
@SET arglist=%*
@IF "%1"=="PUNK-ELEVATED" (
GOTO :gotPrivileges
)
@IF !asadmin!==1 (
net file 1>NUL 2>NUL
@IF '!errorlevel!'=='0' ( GOTO :gotPrivileges ) else ( GOTO :getPrivileges )
)
@GOTO skip_privileges
:getPrivileges
@IF '%1'=='PUNK-ELEVATED' (echo PUNK-ELEVATED & shift /1 & goto :gotPrivileges )
@ECHO Set UAC = CreateObject^("Shell.Application"^) > "%vbsGetPrivileges%"
@ECHO args = "PUNK-ELEVATED " >> "%vbsGetPrivileges%"
@ECHO For Each strArg in WScript.Arguments >> "%vbsGetPrivileges%"
@ECHO args = args ^& strArg ^& " " >> "%vbsGetPrivileges%"
@ECHO Next >> "%vbsGetPrivileges%"
@ECHO UAC.ShellExecute "%~dp0%~n0%~x0", args, "", "runas", 1 >> "%vbsGetPrivileges%"
@ECHO Launching script in new windows due to administrator elevation
@"%SystemRoot%\System32\WScript.exe" "%vbsGetPrivileges%" %*
@EXIT /B
:gotPrivileges
@REM setlocal & pushd .
@PUSHD .
@cd /d %~dp0
@IF "%1"=="PUNK-ELEVATED" (
@DEL "%vbsGetPrivileges%" 1>nul 2>nul
@SET arglist=%arglist:~14%
)
:skip_privileges
@SET need_ps1=0
@REM we want the ps1 to exist even if the nextshell isn't powershell
@if not exist "%~dp0%~n0.ps1" (
@SET need_ps1=1
) ELSE (
fc "%~dp0%~n0%~x0" "%~dp0%~n0.ps1" >nul || goto different
@REM @ECHO "files same"
@SET need_ps1=0
)
@GOTO :pscontinue
:different
@REM @ECHO "files differ"
@SET need_ps1=1
:pscontinue
@IF !need_ps1!==1 (
COPY "%~dp0%~n0%~x0" "%~dp0%~n0.ps1" >NUL
)
@REM avoid using CALL to launch pwsh,tclsh etc - it will intercept some args such as /?
@IF "!shells[%nextshell%]!"=="pwsh" (
REM pws vs powershell hasn't been tested because we didn't need to copy cmd to ps1 this time
REM test availability of preferred option of powershell7+ pwsh
pwsh -nop -nol -c set-executionpolicy -Scope Process Unrestricted; write-host "statusmessage: pwsh-found" >NUL
SET pwshtest_exitcode=!errorlevel!
REM ECHO pwshtest_exitcode !pwshtest_exitcode!
REM fallback to powershell if pwsh failed
IF !pwshtest_exitcode!==0 (
pwsh -nop -nol -c set-executionpolicy -Scope Process Unrestricted; "%~dp0%~n0.ps1" %arglist%
SET task_exitcode=!errorlevel!
) ELSE (
REM CALL powershell -nop -nol -c write-host powershell-found
REM powershell -nop -nol -file "%~dp0%~n0.ps1" %*
powershell -nop -nol -c set-executionpolicy -Scope Process Unrestricted; %~dp0%~n0.ps1" %arglist%
SET task_exitcode=!errorlevel!
)
) ELSE (
IF "!shells[%nextshell%]!"=="bash" (
CALL :getWslPath %winpath% wslpath
REM ECHO wslfullpath "!wslpath!%fname%"
!shells[%nextshell%]! "!wslpath!%fname%" %arglist%
SET task_exitcode=!errorlevel!
) ELSE (
REM probably tclsh or sh
IF NOT "x%keyRemoved%"=="x%validshells%" (
REM sh on windows uses /c/ instead of /mnt/c - at least if using msys. Todo, review what is the norm on windows with and without msys2,cygwin,wsl
REM and what logic if any may be needed. For now sh with /c/xxx seems to work the same as sh with c:/xxx
!shells[%nextshell%]! "%~dp0%fname%" %arglist%
SET task_exitcode=!errorlevel!
) ELSE (
ECHO %fname% has invalid nextshell value ^(%nextshell%^) !shells[%nextshell%]! valid options are %validshells%
SET task_exitcode=66
@REM boundary padding
GOTO :exit_multishell
)
)
)
@REM batch file library functions
@REM boundary padding
@GOTO :endlib
:getWslPath
@SETLOCAL
@SET "_path=%~p1"
@SET "name=%~nx1"
@SET "drive=%~d1"
@SET "rtrn=%~2"
@SET "result=/mnt/%drive:~0,1%%_path:\=/%%name%"
@ENDLOCAL & (
@if "%~2" neq "" (
SET "%rtrn%=%result%"
) ELSE (
ECHO %result%
)
)
@EXIT /B
:getFileTail
@REM return tail of file without any normalization e.g c:/punkshell/bin/Punk.cmd returns Punk.cmd even if file is punk.cmd
@REM we can't use things such as %~nx1 as it can change capitalisation
@REM This function is designed explicitly to preserve capitalisation
@REM accepts full paths with either / or \ as delimiters - or
@SETLOCAL
@SET "rtrn=%~2"
@SET "arg=%~1"
@REM @SET "result=%_arg:*/=%"
@REM @SET "result=%~1"
@SET LF=^
: The above 2 empty lines are important. Don't remove
@CALL :stringContains "!arg!" "\" hasBackSlash
@IF "!hasBackslash!"=="true" (
@for %%A in ("!LF!") do @(
@FOR /F %%B in ("!arg:\=%%~A!") do @set "result=%%B"
)
) ELSE (
@CALL :stringContains "!arg!" "/" hasForwardSlash
@IF "!hasForwardSlash!"=="true" (
@FOR %%A in ("!LF!") do @(
@FOR /F %%B in ("!arg:/=%%~A!") do @set "result=%%B"
)
) ELSE (
@set "result=%arg%"
)
)
@ENDLOCAL & (
@if "%~2" neq "" (
@SET "%rtrn%=%result%"
) ELSE (
@ECHO %result%
)
)
@EXIT /B
@REM boundary padding
@REM boundary padding
:getNormalizedScriptTail
@SETLOCAL
@SET "result=%~nx0"
@SET "rtrn=%~1"
@ENDLOCAL & (
@IF "%~1" neq "" (
@SET "%rtrn%=%result%"
) ELSE (
@ECHO %result%
)
)
@EXIT /B
:getNormalizedFileTailFromPath
@REM warn via echo, and do not set return variable if path not found
@REM note that %~nx1 does not preserve case of provided path - hence the name 'normalized'
@REM boundary padding
@REM boundary padding
@REM boundary padding
@REM boundary padding
@SETLOCAL
@CALL :stringContains %~1 "\" hasBackSlash
@CALL :stringContains %~1 "/" hasForwardSlash
@IF "%hasBackslash%-%hasForwardslash%"=="false-false" (
@SET "P=%cd%%~1"
@CALL :getNormalizedFileTailFromPath "!P!" ftail2
@SET "result=!ftail2!"
) else (
@IF EXIST "%~1" (
@SET "result=%~nx1"
) else (
@ECHO error getNormalizedFileTailFromPath file not found: %~1
@EXIT /B 1
)
)
@SET "rtrn=%~2"
@ENDLOCAL & (
@IF "%~2" neq "" (
SET "%rtrn%=%result%"
) ELSE (
@ECHO getNormalizedFileTailFromPath %1 result: %result%
)
)
@EXIT /B
:stringContains
@REM usage: @CALL:stringContains string needle returnvarname
@SETLOCAL
@SET "rtrn=%~3"
@SET "string=%~1"
@SET "needle=%~2"
@IF "!string:%needle%=!"=="!string!" @(
@SET "result=false"
) ELSE (
@SET "result=true"
)
@ENDLOCAL & (
@IF "%~3" neq "" (
@SET "%rtrn%=%result%"
) ELSE (
@ECHO stringContains %string% %needle% result: %result%
)
)
@EXIT /B
:stringToUpper
@SETLOCAL
@SET "rtrn=%~2"
@SET "string=%~1"
@SET "capstring=%~1"
@FOR %%A in (A B C D E F G H I J K L M N O P Q R S T U V W X Y Z) DO @(
@SET "capstring=!capstring:%%A=%%A!"
)
@SET "result=!capstring!"
@ENDLOCAL & (
@IF "%~2" neq "" (
@SET "%rtrn%=%result%"
) ELSE (
@ECHO stringToUpper %string% result: %result%
)
)
@EXIT /B
:isNumeric
@SETLOCAL
@SET "notnumeric="&FOR /F "delims=0123456789" %%i in ("%1") do set "notnumeric=%%i"
@IF defined notnumeric (
@SET "result=false"
) else (
@SET "result=true"
)
@SET "rtrn=%~2"
@ENDLOCAL & (
@IF "%~2" neq "" (
@SET "%rtrn%=%result%"
) ELSE (
@ECHO %result%
)
)
@EXIT /B
:endlib
: \
@REM @SET taskexit_code=!errorlevel! & goto :exit_multishell
@GOTO :exit_multishell
# }
# -*- tcl -*-
# ## ### ### ### ### ### ### ### ### ### ### ### ### ###
# -- tcl script section
# -- This is a punk multishell file
# -- Primary payload target is Tcl, with sh,bash,powershell as helpers
# -- but it may equally be used with any of these being the primary script.
# -- It is tuned to run when called as a batch file, a tcl script a sh/bash script or a pwsh/powershell script
# -- i.e it is a polyglot file.
# -- The specific layout including some lines that appear just as comments is quite sensitive to change.
# -- It can be called on unix or windows platforms with or without the interpreter being specified on the commandline.
# -- e.g ./filename.polypunk.cmd in sh or bash
# -- e.g tclsh filename.cmd
# --
# ## ### ### ### ### ### ### ### ### ### ### ### ### ###
rename set ""; rename s set; set k {-- "$@" "a}; if {[info exists ::env($k)]} {unset ::env($k)} ;# tidyup and restore
Hide :exit_multishell;Hide {<#};Hide '@
namespace eval ::punk::multishell {
set last_script_root [file dirname [file normalize ${argv0}/__]]
set last_script [file dirname [file normalize [info script]/__]]
if {[info exists argv0] &&
$last_script eq $last_script_root
} {
set ::punk::multishell::is_main($last_script) 1 ;#run as executable/script - likely desirable to launch application and return an exitcode
} else {
set ::punk::multishell::is_main($last_script) 0 ;#sourced - likely to be being used as a library - no launch, no exit. Can use return.
}
if {"::punk::multishell::is_main" ni [info commands ::punk::multishell::is_main]} {
proc ::punk::multishell::is_main {{script_name {}}} {
if {$script_name eq ""} {
set script_name [file dirname [file normalize [info script]/--]]
}
if {![info exists ::punk::multishell::is_main($script_name)]} {
#e.g a .dll or something else unanticipated
puts stderr "Warning punk::multishell didn't recognize info script result: $script_name - will treat as if sourced and return instead of exiting"
puts stderr "Info: script_root: [file dirname [file normalize ${argv0}/__]]"
return 0
}
return [set ::punk::multishell::is_main($script_name)]
}
}
}
# -- --- --- --- --- --- --- --- --- --- --- --- --- ---begin Tcl Payload
#puts "script : [info script]"
#puts "argcount : $::argc"
#puts "argvalues: $::argv"
#puts "argv0 : $::argv0"
# -- --- --- --- --- --- --- --- --- --- --- ---
#<tcl-pre-launch-subprocess>
#</tcl-pre-launch-subprocess>
#<tcl-launch-subprocess>
#</tcl-launch-subproces>
#<tcl-post-launch-subprocess>
#</tcl-post-launch-subproces>
# -- --- --- --- --- --- --- --- --- --- --- ---
# -- Best practice is to always return or exit above, or just by leaving the below defaults in place.
# -- If the multishell script is modified to have Tcl below the Tcl Payload section,
# -- then Tcl bracket balancing needs to be carefully managed in the shell and powershell sections below.
# -- Only the # in front of the two relevant if statements below needs to be removed to enable Tcl below
# -- but the sh/bash 'then' and 'fi' would also need to be uncommented.
# -- This facility left in place for experiments on whether configuration payloads etc can be appended
# -- to tail of file - possibly binary with ctrl-z char - but utility is dependent on which other interpreters/shells
# -- can be made to ignore/cope with such data.
if {[::punk::multishell::is_main]} {
exit 0
} else {
return
}
# -- --- --- --- --- --- --- --- --- --- --- --- --- ---end Tcl Payload
# end hide from unix shells \
HEREDOC1B_HIDE_FROM_BASH_AND_SH
# sh/bash \
shift && set -- "${@:1:$#-1}"
#------------------------------------------------------
# -- This if block only needed if Tcl didn't exit or return above.
if false==false # else {
then
: #
# ## ### ### ### ### ### ### ### ### ### ### ### ### ###
# -- sh/bash script section
# -- leave as is if all that is required is launching the Tcl payload"
# --
# -- Note that sh/bash script isn't called when running a .bat/.cmd from cmd.exe on windows by default
# -- adjust the %nextshell% value above
# -- if sh/bash scripting needs to run on windows too.
# --
# ## ### ### ### ### ### ### ### ### ### ### ### ### ###
# -- --- --- --- --- --- --- --- --- --- --- --- --- ---begin sh Payload
exitcode=0
#printf "start of bash or sh code"
#<shell-pre-launch-subprocess>
#</shell-pre-launch-subprocess>
# -- --- --- --- --- --- --- ---
#<shell-launch-subprocess>
#-- sh/bash launches Tcl here instead of shebang line at top
#-- use exec to use exitcode (if any) directly from the tcl script
#exec /usr/bin/env tclsh "$0" "$@"
#-- alternative - can run sh/bash script after the tcl call.
/usr/bin/env tclsh "$0" "$@"
exitcode=$?
#echo "sh/bash reporting tcl exitcode: ${exitcode}"
#-- override exitcode example
#exit 66
#</shell-launch-subprocess>
# -- --- --- --- --- --- --- ---
#<shell-post-launch-subprocess>
#</shell-post-launch-subproces>
#printf "sh/bash done \n"
# -- --- --- --- --- --- --- --- --- --- --- --- --- ---end sh Payload
#------------------------------------------------------
fi
exit ${exitcode}
# ## ### ### ### ### ### ### ### ### ### ### ### ### ###
# -- Perl script section
# -- leave the script below as is, if all that is required is launching the Tcl payload"
# --
# -- Note that perl script isn't called by default when simply running this script by name
# -- adjust the nextshell value at the top of the script to point to perl
# --
# ## ### ### ### ### ### ### ### ### ### ### ### ### ###
=cut
#!/user/bin/perl
# -- --- --- --- --- --- --- --- --- --- --- --- --- ---begin perl Payload
my $exit_code = 0;
#use ExtUtils::Installed;
#my $installed = ExtUtils::Installed->new();
#my @modules = $installed->modules();
#print "Modules:\n";
#foreach my $m (@modules) {
# print "$m\n";
#}
# -- --- ---
my $scriptname = $0;
print "perl $scriptname\n";
my $i =1;
foreach my $a(@ARGV) {
print "Arg # $i: $a\n";
}
#<perl-pre-launch-subprocess>
#</perl-pre-launch-subprocess>
# -- --- --- --- --- --- --- ---
#<perl-launch-subprocess>
$exit_code=system("tclsh", $scriptname, @ARGV);
#print "perl reporting tcl exitcode: $exit_code";
#</perl-launch-subprocess>
# -- --- --- --- --- --- --- ---
#<perl-post-launch-subprocess>
#</perl-post-launch-subprocess>
# -- --- --- --- --- --- --- --- --- --- --- --- --- ---end perl Payload
exit $exit_code;
__END__
# end hide sh/bash/perl block from Tcl
# This comment with closing brace should stay in place whether if commented or not }
#------------------------------------------------------
# begin hide powershell-block from Tcl - only needed if Tcl didn't exit or return above
if 0 {
: end heredoc1 - end hide from powershell \
'@
# ## ### ### ### ### ### ### ### ### ### ### ### ### ###
# -- powershell/pwsh section
# -- Do not edit if current file is the .ps1
# -- Edit the corresponding .cmd and it will autocopy
# -- unbalanced braces { } here *even in comments* will cause problems if there was no Tcl exit or return above
# ## ### ### ### ### ### ### ### ### ### ### ### ### ###
function GetScriptName { $myInvocation.ScriptName }
$scriptname = getScriptName
# -- --- --- --- --- --- --- --- --- --- --- --- --- ---begin powershell Payload
#"Timestamp : {0,10:yyyy-MM-dd HH:mm:ss}" -f $(Get-Date) | write-host
#"Script Name : {0}" -f $scriptname | write-host
#"Powershell Version: {0}" -f $PSVersionTable.PSVersion.Major | write-host
#"powershell args : {0}" -f ($args -join ", ") | write-host
# -- --- --- ---
#<powershell-pre-launch-subprocess>
$url = "https://www.gitea1.intx.com.au/jn/punkbin/raw/branch/master/win64/tclkit86bi.exe"
$output = "$(join-path $PSScriptRoot "..\src\runtime\tclkit86bi.exe")"
if (-not(Test-Path -Path $output -PathType Leaf)) {
try {
#Invoke-WebRequest $url -OutFile
Import-Module BitsTransfer
Start-BitsTransfer -Source $url -Destination $output
Write-Host "Runtime saved at $output"
}
catch {
throw $_.Exception.Message
}
}
else {
Write-Host "Runtime already found at $output"
}
#</powershell-pre-launch-subprocess>
# -- --- --- --- --- --- --- ---
#<powershell-launch-subprocess>
tclsh $scriptname $args
#"powershell reporting exitcode: {0}" -f $LASTEXITCODE | write-host
#</powershell-launch-subprocess>
# -- --- --- --- --- --- --- ---
#<powershell-post-launch-subprocess>
#</powershell-post-launch-subprocess>
# -- --- --- --- --- --- --- --- --- --- --- --- --- ---end powershell Payload
Exit $LASTEXITCODE
# heredoc2 for powershell to ignore block below
$1 = @'
'
: comment end hide powershell-block from Tcl \
# This comment with closing brace should stay in place whether 'if' commented or not }
: multishell doubled-up cmd exit label - return exitcode
:exit_multishell
:exit_multishell
: \
@REM @ECHO exitcode: !task_exitcode!
: \
@IF "%1"=="PUNK-ELEVATED" (echo. & @cmd /k echo elevated prompt: type exit to quit)
: \
@EXIT /B !task_exitcode!
# cmd has exited
: comment end heredoc2 \
'@
<#
# id:tailblock0
# -- powershell multiline comment
#>
<#
no script engine should try to run me
# id:tailblock1
# <ctrl-z>

# </ctrl-z>
# -- unreachable by tcl directly if ctrl-z character is in the <ctrl-z> section above. (but file can be read and split on \x1A)
# -- Potential for zip and/or base64 contents, but we can't stop pwsh parser from slurping in the data
# -- so for example a plain text tar archive could cause problems depending on the content.
# -- final line in file must be the powershell multiline comment terminator or other data it can handle.
# -- e.g plain # comment lines will work too
# -- (for example a powershell digital signature is a # commented block of data at the end of the file)
#>

43
bin/runtime.cmd
Unescape View File

@ -940,6 +940,7 @@ if {$nextshelltype ne "tcl" && $nextshelltype ne "none"} {
#maint: keep this munging in sync with zsh/bash and perl blocks which must also do msys mangling
if {[regexp {^cmd$|^cmd[.]exe$} $cmdword]} {
#need to deal with msys argument munging
puts stderr "cmd call via msys detected. performing translation of /c to //C"
#for now we only deal with /C or /c - todo - other cmd.exe flags?
#In this context we would usually only be using cmd.exe /c to launch older 'desktop' powershell to avoid spaced-argument problems - so we aren't expecting other flags
set new_nextshellpath [list $cmdword]
@ -1228,13 +1229,14 @@ if [[ "$nextshelltype" != "bash" && "$nextshelltype" != "none" ]]; then
#do not double quote cmdpattern - or it will be treated as literal string
if [[ "$nextshellpath" =~ $cmdpattern ]]; then
#for now - tell the user what's going on
echo "cmd call via msys detected. performing translation of /c to //c and escaping backslashes in script path"
echo "cmd call via msys detected. performing translation of /c to //c and escaping backslashes in script path" >&2
#flags to cmd.exe such as /c are interpreted by msys as looking like a unix path
#review - for nextshellpath targets specified in the block for win32 - we don't expect unix paths (?)
#what about other flags? - can we just double up all forward slashes?
#maint: keep this munging in sync with the tcl block and perl block which must also do msys munging
nextshellpath="${nextshellpath// \/[cC] / \/\/c }"
# echo "new nextshellpath: ${nextshellpath}"
#review -
#don't double quote this
script=${script//\\/\\\\}
fi
@ -1482,8 +1484,33 @@ if 0 {
# -- unbalanced braces { } here *even in comments* will cause problems if there was no Tcl exit or return above
# -- custom script should generally go below the begin_powershell_payload line
# ## ### ### ### ### ### ### ### ### ### ### ### ### ###
function GetScriptName { $myInvocation.ScriptName }
$scriptname = GetScriptName
#$MyInvocation.ScriptName should probably be considered deprecated
# https://stackoverflow.com/questions/78511229/how-can-i-choose-between-myinvocation-scriptname-and-myinvocation-pscommandpat
$runningscriptname = $PSCommandPath
if (-not $MyInvocation.PSCommandPath) {
$callingscriptname = ''
} else {
$callingscriptname = $MyInvocation.PSCommandPath
}
#The problem with psmodulepath
#https://github.com/PowerShell/PowerShell/issues/18108
# psmodulepath is shared by powershell and pwsh despite not all ps modules being compatible.
# It is futzed with by powershell/pwsh based on detecting the child process type.
# a psmodulepath that has been futzed with by pwsh will not work for a child powershell 5 process that isn't launched directly
#This is inherently unfriendly to situations where an intervening process may be something else such as cmd.exe,tcl,perl etc
# nevertheless, powershell/pwsh maintainers seem to have taken the MS-centric view of the world that such situations don't exist :/
#
#symptoms of these shenannigans not working include things like Get-FileHash failing in powershell desktop
#
#We don't know if the original console was pwsh/powershell or cmd.exe, and we need to potentially divert to powershell 5 (desktop)
#via tcl or perl etc - or cmd.exe
if ($PSVersionTable.PSVersion.Major -le 5) {
# For Windows PowerShell, we want to remove any PowerShell 7 paths from PSModulePath
#snipped from https://github.com/PowerShell/DSC/pull/777/commits/af9b99a4d38e0cf1e54c4bbd89cbb6a8a8598c4e
#Presumably users are supposed to know not to have custom paths for powershell desktop containing a 'pwershell' subfolder??
$env:PSModulePath = ($env:PSModulePath -split ';' | Where-Object { $_ -notlike '*\powershell\*' }) -join ';'
}
function GetDynamicParamDictionary {
[CmdletBinding()]
param(
@ -1558,11 +1585,11 @@ function GetDynamicParamDictionary {
#}
#psmain @args
#"Timestamp : {0,10:yyyy-MM-dd HH:mm:ss}" -f $(Get-Date) | write-host
"Script Name : {0}" -f $scriptname | write-host
#"Running Script Name : {0}" -f $runningscriptname | write-host
"Powershell Version: {0}" -f $PSVersionTable.PSVersion.Major | write-host
"powershell args : {0}" -f ($args -join ", ") | write-host
#"powershell args : {0}" -f ($args -join ", ") | write-host
# -- --- --- ---
$thisfileContent = Get-Content $scriptname -Raw
$thisfileContent = Get-Content $runningscriptname -Raw
$startTag = ": <<asadmin_start>>"
$endTag = ": <<asadmin_end>>"
$pattern = "(?s)`n$startTag[^`n]*`n(.*?)`n$endTag"
@ -1661,7 +1688,7 @@ if ($match.Success) {
}
if (-not (("pwsh", "powershell", "") -contains $nextshell_type)) {
#nextshell diversion exists for this platform
write-host "os: $os pwsh/powershell launching subshell of type: $nextshell_type shellpath: $nextshell_path on script $scriptname"
write-host "os: $os pwsh/powershell launching subshell of type: $nextshell_type shellpath: $nextshell_path on script $runningscriptname"
# $arguments = @($($MyInvocation.MyCommand.Path))
# $arguments += $args
@ -1669,7 +1696,7 @@ if ($match.Success) {
# $process = (Start-Process -FilePath $nextshell_path -ArgumentList $arguments -NoNewWindow -Wait)
# Exit $process.ExitCode
& $nextshell_path $scriptname $args
& $nextshell_path $runningscriptname $args
exit $LASTEXITCODE
}
}

4
bin/sdx.bat
Unescape View File

@ -1,4 +0,0 @@
::lindex tcl;#\
@call "%~dp0..\src\runtime\tclkit86bi.exe" "%~dp0sdx.kit" %* & goto :eof
# --- --- --- --- --- --- --- --- --- --- --- --- ---begin comments only
#

BIN
bin/sdx.kit
View File

Binary file not shown.

57
scriptlib/stdout_per_second.tcl
Unescape View File

@ -25,21 +25,26 @@ set newline_every_x_seconds 5
#---
chan configure stdout -blocking 1 -buffering none
set counter 0
set ms [expr {1000 / $persec}]
set nl_every [expr {$persec * $newline_every_x_seconds}]
set ms [expr {round(1000 / $persec)}]
set nl_every [expr {round($persec * $newline_every_x_seconds)}]
proc schedule {} {
upvar ::counter c
upvar ::maxcount maxcount
upvar ::ms ms
if {$::forever_stdout_per_second} {
if {$maxcount > 0 && $c >= $maxcount} {
set ::forever_stdout_per_second 0
} else {
after idle [list after 0 ::emit]
}
if {$ms == 0} {
tailcall after idle ::schedule
} else {
tailcall after $::ms ::schedule
}
} else {
after idle [list ::the_end]
after 0 [list ::the_end]
}
}
@ -55,24 +60,64 @@ proc the_end {} {
proc emit {} {
upvar ::counter c
if {($c > 1) && (($c % $::nl_every) == 0)} {
puts -nonewline stdout " "
puts -nonewline stdout "$::what "
flush stdout
puts stderr $c
flush stderr
} else {
puts -nonewline stdout $::what
}
#flush stdout
incr c
}
set original_config [chan configure stdin]
chan configure stdin -blocking 0 -buffering none
catch {chan configure stdin -inputmode raw}
variable ::cmdbuffer ""
chan event stdin readable [list apply {{chan} {
upvar ::cmdbuffer b
set chunk [chan read $chan]
if {[string length $chunk]} {
if {[string match "*q*" [string tolower $chunk]]} {
set ::forever_stdout_per_second 0
chan event $chan readable {}
puts stderr "cancelling"
if {$::ms > 500} {
after 0 ::the_end
}
} else {
if {[catch {
package require punk::ansi
puts stderr [punk::ansi::a bold yellow][punk::ansi::ansistring VIEW -lf 1 -cr 1 -crlf 1 $chunk][punk::ansi::a]
} _err]} {
puts stderr $chunk
}
}
if {$chunk in [list "\r" "\n" "\r\n"]} {
if {[string is double -strict $b]} {
if {$b == 0} {
puts stderr "ms must be > 0"
set ::ms 1
}
set ::ms [expr {round(1000 / $b)}]
set ::nl_every [expr {round($b * $::newline_every_x_seconds)}]
puts stderr "ms: $::ms"
} else {
if {[string match "!*" $b]} {
set cmd [string range $b 1 end]
if {[catch {eval $cmd} result]} {
puts stderr "error: $result"
} else {
puts stderr "ok"
puts stderr $result
}
} else {
puts stderr "cmd: '$b' not understood - use 'q' to quit"
}
}
set b ""
} else {
append b $chunk
}
}
if {[chan eof $chan]} {
@ -84,6 +129,8 @@ schedule
vwait ::forever_stdout_per_second
vwait ::done_stdout_per_second
catch {chan configure stdin {*}$originalconfig}

201
scriptlib/utils/pwsh/consolemode.ps1
Unescape View File

@ -0,0 +1,201 @@
# from github.com/dahlbyk/posh-git
# ------------------------------------------------------------------------------------
#Copyright (c) 2010-2018 Keith Dahlby, Keith Hill, and contributors
#Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions:
#The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software.
#THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
# ------------------------------------------------------------------------------------
# Always skip setting the console mode on non-Windows platforms.
if (($PSVersionTable.PSVersion.Major -ge 6) -and !$IsWindows) {
function Set-ConsoleMode {
[Diagnostics.CodeAnalysis.SuppressMessageAttribute("PSUseShouldProcessForStateChangingFunctions", "")]
param()
}
return
}
$consoleModeSource = @"
using System;
using System.Runtime.InteropServices;
public class NativeConsoleMethods
{
[DllImport("kernel32.dll", CharSet = CharSet.Unicode, SetLastError = true)]
public static extern IntPtr GetStdHandle(int handleId);
[DllImport("kernel32.dll", CharSet = CharSet.Unicode, SetLastError = true)]
public static extern bool GetConsoleMode(IntPtr hConsoleOutput, out uint dwMode);
[DllImport("kernel32.dll", CharSet = CharSet.Unicode, SetLastError = true)]
public static extern bool SetConsoleMode(IntPtr hConsoleOutput, uint dwMode);
public static uint GetConsoleMode(bool input = false)
{
var handle = GetStdHandle(input ? -10 : -11);
uint mode;
if (GetConsoleMode(handle, out mode))
{
return mode;
}
return 0xffffffff;
}
public static uint SetConsoleMode(bool input, uint mode)
{
var handle = GetStdHandle(input ? -10 : -11);
if (SetConsoleMode(handle, mode))
{
return GetConsoleMode(input);
}
return 0xffffffff;
}
}
"@
[Flags()]
enum ConsoleModeInputFlags
{
ENABLE_PROCESSED_INPUT = 0x0001
ENABLE_LINE_INPUT = 0x0002
ENABLE_ECHO_INPUT = 0x0004
ENABLE_WINDOW_INPUT = 0x0008
ENABLE_MOUSE_INPUT = 0x0010
ENABLE_INSERT_MODE = 0x0020
ENABLE_QUICK_EDIT_MODE = 0x0040
ENABLE_EXTENDED_FLAGS = 0x0080
ENABLE_AUTO_POSITION = 0x0100
ENABLE_VIRTUAL_TERMINAL_PROCESSING = 0x0200
}
[Flags()]
enum ConsoleModeOutputFlags
{
ENABLE_PROCESSED_OUTPUT = 0x0001
ENABLE_WRAP_AT_EOL_OUTPUT = 0x0002
ENABLE_VIRTUAL_TERMINAL_PROCESSING = 0x0004
}
function Set-ConsoleMode
{
[Diagnostics.CodeAnalysis.SuppressMessageAttribute("PSUseShouldProcessForStateChangingFunctions", "")]
param(
[Parameter(ParameterSetName = "ANSI")]
[switch]
$ANSI,
[Parameter(ParameterSetName = "Mode")]
[uint32]
$Mode,
[switch]
$StandardInput
)
begin {
# Module import is speeded up by deferring the Add-Type until the first time this function is called.
# Add the NativeConsoleMethods type but only once per session.
if (!('NativeConsoleMethods' -as [System.Type])) {
Add-Type $consoleModeSource
}
}
end {
if ($ANSI)
{
$outputMode = [NativeConsoleMethods]::GetConsoleMode($false)
$null = [NativeConsoleMethods]::SetConsoleMode($false, $outputMode -bor [ConsoleModeOutputFlags]::ENABLE_VIRTUAL_TERMINAL_PROCESSING)
if ($StandardInput)
{
$inputMode = [NativeConsoleMethods]::GetConsoleMode($true)
$null = [NativeConsoleMethods]::SetConsoleMode($true, $inputMode -bor [ConsoleModeInputFlags]::ENABLE_VIRTUAL_TERMINAL_PROCESSING)
}
}
else
{
[NativeConsoleMethods]::SetConsoleMode($StandardInput, $Mode)
}
}
}
function Get-ConsoleMode
{
[Diagnostics.CodeAnalysis.SuppressMessageAttribute("PSUseShouldProcessForStateChangingFunctions", "")]
param(
[switch]
$StandardInput
)
begin {
# Module import is speeded up by deferring the Add-Type until the first time this function is called.
# Add the NativeConsoleMethods type but only once per session.
if (!('NativeConsoleMethods' -as [System.Type])) {
Add-Type $consoleModeSource
}
}
end {
$mode = [NativeConsoleMethods]::GetConsoleMode($StandardInput)
write-Output $mode
return
}
}
function psmain {
param (
[validateSet('enableRaw', 'disableRaw')]
[string]$Action
)
$inputflags = Get-ConsoleMode -StandardInput
$resultflags = $inputflags #default
if (($inputflags -band [ConsoleModeInputFlags]::ENABLE_LINE_INPUT) -eq [ConsoleModeInputFlags]::ENABLE_LINE_INPUT) {
#cooked mode
$initialstate = "cooked"
if ($action -eq "enableraw") {
#disable cooked flags
$disable = [uint32](-bnot [uint32][ConsoleModeInputFlags]::ENABLE_LINE_INPUT) -band ( -bnot [uint32][ConsoleModeInputFlags]::ENABLE_ECHO_INPUT)
$adjustedflags = $inputflags -band ($disable)
$resultflags = [NativeConsoleMethods]::SetConsoleMode($true,$adjustedflags)
}
} else {
#raw mode
$initialstate = "raw"
if ($action -eq "disableraw") {
#set cooked flags
$adjustedflags = $inputflags -bor [ConsoleModeInputFlags]::ENABLE_LINE_INPUT -bor [ConsoleModeInputFlags]::ENABLE_ECHO_INPUT
$resultflags = [NativeConsoleMethods]::SetConsoleMode($true,$adjustedflags)
}
}
#return in format that can act as a tcl dict
write-host "startflags: $inputflags initialstate: $initialstate action: $Action endflags: $resultflags"
}
psmain @args
#write-host (Get-ConsoleMode)
#Set-ConsoleMode -ANSI -StandardInput
#write-host (Get-ConsoleMode)
#test toggle
#if ((($inputflags -band [ConsoleModeInputFlags]::ENABLE_QUICK_EDIT_MODE)) -eq [ConsoleModeInputFlags]::ENABLE_QUICK_EDIT_MODE) {
# #quick edit is on
# write-host "quick edit is on"
# $adjustedflags = $inputflags -band (-bnot [uint32][ConsoleModeInputFlags]::ENABLE_QUICK_EDIT_MODE)
# $resultflags = [NativeConsoleMethods]::SetConsoleMode($true, $adjustedflags)
##
#} else {
# #quick edit is off
# write-host "quick edit is off"
# $resultflags = [NativeConsoleMethods]::SetConsoleMode($true, $inputflags -bor [ConsoleModeInputFlags]::ENABLE_QUICK_EDIT_MODE)
#}
#todo - parameters so it doesn't act as a toggle
#we want to be able to explicitly set raw vs cooked
#multi

91
scriptlib/utils/pwsh/consolemode_enableraw.ps1
Unescape View File

@ -0,0 +1,91 @@
#!SEMICOLONS must be placed after each command as scriptdata needs to be sent to powershell directly with the -c parameter!
;
if ($PSVersionTable.PSVersion.Major -le 5) {
# For Windows PowerShell, we want to remove any PowerShell 7 paths from PSModulePath
#snipped from https://github.com/PowerShell/DSC/pull/777/commits/af9b99a4d38e0cf1e54c4bbd89cbb6a8a8598c4e
#Presumably users are supposed to know not to have custom paths for powershell desktop containing a 'powershell' subfolder??
;
$env:PSModulePath = ($env:PSModulePath -split ';' | Where-Object { $_ -notlike '*\powershell\*' }) -join ';';
};
$consoleModeSource = @"
using System;
using System.Runtime.InteropServices;
public class NativeConsoleMethods
{
[DllImport("kernel32.dll", CharSet = CharSet.Unicode, SetLastError = true)]
public static extern IntPtr GetStdHandle(int handleId);
[DllImport("kernel32.dll", CharSet = CharSet.Unicode, SetLastError = true)]
public static extern bool GetConsoleMode(IntPtr hConsoleOutput, out uint dwMode);
[DllImport("kernel32.dll", CharSet = CharSet.Unicode, SetLastError = true)]
public static extern bool SetConsoleMode(IntPtr hConsoleOutput, uint dwMode);
public static uint GetConsoleMode(bool input = false)
{
var handle = GetStdHandle(input ? -10 : -11);
uint mode;
if (GetConsoleMode(handle, out mode))
{
return mode;
}
return 0xffffffff;
}
public static uint SetConsoleMode(bool input, uint mode)
{
var handle = GetStdHandle(input ? -10 : -11);
if (SetConsoleMode(handle, mode))
{
return GetConsoleMode(input);
}
return 0xffffffff;
}
}
"@
;
[Flags()]
enum ConsoleModeInputFlags
{
ENABLE_LINE_INPUT = 0x0002
ENABLE_ECHO_INPUT = 0x0004
};
function psmain {
param (
[validateSet('enableRaw', 'disableRaw')]
[string]$Action
);
# $inputflags = Get-ConsoleMode -StandardInput;
if (!('NativeConsoleMethods' -as [System.Type])) {
Add-Type $consoleModeSource
}
$inputFlags = [NativeConsoleMethods]::GetConsoleMode($true);
$resultflags = $inputflags;
if (($inputflags -band [ConsoleModeInputFlags]::ENABLE_LINE_INPUT) -eq [ConsoleModeInputFlags]::ENABLE_LINE_INPUT) {
#cooked mode
$initialstate = "cooked";
if ($action -eq "enableraw") {
#disable cooked flags
$disable = [uint32](-bnot [uint32][ConsoleModeInputFlags]::ENABLE_LINE_INPUT) -band ( -bnot [uint32][ConsoleModeInputFlags]::ENABLE_ECHO_INPUT);
$adjustedflags = $inputflags -band ($disable);
$resultflags = [NativeConsoleMethods]::SetConsoleMode($true,$adjustedflags);
}
} else {
#raw mode
$initialstate = "raw";
if ($action -eq "disableraw") {
#set cooked flags
$adjustedflags = $inputflags -bor [ConsoleModeInputFlags]::ENABLE_LINE_INPUT -bor [ConsoleModeInputFlags]::ENABLE_ECHO_INPUT;
$resultflags = [NativeConsoleMethods]::SetConsoleMode($true,$adjustedflags);
}
}
#return in format that can act as a tcl dict
#write-host "startflags: $inputflags initialstate: $initialstate action: $Action endflags: $resultflags";
};
psmain 'enableRaw';

144
scriptlib/utils/pwsh/consolemode_server.ps1
Unescape View File

@ -0,0 +1,144 @@
#!SEMICOLONS must be placed after each command as scriptdata needs to be sent to powershell directly with the -c parameter!
;
if ($PSVersionTable.PSVersion.Major -le 5) {
# For Windows PowerShell, we want to remove any PowerShell 7 paths from PSModulePath
#snipped from https://github.com/PowerShell/DSC/pull/777/commits/af9b99a4d38e0cf1e54c4bbd89cbb6a8a8598c4e
#Presumably users are supposed to know not to have custom paths for powershell desktop containing a 'powershell' subfolder??
;
$env:PSModulePath = ($env:PSModulePath -split ';' | Where-Object { $_ -notlike '*\powershell\*' }) -join ';';
};
$consoleModeSource = @"
using System;
using System.Runtime.InteropServices;
public class NativeConsoleMethods
{
[DllImport("kernel32.dll", CharSet = CharSet.Unicode, SetLastError = true)]
public static extern IntPtr GetStdHandle(int handleId);
[DllImport("kernel32.dll", CharSet = CharSet.Unicode, SetLastError = true)]
public static extern bool GetConsoleMode(IntPtr hConsoleOutput, out uint dwMode);
[DllImport("kernel32.dll", CharSet = CharSet.Unicode, SetLastError = true)]
public static extern bool SetConsoleMode(IntPtr hConsoleOutput, uint dwMode);
public static uint GetConsoleMode(bool input = false)
{
var handle = GetStdHandle(input ? -10 : -11);
uint mode;
if (GetConsoleMode(handle, out mode))
{
return mode;
}
return 0xffffffff;
}
public static uint SetConsoleMode(bool input, uint mode)
{
var handle = GetStdHandle(input ? -10 : -11);
if (SetConsoleMode(handle, mode))
{
return GetConsoleMode(input);
}
return 0xffffffff;
}
}
"@
;
[Flags()]
enum ConsoleModeInputFlags
{
ENABLE_LINE_INPUT = 0x0002
ENABLE_ECHO_INPUT = 0x0004
};
if (!('NativeConsoleMethods' -as [System.Type])) {
Add-Type $consoleModeSource
}
function psmain {
param (
[validateSet('enableRaw', 'disableRaw')]
[string]$Action
);
# $inputflags = Get-ConsoleMode -StandardInput;
if (!('NativeConsoleMethods' -as [System.Type])) {
Add-Type $consoleModeSource
}
$inputFlags = [NativeConsoleMethods]::GetConsoleMode($true);
$resultflags = $inputflags;
if (($inputflags -band [ConsoleModeInputFlags]::ENABLE_LINE_INPUT) -eq [ConsoleModeInputFlags]::ENABLE_LINE_INPUT) {
#cooked mode
$initialstate = "cooked";
if ($action -eq "enableraw") {
#disable cooked flags
$disable = [uint32](-bnot [uint32][ConsoleModeInputFlags]::ENABLE_LINE_INPUT) -band ( -bnot [uint32][ConsoleModeInputFlags]::ENABLE_ECHO_INPUT);
$adjustedflags = $inputflags -band ($disable);
$resultflags = [NativeConsoleMethods]::SetConsoleMode($true,$adjustedflags);
}
} else {
#raw mode
$initialstate = "raw";
if ($action -eq "disableraw") {
#set cooked flags
$adjustedflags = $inputflags -bor [ConsoleModeInputFlags]::ENABLE_LINE_INPUT -bor [ConsoleModeInputFlags]::ENABLE_ECHO_INPUT;
$resultflags = [NativeConsoleMethods]::SetConsoleMode($true,$adjustedflags);
}
}
#return in format that can act as a tcl dict
#write-host "startflags: $inputflags initialstate: $initialstate action: $Action endflags: $resultflags";
};
# psmain 'enableRaw';
$consoleid = $args[0];
if ([string]::IsNullOrEmpty($consoleid)) {
$consoleid= "<punkshell_consoleid>"
};
$pipeName = "punkshell_ps_consolemode_$consoleid";
"pipename: $pipeName"
$pipeServer = New-Object System.IO.Pipes.NamedPipeServerStream($pipeName);
try {
while ($true) {
#"Waiting for connection on '$pipeName'";
$pipeServer.WaitForConnection();
#"Connection established";
$pipeReader = New-Object System.IO.StreamReader($pipeServer);
#$pipeWriter = New-Object System.IO.StreamWriter($pipeServer);
#$pipeWriter.AutoFlush = $true;
$request = $pipeReader.ReadLine();
# "Received request: $request";
if ($request -eq "exit") {
"consolemode_server.ps1 Exiting";
exit;
} elseif ($request -eq "") {
#"Empty input";
$pipeServer.Disconnect();
#"Disconnected";
continue;
} elseif ($request -eq $none) {
"Remote disconnected before sending";
$pipeServer.Disconnect();
"Disconnected";
continue;
} elseif ($request -eq "enableraw") {
#$result = psmain 'enableRaw';
$null = psmain 'enableRaw'
# "Sending result: '$result'";
#$pipeWriter.Write($result);
$pipeServer.Disconnect();
continue;
} else {
"consolemode_server.ps1 ignoring request: $request";
$pipeServer.Disconnect();
continue;
}
}
}
finally {
$pipeServer.Dispose();
};

244
scriptlib/utils/pwsh/consolemode_server_async.2ps1
Unescape View File

@ -0,0 +1,244 @@
#!SEMICOLONS must be placed after each command as scriptdata needs to be sent to powershell directly with the -c parameter!
;
if ($PSVersionTable.PSVersion.Major -le 5) {
# For Windows PowerShell, we want to remove any PowerShell 7 paths from PSModulePath
#snipped from https://github.com/PowerShell/DSC/pull/777/commits/af9b99a4d38e0cf1e54c4bbd89cbb6a8a8598c4e
#Presumably users are supposed to know not to have custom paths for powershell desktop containing a 'powershell' subfolder??
;
$env:PSModulePath = ($env:PSModulePath -split ';' | Where-Object { $_ -notlike '*\powershell\*' }) -join ';';
};
$helper = @'
using System;
using System.Collections.Generic;
using System.Linq;
using System.Linq.Expressions;
using System.Management.Automation.Runspaces;
public class RunspacedDelegateFactory
{
public static Delegate NewRunspacedDelegate(Delegate _delegate, Runspace runspace)
{
Action setRunspace = () => Runspace.DefaultRunspace = runspace;
return ConcatActionToDelegate(setRunspace, _delegate);
}
private static Expression ExpressionInvoke(Delegate _delegate, params Expression[] arguments)
{
var invokeMethod = _delegate.GetType().GetMethod("Invoke");
return Expression.Call(Expression.Constant(_delegate), invokeMethod, arguments);
}
public static Delegate ConcatActionToDelegate(Action a, Delegate d)
{
var parameters =
d.GetType().GetMethod("Invoke").GetParameters()
.Select(p => Expression.Parameter(p.ParameterType, p.Name))
.ToArray();
Expression body = Expression.Block(ExpressionInvoke(a), ExpressionInvoke(d, parameters));
var lambda = Expression.Lambda(d.GetType(), body, parameters);
var compiled = lambda.Compile();
return compiled;
}
}
'@
add-type -TypeDefinition $helper
#region console
$consoleModeSource = @"
using System;
using System.Runtime.InteropServices;
public class NativeConsoleMethods
{
[DllImport("kernel32.dll", CharSet = CharSet.Unicode, SetLastError = true)]
public static extern IntPtr GetStdHandle(int handleId);
[DllImport("kernel32.dll", CharSet = CharSet.Unicode, SetLastError = true)]
public static extern bool GetConsoleMode(IntPtr hConsoleOutput, out uint dwMode);
[DllImport("kernel32.dll", CharSet = CharSet.Unicode, SetLastError = true)]
public static extern bool SetConsoleMode(IntPtr hConsoleOutput, uint dwMode);
public static uint GetConsoleMode(bool input = false)
{
var handle = GetStdHandle(input ? -10 : -11);
uint mode;
if (GetConsoleMode(handle, out mode))
{
return mode;
}
return 0xffffffff;
}
public static uint SetConsoleMode(bool input, uint mode)
{
var handle = GetStdHandle(input ? -10 : -11);
if (SetConsoleMode(handle, mode))
{
return GetConsoleMode(input);
}
return 0xffffffff;
}
}
"@
;
[Flags()]
enum ConsoleModeInputFlags
{
ENABLE_LINE_INPUT = 0x0002
ENABLE_ECHO_INPUT = 0x0004
};
if (!('NativeConsoleMethods' -as [System.Type])) {
Add-Type $consoleModeSource
}
function psmain {
param (
[validateSet('enableRaw', 'disableRaw')]
[string]$Action
);
# $inputflags = Get-ConsoleMode -StandardInput;
if (!('NativeConsoleMethods' -as [System.Type])) {
Add-Type $consoleModeSource
}
$inputFlags = [NativeConsoleMethods]::GetConsoleMode($true);
$resultflags = $inputflags;
if (($inputflags -band [ConsoleModeInputFlags]::ENABLE_LINE_INPUT) -eq [ConsoleModeInputFlags]::ENABLE_LINE_INPUT) {
#cooked mode
$initialstate = "cooked";
if ($action -eq "enableraw") {
#disable cooked flags
$disable = [uint32](-bnot [uint32][ConsoleModeInputFlags]::ENABLE_LINE_INPUT) -band ( -bnot [uint32][ConsoleModeInputFlags]::ENABLE_ECHO_INPUT);
$adjustedflags = $inputflags -band ($disable);
$resultflags = [NativeConsoleMethods]::SetConsoleMode($true,$adjustedflags);
}
} else {
#raw mode
$initialstate = "raw";
if ($action -eq "disableraw") {
#set cooked flags
$adjustedflags = $inputflags -bor [ConsoleModeInputFlags]::ENABLE_LINE_INPUT -bor [ConsoleModeInputFlags]::ENABLE_ECHO_INPUT;
$resultflags = [NativeConsoleMethods]::SetConsoleMode($true,$adjustedflags);
}
}
#return in format that can act as a tcl dict
#write-host "startflags: $inputflags initialstate: $initialstate action: $Action endflags: $resultflags";
};
# psmain 'enableRaw';
#endregion console
$consoleid = $args[0];
if ([string]::IsNullOrEmpty($consoleid)) {
$consoleid= "<punkshell_consoleid>"
};
$pipeName = "punkshell_ps_consolemode_$consoleid";
"pipename: $pipeName";
$pipeServer = New-Object System.IO.Pipes.NamedPipeServerStream(
$pipeName,
[System.IO.Pipes.PipeDirection]::In,
1,
[System.IO.Pipes.PipeTransmissionMode]::Byte,
[System.IO.Pipes.PipeOptions]::Asynchronous
);
#$pipeServer = New-Object System.IO.Pipes.NamedPipeServerStream($pipeName);
;
# Define the callback function for when a client connects
$callback = [System.AsyncCallback]{
param($asyncResult);
$se = $asyncResult.AsyncState.Sync;
$ps = $asyncResult.AsyncState.Pipeserver;
$pn = $asyncResult.AsyncState.Pipename;
Write-Host "Client connected - $pn";
# End the asynchronous wait operation
;
$ps.EndWaitForConnection($asyncResult);
#??
;
# You can now perform read/write operations with the client
# For example, create a StreamReader and StreamWriter
;
$streamReader = New-Object System.IO.StreamReader($ps);
#$streamWriter = New-Object System.IO.StreamWriter($pipeServer);
#$streamWriter.AutoFlush = $true;
try {
$message = $streamReader.ReadLine();
Write-Host "Received: $message";
;
#$asyncResult.Message = $message;
;
} catch {
Write-Error "Error during communication: $($_.Exception.Message)";
} finally {
# sever connection with client but keep the named pipe
if ($streamReader -ne $null) {
Write-Host "streamreader closing";
$streamReader.Close();
Write-Host "streamreader closed";
}
Write-Host "Client disconnecting. $pn";
$ps.Disconnect();
Write-Host "Client disconnected. $pn";
#$ps.Disconnect();
#[System.Console]::Out.Flush();
;
};
write-host "HERE";
$se.set();
# Optionally, you can call BeginWaitForConnection again to listen for another client
# if your server is designed for multiple connections over time.
# $pipeServer.BeginWaitForConnection($callback, $null)
$ps.BeginWaitForConnection($callback, $null)
;
};
$syncEvent = New-Object System.Threading.ManualResetEvent($false);
$runspacedDelegate = [RunspacedDelegateFactory]::NewRunspacedDelegate($callback, [Runspace]::DefaultRunspace);
$loop = 0;
while ($loop -lt 15) {
Write-Host "Waiting for client connection on pipe '$pipeName'...";
# Begin the asynchronous wait for a client connection
;
$state = [PSCustomObject]@{
Loop = $loop
Sync = $SyncEvent
Pipeserver = $pipeServer
Pipename = $pipename
Message = ""
};
$x = $pipeServer.BeginWaitForConnection($runspacedDelegate, $state );
$syncEvent.WaitOne(10000);
# $x | Get-Member | write-host
;
write-host "msg: $(${x}.AsyncState.Message)"
if ($x.IsCompleted) {
write-host "completed";
};
$SyncEvent.reset();
$loop += 1;
#$cli = New-Object System.IO.Pipes.NamedPipeClientStream($pipeName);
#$cli.w
}
# Keep the script running to allow the asynchronous operation to complete
# In a real-world scenario, you might have a loop or other logic here.
#Read-Host "Press Enter to exit the server."
# Clean up
$pipeServer.Dispose();

262
scriptlib/utils/pwsh/consolemode_server_async.ps1
Unescape View File

@ -0,0 +1,262 @@
#!SEMICOLONS must be placed after each command as scriptdata needs to be sent to powershell directly with the -c parameter!
;
if ($PSVersionTable.PSVersion.Major -le 5) {
# For Windows PowerShell, we want to remove any PowerShell 7 paths from PSModulePath
#snipped from https://github.com/PowerShell/DSC/pull/777/commits/af9b99a4d38e0cf1e54c4bbd89cbb6a8a8598c4e
#Presumably users are supposed to know not to have custom paths for powershell desktop containing a 'powershell' subfolder??
;
$env:PSModulePath = ($env:PSModulePath -split ';' | Where-Object { $_ -notlike '*\powershell\*' }) -join ';';
};
$consoleModeSource = @"
using System;
using System.Runtime.InteropServices;
public class NativeConsoleMethods
{
[DllImport("kernel32.dll", CharSet = CharSet.Unicode, SetLastError = true)]
public static extern IntPtr GetStdHandle(int handleId);
[DllImport("kernel32.dll", CharSet = CharSet.Unicode, SetLastError = true)]
public static extern bool GetConsoleMode(IntPtr hConsoleOutput, out uint dwMode);
[DllImport("kernel32.dll", CharSet = CharSet.Unicode, SetLastError = true)]
public static extern bool SetConsoleMode(IntPtr hConsoleOutput, uint dwMode);
public static uint GetConsoleMode(bool input = false)
{
var handle = GetStdHandle(input ? -10 : -11);
uint mode;
if (GetConsoleMode(handle, out mode))
{
return mode;
}
return 0xffffffff;
}
public static uint SetConsoleMode(bool input, uint mode)
{
var handle = GetStdHandle(input ? -10 : -11);
if (SetConsoleMode(handle, mode))
{
return GetConsoleMode(input);
}
return 0xffffffff;
}
}
"@
;
[Flags()]
enum ConsoleModeInputFlags
{
ENABLE_PROCESSED_INPUT = 0x0001
ENABLE_LINE_INPUT = 0x0002
ENABLE_ECHO_INPUT = 0x0004
ENABLE_WINDOW_INPUT = 0x0008
ENABLE_MOUSE_INPUT = 0x0010
ENABLE_INSERT_MODE = 0x0020
ENABLE_QUICK_EDIT_MODE = 0x0040
ENABLE_EXTENDED_FLAGS = 0x0080
ENABLE_AUTO_POSITION = 0x0100
ENABLE_VIRTUAL_TERMINAL_PROCESSING = 0x0200
};
[Flags()]
enum ConsoleModeOutputFlags
{
ENABLE_PROCESSED_OUTPUT = 0x0001
ENABLE_WRAP_AT_EOL_OUTPUT = 0x0002
ENABLE_VIRTUAL_TERMINAL_PROCESSING = 0x0004
};
if (!('NativeConsoleMethods' -as [System.Type])) {
Add-Type $consoleModeSource
}
function rawmode {
param (
[validateSet('enable', 'disable')]
[string]$Action
);
# $inputflags = Get-ConsoleMode -StandardInput;
if (!('NativeConsoleMethods' -as [System.Type])) {
Add-Type $consoleModeSource
}
$inputFlags = [NativeConsoleMethods]::GetConsoleMode($true);
$resultflags = $inputflags;
if (($inputflags -band [ConsoleModeInputFlags]::ENABLE_LINE_INPUT) -eq [ConsoleModeInputFlags]::ENABLE_LINE_INPUT) {
#cooked mode
$initialstate = "cooked";
if ($action -eq "enable") {
#disable cooked flags
$disable = [uint32](-bnot [uint32][ConsoleModeInputFlags]::ENABLE_LINE_INPUT) -band ( -bnot [uint32][ConsoleModeInputFlags]::ENABLE_ECHO_INPUT);
$adjustedflags = $inputflags -band ($disable);
$resultflags = [NativeConsoleMethods]::SetConsoleMode($true,$adjustedflags);
}
} else {
#raw mode
$initialstate = "raw";
if ($action -eq "disable") {
#set cooked flags
$adjustedflags = $inputflags -bor [ConsoleModeInputFlags]::ENABLE_LINE_INPUT -bor [ConsoleModeInputFlags]::ENABLE_ECHO_INPUT;
$resultflags = [NativeConsoleMethods]::SetConsoleMode($true,$adjustedflags);
}
}
#return in format that can act as a tcl dict
#write-host "startflags: $inputflags initialstate: $initialstate action: $Action endflags: $resultflags";
};
# rawmode 'enable';
$consoleid = $args[0];
if ([string]::IsNullOrEmpty($consoleid)) {
$consoleid= "<punkshell_consoleid>"
};
$pipeName = "punkshell_ps_consolemode_$consoleid";
"pipename: $pipeName"
#$pipeServer = New-Object System.IO.Pipes.NamedPipeServerStream($pipeName);
$sharedData = [hashtable]::Synchronized(@{}) #TSV
$scriptblock = {
param($tsv);
Add-Type -AssemblyName System.IO.Pipes;
#$pipeServer = New-Object System.IO.Pipes.NamedPipeServerStream(
# $pipeName,
# [System.IO.Pipes.PipeDirection]::In,
# 1,
# [System.IO.Pipes.PipeTransmissionMode]::Byte,
# [System.IO.Pipes.PipeOptions]::Asynchronous
#);
;
$serverloop = 0;
while ($true) {
$pipeServer = New-Object System.IO.Pipes.NamedPipeServerStream($pipeName);
$serverloop += 1;
$pipeServer.WaitForConnection();
#write-host "Connection established";
$reader = New-Object System.IO.StreamReader($pipeServer);
if ($reader -ne $null) {
$message = $reader.ReadLine();
$reader.Close();
$reader.Dispose();
if ($message -ne $null) {
if ($message -eq "exit") {
#write-host "consolemode_server.ps1 exiting";
$tsv.State = "done";
break;
} elseif ($message -eq "enableraw") {
#write-host "RECEIVED: $message";
$tsv.Message = $message;
#$tsv.Message = "$pipeName serverloop: $serverloop";
$tsv.Ping = Get-Date;
$msync.Set();
};
} else {
# write-host "consolemode_server.ps1 null-msg";
$tsv.State = "done";
break;
};
};
$pipeServer.Disconnect();
$pipeServer.Dispose();
};
exit;
};
$keepalive_timeout = 20; #number of seconds without ping or other message, after which we terminate the process.
try {
$syncEvent = New-Object System.Threading.ManualResetEvent($false);
$runspace = [runspacefactory]::CreateRunspace();
[void]$runspace.Open();
$runspace.SessionStateProxy.SetVariable("pipeName", $pipeName);
$runspace.SessionStateProxy.SetVariable("pipeServer", $null);
$runspace.SessionStateProxy.SetVariable("msync", $syncEvent);
$powershell = [System.Management.Automation.PowerShell]::Create();
$powershell.Runspace = $runspace;
[void]$powershell.Addscript($scriptblock).AddArgument($sharedData);
$sharedData.State = "running";
$sharedData.Ping = Get-Date;
$asyncResult = $powershell.BeginInvoke();
write-Host "Started named pipe server $pipeName in runspace"
$loop = 0;
while ($true) {
$loop += 1;
#write-host "loop $loop";
[void]$syncEvent.WaitOne(($keepalive_timeout * 1000 / 2));
$msg = $sharedData.Message;
#Write-Host "$pipeName Last message: $msg";
$sharedData.Message = "";
if ($msg -eq "enableraw") {
$null = rawmode 'enable'
} elseif ($msg -eq "disableraw") {
$null = rawmode 'disable'
}
#write-host "STATE: $(${sharedData}.State)"
if ($(${sharedData}.State) -eq "done") {
break;
};
$tnow = Get-Date;
$elapsed = New-TimeSpan -Start $sharedData.Ping -End $tnow;
if ($elapsed.TotalSeconds -lt $keepalive_timeout) {
# write-host "ping ok";
} else {
write-host "ping stale for pipe $pipeName - exiting";
break;
}
[void]$syncEvent.Reset();
# start-sleep -Milliseconds 300
};
} finally {
# Failing to properly shut down the run process can leave an orphan powershell process
# We need to use a client for the named pipe to send an exit message.
# Write-Host "terminating process for $pipeName";
try {
# Write-Host "creating cli for $pipeName";
$cli = New-Object System.IO.Pipes.NamedPipeClientStream($pipeName);
$cli.connect(1000);
#Write-Host "sending exit for $pipeName";
$writer = new-object System.IO.StreamWriter($cli);
$writer.writeline("exit");
$writer.flush();
#Write-Host "disposing of cli for $pipeName";
$cli.Dispose();
} catch {
write-host "error during cli tidyup";
Write-Error "error: $($PSItem.ToString())";
Write-Host "Detailed Exception Message: $($PSItem.Exception.Message)";
};
try {
if ($null -ne $runspace) {
#Write-Host "closing runspace for $pipeName";
$runspace.Close();
#Write-Host "disposing of runspace for $pipeName";
$runspace.Dispose();
};
} catch {
write-host "error during runspace tidyup";
Write-Error "error: $($PSItem.ToString())";
Write-Host "Detailed Exception Message: $($PSItem.Exception.Message)";
} finally {
};
try {
if ($null -ne $powershell) {
#Write-Host "tidying up powershell for $pipeName";
$powershell.dispose();
};
} finally {
};
};
write-host "consolemode_server_async.ps1 shutdown for pipe $pipeName";
exit 0;

266
scriptlib/utils/pwsh/consolemode_server_async1.ps1
Unescape View File

@ -0,0 +1,266 @@
#!SEMICOLONS must be placed after each command as scriptdata needs to be sent to powershell directly with the -c parameter!
;
if ($PSVersionTable.PSVersion.Major -le 5) {
# For Windows PowerShell, we want to remove any PowerShell 7 paths from PSModulePath
#snipped from https://github.com/PowerShell/DSC/pull/777/commits/af9b99a4d38e0cf1e54c4bbd89cbb6a8a8598c4e
#Presumably users are supposed to know not to have custom paths for powershell desktop containing a 'powershell' subfolder??
;
$env:PSModulePath = ($env:PSModulePath -split ';' | Where-Object { $_ -notlike '*\powershell\*' }) -join ';';
};
$consoleModeSource = @"
using System;
using System.Runtime.InteropServices;
public class NativeConsoleMethods
{
[DllImport("kernel32.dll", CharSet = CharSet.Unicode, SetLastError = true)]
public static extern IntPtr GetStdHandle(int handleId);
[DllImport("kernel32.dll", CharSet = CharSet.Unicode, SetLastError = true)]
public static extern bool GetConsoleMode(IntPtr hConsoleOutput, out uint dwMode);
[DllImport("kernel32.dll", CharSet = CharSet.Unicode, SetLastError = true)]
public static extern bool SetConsoleMode(IntPtr hConsoleOutput, uint dwMode);
public static uint GetConsoleMode(bool input = false)
{
var handle = GetStdHandle(input ? -10 : -11);
uint mode;
if (GetConsoleMode(handle, out mode))
{
return mode;
}
return 0xffffffff;
}
public static uint SetConsoleMode(bool input, uint mode)
{
var handle = GetStdHandle(input ? -10 : -11);
if (SetConsoleMode(handle, mode))
{
return GetConsoleMode(input);
}
return 0xffffffff;
}
}
"@
;
[Flags()]
enum ConsoleModeInputFlags
{
ENABLE_LINE_INPUT = 0x0002
ENABLE_ECHO_INPUT = 0x0004
};
if (!('NativeConsoleMethods' -as [System.Type])) {
Add-Type $consoleModeSource
}
function psmain {
param (
[validateSet('enableRaw', 'disableRaw')]
[string]$Action
);
# $inputflags = Get-ConsoleMode -StandardInput;
if (!('NativeConsoleMethods' -as [System.Type])) {
Add-Type $consoleModeSource
}
$inputFlags = [NativeConsoleMethods]::GetConsoleMode($true);
$resultflags = $inputflags;
if (($inputflags -band [ConsoleModeInputFlags]::ENABLE_LINE_INPUT) -eq [ConsoleModeInputFlags]::ENABLE_LINE_INPUT) {
#cooked mode
$initialstate = "cooked";
if ($action -eq "enableraw") {
#disable cooked flags
$disable = [uint32](-bnot [uint32][ConsoleModeInputFlags]::ENABLE_LINE_INPUT) -band ( -bnot [uint32][ConsoleModeInputFlags]::ENABLE_ECHO_INPUT);
$adjustedflags = $inputflags -band ($disable);
$resultflags = [NativeConsoleMethods]::SetConsoleMode($true,$adjustedflags);
}
} else {
#raw mode
$initialstate = "raw";
if ($action -eq "disableraw") {
#set cooked flags
$adjustedflags = $inputflags -bor [ConsoleModeInputFlags]::ENABLE_LINE_INPUT -bor [ConsoleModeInputFlags]::ENABLE_ECHO_INPUT;
$resultflags = [NativeConsoleMethods]::SetConsoleMode($true,$adjustedflags);
}
}
#return in format that can act as a tcl dict
#write-host "startflags: $inputflags initialstate: $initialstate action: $Action endflags: $resultflags";
};
# psmain 'enableRaw'
;
$consoleid = $args[0];
if ([string]::IsNullOrEmpty($consoleid)) {
$consoleid= "<punkshell_consoleid>"
};
$pipeName = "punkshell_ps_consolemode_$consoleid";
"pipename: $pipeName"
# Create the NamedPipeServerStream
$pipeServer = New-Object System.IO.Pipes.NamedPipeServerStream(
$pipeName,
[System.IO.Pipes.PipeDirection]::In,
1,
[System.IO.Pipes.PipeTransmissionMode]::Message,
[System.IO.Pipes.PipeOptions]::Asynchronous
);
;
#$pipeServer = New-Object System.IO.Pipes.NamedPipeServerStream($pipeName);
;
# Create a synchronization object (ManualResetEvent) to signal completion
;
$syncEvent = New-Object System.Threading.ManualResetEvent($false)
# Define the callback function for BeginWaitForConnection
$connectionCallback = [System.AsyncCallback]{
param($ar,$s);
# Get the NamedPipeServerStream from the AsyncResult object
;
$server = $ar.AsyncState;
# End the asynchronous wait operation
;
$server.EndWaitForConnection($ar);
Write-Host "Client connected!";
# Create a new runspace to handle client communication
;
$runspace = [System.Management.Automation.Runspaces.RunspaceFactory]::CreateRunspace();
$runspace.Open();
# Create a PowerShell pipeline within the runspace
;
$powershell = [System.Management.Automation.PowerShell]::Create();
$powershell.Runspace = $runspace;
$scriptBlock = {
param($pipeStream);
$reader = New-Object System.IO.StreamReader($pipeStream);
#$writer = New-Object System.IO.StreamWriter($pipeStream);
#$writer.AutoFlush = $true;
$message = $reader.ReadLine();
Write-Host "Received from client: $message";
#$response = "Server received: $message"
#$writer.WriteLine($response)
#Write-Host "Sent to client: $response"
# Disconnect the pipe to allow new connections if desired
;
$pipeStream.Disconnect();
};
# Add the script block to the PowerShell pipeline and pass the pipe stream
;
$powershell.AddScript($scriptBlock).AddArgument($server);
# Invoke the pipeline asynchronously
;
$asyncResult = $powershell.BeginInvoke();
# You can do other work here while the client communication happens in the runspace
;
;
# Wait for the pipeline to complete and close the runspace
$powershell.EndInvoke($asyncResult);
$powershell.Dispose();
$runspace.Close();
$runspace.Dispose();
Write-Host "Client communication handled. Waiting for next connection...";
$s.Set();
# Begin waiting for the next connection;
#$server.BeginWaitForConnection($callback, $server);
;
}
$global:keep_listening = $true;
while ($global:keep_listening) {
# Begin waiting for a client connection asynchronously
;
$runspace = [System.Management.Automation.Runspaces.RunspaceFactory]::CreateRunspace();
$runspace.Open();
# Create a PowerShell pipeline within the runspace
;
$powershell = [System.Management.Automation.PowerShell]::Create();
$powershell.Runspace = $runspace;
$scriptblock = {
param($p,$s);
Write-Host "Waiting for client connection on pipe: $p";
$p.BeginWaitForConnection($connectionCallback, $p,$s);
$s.WaitOne(10000);
}
$powershell.AddScript($scriptBlock)
[void]$powershell.AddParameter('p',$pipeName);
[void]$powershell.AddParameter('s',$syncEvent);
$asyncResult = $powershell.BeginInvoke();
# You can do other work here while the client communication happens in the runspace
;
write-host "interim"
;
# Wait for the pipeline to complete and close the runspace
$powershell.EndInvoke($asyncResult);
$powershell.Dispose();
$runspace.Close();
$runspace.Dispose();
write-host "looping"
};
#$pipeServer.BeginWaitForConnection($connectionCallback, $pipeServer);
Write-Host "Server shutting down.";
$pipeServer.Dispose();
#try {
# while ($true) {
# #"Waiting for connection on '$pipeName'";
# $pipeServer.WaitForConnection();
# #"Connection established";
# $pipeReader = New-Object System.IO.StreamReader($pipeServer);
# #$pipeWriter = New-Object System.IO.StreamWriter($pipeServer);
# #$pipeWriter.AutoFlush = $true;
# $request = $pipeReader.ReadLine();
# # "Received request: $request";
# if ($request -eq "exit") {
# "consolemode_server.ps1 Exiting";
# exit;
# } elseif ($request -eq "") {
# #"Empty input";
# $pipeServer.Disconnect();
# #"Disconnected";
# continue;
# } elseif ($request -eq $none) {
# "Remote disconnected before sending";
# $pipeServer.Disconnect();
# "Disconnected";
# continue;
# } elseif ($request -eq "enableraw") {
# #$result = psmain 'enableRaw';
# $null = psmain 'enableRaw'
# # "Sending result: '$result'";
# #$pipeWriter.Write($result);
# $pipeServer.Disconnect();
# continue;
# } else {
# "consolemode_server.ps1 ignoring request: $request";
# $pipeServer.Disconnect();
# continue;
# }
# }
#}
#finally {
# $pipeServer.Dispose();
#};

1
scriptlib/utils/pwsh/echotest.ps1
Unescape View File

@ -0,0 +1 @@
write-host "test"

5
src/bootsupport/modules/punk/args-0.2.tm
Unescape View File

@ -3036,8 +3036,11 @@ tcl::namespace::eval punk::args {
#This mechanism gets less-than-useful results for oo methods
#e.g {$obj}
proc Get_caller {} {
set depth [info level]
set maxd [expr {min($depth,4)}]
set call_level [expr {-1 * $maxd}]
#set call_level -3 ;#for get_dict call
set call_level -4
#set call_level -4
set cmdinfo [tcl::dict::get [tcl::info::frame $call_level] cmd]
#puts "-->$cmdinfo"
#puts "-->[tcl::info::frame -3]"

2
src/bootsupport/modules/punk/args/tclcore-0.1.0.tm
Unescape View File

@ -3498,7 +3498,7 @@ tcl::namespace::eval punk::args::tclcore {
example, in ${$B}-dictionary${$N} mode, bigBoy sorts between bigbang and bigboy,
and x10y sorts between x9y and x11y. Overrides the ${$B}-nocase${$N} option."
-integer -type none -help\
"Convert list elements to integers and use integer comparsion."
"Convert list elements to integers and use integer comparison."
-real -type none -help\
"Convert list elements to floating-point values and use floating comparison."
-command -type string -help\

556
src/bootsupport/modules/punk/console-0.1.1.tm
Unescape View File

@ -132,216 +132,22 @@ namespace eval punk::console {
if {"windows" eq $::tcl_platform(platform)} {
#accept args for all dummy/load functions so we don't have to match/update argument signatures here
set has_twapi [expr {! [catch {package require twapi}]}]
proc enableAnsi {args} {
#loopavoidancetoken (don't remove)
internal::define_windows_procs
internal::abort_if_loop
tailcall enableAnsi {*}$args
}
#review what raw mode means with regard to a specific channel vs terminal as a whole
proc enableRaw {args} {
#loopavoidancetoken (don't remove)
internal::define_windows_procs
internal::abort_if_loop
tailcall enableRaw {*}$args
}
proc disableRaw {args} {
#loopavoidancetoken (don't remove)
internal::define_windows_procs
internal::abort_if_loop
tailcall disableRaw {*}$args
}
proc enableVirtualTerminal {args} {
#loopavoidancetoken (don't remove)
internal::define_windows_procs
internal::abort_if_loop
tailcall enableVirtualTerminal {*}$args
}
proc disableVirtualTerminal {args} {
#loopavoidancetoken (don't remove)
internal::define_windows_procs
internal::abort_if_loop
tailcall disableVirtualTerminal {*}$args
}
set funcs [list disableAnsi enableProcessedInput disableProcessedInput]
foreach f $funcs {
proc $f {args} [string map [list %f% $f] {
set mybody [info body %f%]
internal::define_windows_procs
set newbody [info body %f%]
if {$newbody ne $mybody} {
tailcall %f% {*}$args
} else {
#error vs noop?
puts stderr "Unable to set implementation for %f% - check twapi?"
}
}]
}
} else {
proc enableAnsi {} {
#todo?
}
proc disableAnsi {} {
}
#todo - something better - the 'channel' concept may not really apply on unix, as raw mode is set for input and output modes currently - only valid to set on a readable channel?
#on windows they can be set independently (but not with stty) - REVIEW
#NOTE - the is_raw is only being set in current interp - but the channel is shared.
#this is problematic with the repl thread being separate. - must be a tsv? REVIEW
proc enableRaw {{channel stdin}} {
#variable is_raw
variable previous_stty_state_$channel
set sttycmd [auto_execok stty]
if {[set previous_stty_state_$channel] eq ""} {
if {[catch {exec {*}$sttycmd -g <@$channel} previous_stty_state_$channel]} {
set previous_stty_state_$channel ""
}
}
exec {*}$sttycmd raw -echo <@$channel
tsv::set console is_raw 1
return [dict create previous [set previous_stty_state_$channel]]
}
proc disableRaw {{channel stdin}} {
#variable is_raw
variable previous_stty_state_$channel
set sttycmd [auto_execok stty]
if {[set previous_stty_state_$channel] ne ""} {
exec {*}$sttycmd [set previous_stty_state_$channel]
set previous_stty_state_$channel ""
tsv::set console is_raw 0
return restored
}
exec {*}$sttycmd -raw echo <@$channel
tsv::set console is_raw 0
return done
}
proc enableVirtualTerminal {{channels {input output}}} {
}
proc disableVirtualTerminal {args} {
}
}
#review - document and decide granularity required. should we enable/disable more than one at once?
proc enable_mouse {} {
puts -nonewline stdout \x1b\[?1000h
puts -nonewline stdout \x1b\[?1003h
puts -nonewline stdout \x1b\[?1015h
puts -nonewline stdout \x1b\[?1006h
flush stdout
}
proc disable_mouse {} {
puts -nonewline stdout \x1b\[?1000l
puts -nonewline stdout \x1b\[?1003l
puts -nonewline stdout \x1b\[?1015l
puts -nonewline stdout \x1b\[?1006l
flush stdout
}
proc enable_bracketed_paste {} {
puts -nonewline stdout \x1b\[?2004h
}
proc disable_bracketed_paste {} {
puts -nonewline stdout \x1b\[?2004l
}
proc start_application_mode {} {
#need loop to read events?
puts -nonewline stdout \x1b\[?1049h ;#alt screen
enable_mouse
#puts -nonewline stdout \x1b\[?25l ;#hide cursor
puts -nonewline stdout \x1b\[?1003h\n
enable_bracketed_paste
}
#todo stop_application_mode {} {}
proc mode {{raw_or_line query}} {
#variable is_raw
variable ansi_available
set raw_or_line [string tolower $raw_or_line]
if {$raw_or_line eq "query"} {
if {[tsv::get console is_raw]} {
return "raw"
} else {
return "line"
}
} elseif {$raw_or_line eq "raw"} {
if {[catch {
punk::console::enableRaw
} errM]} {
puts stderr "Warning punk::console::enableRaw failed - $errM"
}
if {[can_ansi]} {
punk::console::enableVirtualTerminal both
}
} elseif {$raw_or_line eq "line"} {
#review -order. disableRaw has memory from enableRaw.. but but for line mode we want vt disabled - so call it after disableRaw (?)
if {[catch {
punk::console::disableRaw
} errM]} {
puts stderr "Warning punk::console::disableRaw failed - $errM"
}
if {[can_ansi]} {
punk::console::disableVirtualTerminal input ;#default readline arrow behaviour etc
punk::console::enableVirtualTerminal output ;#display/use ansi codes
}
} else {
error "punk::console::mode expected 'raw' or 'line' or default value 'query'"
}
}
namespace eval internal {
proc abort_if_loop {{failmsg ""}} {
#puts "il1 [info level 1]"
#puts "thisproc: [lindex [info level 0] 0]"
set would_loop [uplevel 1 {expr {[string match *loopavoidancetoken* [info body [namespace tail [lindex [info level 0] 0]]]]}}]
#puts "would_loop: $would_loop"
if {$would_loop} {
set procname [uplevel 1 {namespace tail [lindex [info level 0] 0]}]
if {$failmsg eq ""} {
set errmsg "[namespace current] Failed to redefine procedure $procname"
} else {
set errmsg $failmsg
}
error $errmsg
}
}
proc define_windows_procs {} {
package require zzzload
set loadstate [zzzload::pkg_require twapi]
#loadstate could also be stuck on loading? - review - zzzload not very ripe
#Twapi can be relatively slow to load (on some systems) - can be 1s plus in some cases - and much longer if there are disk performance issues.
if {$loadstate ni [list failed]} {
#possibly still 'loading'
#review zzzload usage
#puts stdout "=========== console loading twapi ============="
set loadstate [zzzload::pkg_wait twapi] ;#can return 'failed' will return version if already loaded or loaded during wait
}
if {$loadstate ni [list failed]} {
package require twapi ;#should be fast once twapi dll loaded in zzzload thread
set ::punk::console::has_twapi 1
#todo - move some of these to the punk::console::local sub-namespace - as they use APIs rather than in-band ANSI to do their work.
#enableAnsi seems like it should be directly under punk::console .. but then it seems inconsistent if other local console-mode setting functions aren't.
#Find a compromise to organise things somewhat sensibly..
if {$has_twapi} {
#this is really enableAnsi *processing*
proc [namespace parent]::enableAnsi {} {
proc enableAnsi {} {
#output handle modes
#Enable virtual terminal processing (sometimes off in older windows terminals)
#ENABLE_PROCESSED_OUTPUT = 0x0001
#ENABLE_WRAP_AT_EOL_OUTPUT = 0x0002
#ENABLE_VIRTUAL_TERMINAL_PROCESSING = 0x0004
#DISABLE_NEWLINE_AUTO_RETURN = 0x0008
set h_out [twapi::get_console_handle stdout]
if {[catch {twapi::get_console_handle stdout} h_out]} {
puts stderr "enableAnsi failed: twapi cannot get console handle for stdout"
return
}
set oldmode_out [twapi::GetConsoleMode $h_out]
set newmode_out [expr {$oldmode_out | 4}] ;#don't enable processed output too, even though it's required. keep symmetrical with disableAnsi?
@ -366,7 +172,7 @@ namespace eval punk::console {
return [list stdout [list from $oldmode_out to $newmode_out] stdin [list from $oldmode_in to $newmode_in]]
}
proc [namespace parent]::disableAnsi {} {
proc disableAnsi {} {
set h_out [twapi::get_console_handle stdout]
set oldmode_out [twapi::GetConsoleMode $h_out]
set newmode_out [expr {$oldmode_out & ~4}]
@ -381,9 +187,7 @@ namespace eval punk::console {
return [list stdout [list from $oldmode_out to $newmode_out] stdin [list from $oldmode_in to $newmode_in]]
}
#
proc [namespace parent]::enableVirtualTerminal {{channels {input output}}} {
proc enableVirtualTerminal {{channels {input output}}} {
set ins [list in input stdin]
set outs [list out output stdout stderr]
set known [concat $ins $outs both]
@ -424,7 +228,8 @@ namespace eval punk::console {
return $result
}
proc [namespace parent]::disableVirtualTerminal {{channels {input output}}} {
proc disableVirtualTerminal {{channels {input output}}} {
set ins [list in input stdin]
set outs [list out output stdout stderr]
set known [concat $ins $outs both]
@ -465,65 +270,158 @@ namespace eval punk::console {
#return [list stdout [list from $oldmode_out to $newmode_out] stdin [list from $oldmode_in to $newmode_in]]
return $result
}
proc [namespace parent]::enableProcessedInput {} {
proc enableProcessedInput {} {
set h_in [twapi::get_console_handle stdin]
set oldmode_in [twapi::GetConsoleMode $h_in]
set newmode_in [expr {$oldmode_in | 1}]
twapi::SetConsoleMode $h_in $newmode_in
return [list stdin [list from $oldmode_in to $newmode_in]]
}
proc [namespace parent]::disableProcessedInput {} {
proc disableProcessedInput {} {
set h_in [twapi::get_console_handle stdin]
set oldmode_in [twapi::GetConsoleMode $h_in]
set newmode_in [expr {$oldmode_in & ~1}]
twapi::SetConsoleMode $h_in $newmode_in
return [list stdin [list from $oldmode_in to $newmode_in]]
}
proc enableRaw {{channel stdin}} {
#variable is_raw
variable previous_stty_state_$channel
if {[catch {twapi::get_console_handle stdin} console_handle]} {
puts stderr "enableRaw error: twapi cannot get console handle for stdin"
#review. If twapi couldn't get a console handle - no point trying other mechanisms(?)
return
}
#returns dictionary
#e.g -processedinput 1 -lineinput 1 -echoinput 1 -windowinput 0 -mouseinput 0 -insertmode 1 -quickeditmode 1 -extendedmode 1 -autoposition 0
set oldmode [twapi::get_console_input_mode]
twapi::modify_console_input_mode $console_handle -lineinput 0 -echoinput 0
# Turn off the echo and line-editing bits
#set newmode [dict merge $oldmode [dict create -lineinput 0 -echoinput 0]]
set newmode [twapi::get_console_input_mode]
tsv::set console is_raw 1
#don't disable handler - it will detect is_raw
### twapi::set_console_control_handler {}
return [list stdin [list from $oldmode to $newmode]]
}
} else {
#note: twapi GetStdHandle & GetConsoleMode & SetConsoleCombo unreliable - fails with invalid handle (somewhat intermittent.. after stdin reopened?)
#could be we were missing a step in reopening stdin and console configuration?
puts stderr "punk::console falling back to stty because twapi load failed"
proc [namespace parent]::enableAnsi {} {
puts stderr "punk::console::enableAnsi todo"
}
proc [namespace parent]::disableAnsi {} {
proc disableRaw {{channel stdin}} {
#variable is_raw
variable previous_stty_state_$channel
set ch_state [chan conf $channel]
if {[dict exists $ch_state -inputmode]} {
chan conf $channel -inputmode normal
tsv::set console is_raw 0
return [list $channel [list from [dict get $ch_state -inputmode] to normal]]
} else {
if {[catch {twapi::get_console_handle stdin} console_handle]} {
#e.g tkcon/wish
puts stderr "disableRaw error: twapi cannot get console handle for stdin"
return ;# ???
}
#?
proc [namespace parent]::enableVirtualTerminal {{channels {input output}}} {
set oldmode [twapi::get_console_input_mode]
# Turn on the echo and line-editing bits
twapi::modify_console_input_mode $console_handle -lineinput 1 -echoinput 1
set newmode [twapi::get_console_input_mode]
tsv::set console is_raw 0
return [list stdin [list from $oldmode to $newmode]]
}
proc [namespace parent]::disableVirtualTerminal {{channels {input output}}} {
}
proc [namespace parent]::enableProcessedInput {args} {
}
proc [namespace parent]::disableProcessedInput {args} {
} else {
variable ps_consolemode_pid
variable ps_consolemode_contents
variable ps_pipename
if {![info exists ps_consolemode_contents]} {
#start persistent powershell consolemode_server.ps1 named pipe server
if {$::argv0 ne ""} {
set pstooldir [file dirname [file dirname [file normalize $::argv0]]]/scriptlib/utils/pwsh
} else {
set pstooldir [pwd]
}
#set ps_script $pstooldir/consolemode_server.ps1
set ps_script $pstooldir/consolemode_server_async.ps1
if {[file exists $ps_script]} {
set fd [open $ps_script r]
chan configure $fd -translation binary
set ps_consoleid [pid]-[expr {int(999 * rand())+1}]
set ps_consolemode_contents [string map [list "<punkshell_consoleid>" $ps_consoleid] [read $fd]]
close $fd
#set ps_consolemode_pipe [twapi::namedpipe_client {//./pipe/punkshell_ps_consolemode} -access write]
#set ps_cmd [auto_execok pwsh.exe]
set ps_cmd [auto_execok pwsh.exe]
if {$ps_cmd eq ""} {
set ps_cmd [auto_execok powershell.exe]
}
if {$ps_cmd ne ""} {
set ps_consolemode_pid [exec {*}$ps_cmd -nop -nol -c $ps_consolemode_contents &]
set ps_pipename {\\.\pipe\punkshell_ps_consolemode_}
append ps_pipename $ps_consoleid
puts stderr "twapi not present, using persistent powershell process: pipename: $ps_pipename pid: $ps_consolemode_pid"
#todo - taskkill /F /PID $ps_consolemode_pid
#when?
#review
#if {[catch {puts "pidinfo: [::tcl::process::status $ps_consolemode_pid]"} errM]} {
# puts stderr "--- failed to get process status for $ps_consolemode_pid\n$errM"
#}
#set p [open {\\.\pipe\punkshell_ps_consolemode} w]
#chan conf $p -buffering none -blocking 1
#puts $p ""
#close $p
}
}
}
proc [namespace parent]::enableRaw {{channel stdin}} {
#enableRaw
proc enableRaw {{channel stdin}} {
#puts stderr "punk::console::enableRaw"
#variable is_raw
variable previous_stty_state_$channel
variable ps_consolemode_contents
variable ps_pipename
if {[package provide twapi] ne ""} {
set console_handle [twapi::get_console_handle stdin]
#returns dictionary
#e.g -processedinput 1 -lineinput 1 -echoinput 1 -windowinput 0 -mouseinput 0 -insertmode 1 -quickeditmode 1 -extendedmode 1 -autoposition 0
set oldmode [twapi::get_console_input_mode]
twapi::modify_console_input_mode $console_handle -lineinput 0 -echoinput 0
# Turn off the echo and line-editing bits
#set newmode [dict merge $oldmode [dict create -lineinput 0 -echoinput 0]]
set newmode [twapi::get_console_input_mode]
if {[info exists ps_consolemode_contents]} {
#ps_pipename e.g \\.\pipe\punkwinshell_ps_consolemode_12345-1223456
set trynum 0
set wrote 0
while {$trynum < 5} {
incr trynum
if {![catch {
set pipe [open $ps_pipename w]
} errMsg]} {
chan conf $pipe -buffering line
puts -nonewline $pipe "enableraw\r\n"
#flush $pipe
#after 10
#close $pipe
set wrote 1
break
} else {
after 100
}
}
if {$wrote} {
tsv::set console is_raw 1
#don't disable handler - it will detect is_raw
### twapi::set_console_control_handler {}
return [list stdin [list from $oldmode to $newmode]]
after 100
close $pipe
} else {
puts stderr "write to $ps_pipename failed trynum: $trynum\n$errMsg"
}
} elseif {[set sttycmd [auto_execok stty]] ne ""} {
#todo - something else entirely
#this approach does not work on windows
#the msys/cygwin stty command is launched as a subprocess - can be used to retrieve info
# but seems to be useless as far as affecting the calling process/console
if {[set previous_stty_state_$channel] eq ""} {
set previous_stty_state_$channel [exec {*}$sttycmd -g <@$channel]
}
@ -537,25 +435,19 @@ namespace eval punk::console {
}
}
#note: twapi GetStdHandle & GetConsoleMode & SetConsoleCombo unreliable - fails with invalid handle (somewhat intermittent.. after stdin reopened?)
#could be we were missing a step in reopening stdin and console configuration?
proc [namespace parent]::disableRaw {{channel stdin}} {
#variable is_raw
proc disableRaw {{channel stdin}} {
variable previous_stty_state_$channel
if {[package provide twapi] ne ""} {
set console_handle [twapi::get_console_handle stdin]
set oldmode [twapi::get_console_input_mode]
# Turn on the echo and line-editing bits
twapi::modify_console_input_mode $console_handle -lineinput 1 -echoinput 1
set newmode [twapi::get_console_input_mode]
set ch_state [chan conf $channel]
if {[dict exists $ch_state -inputmode]} {
chan conf $channel -inputmode normal
tsv::set console is_raw 0
return [list stdin [list from $oldmode to $newmode]]
} elseif {[set sttycmd [auto_execok stty]] ne ""} {
#stty can return info on windows - but doesn't seem to be able to set anything.
#review - is returned info even valid?
return [list $channel [list from [dict get $ch_state -inputmode] to normal]]
} else {
#tcl <= 8.6x doesn't support -inputmode
if {[set sttycmd [auto_execok stty]] ne ""} {
#this doesn't work on windows
#It may seem to - only because running *any* external utility can exit raw mode
set sttycmd [auto_execok stty]
if {[set previous_stty_state_$channel] ne ""} {
exec {*}$sttycmd [set previous_stty_state_$channel]
@ -571,6 +463,163 @@ namespace eval punk::console {
error "punk::console::disableRaw Unable to use twapi or stty to unset raw mode - aborting"
}
}
}
#enableAnsi
proc enableAnsi {} {
}
#disableAnsi
proc enableAnsi {} {
}
#enableVirtualTerminal
proc enableVirtualTerminal {{channels {input output}}} {
}
#disableVirtualTerminal
proc disableVirtualTerminal {{channels {input output}}} {
}
#enableProcessedInput
#disableProcessedInput
}
} else {
#non-windows platforms
proc enableAnsi {} {
#todo?
}
proc disableAnsi {} {
}
#todo - something better - the 'channel' concept may not really apply on unix, as raw mode is set for input and output modes currently - only valid to set on a readable channel?
#on windows they can be set independently (but not with stty) - REVIEW
proc enableVirtualTerminal {{channels {input output}}} {
}
proc disableVirtualTerminal {args} {
}
#NOTE - the is_raw is only being set in current interp - but the channel is shared.
#this is problematic with the repl thread being separate. - must be a tsv? REVIEW
proc enableRaw {{channel stdin}} {
#variable is_raw
variable previous_stty_state_$channel
set sttycmd [auto_execok stty]
if {[set previous_stty_state_$channel] eq ""} {
if {[catch {exec {*}$sttycmd -g <@$channel} previous_stty_state_$channel]} {
set previous_stty_state_$channel ""
}
}
exec {*}$sttycmd raw -echo <@$channel
tsv::set console is_raw 1
return [dict create previous [set previous_stty_state_$channel]]
}
proc disableRaw {{channel stdin}} {
#variable is_raw
variable previous_stty_state_$channel
set sttycmd [auto_execok stty]
if {[set previous_stty_state_$channel] ne ""} {
exec {*}$sttycmd [set previous_stty_state_$channel]
set previous_stty_state_$channel ""
tsv::set console is_raw 0
return restored
}
exec {*}$sttycmd -raw echo <@$channel
tsv::set console is_raw 0
return done
}
}
#review - document and decide granularity required. should we enable/disable more than one at once?
proc enable_mouse {} {
puts -nonewline stdout \x1b\[?1000h
puts -nonewline stdout \x1b\[?1003h
puts -nonewline stdout \x1b\[?1015h
puts -nonewline stdout \x1b\[?1006h
flush stdout
}
proc disable_mouse {} {
puts -nonewline stdout \x1b\[?1000l
puts -nonewline stdout \x1b\[?1003l
puts -nonewline stdout \x1b\[?1015l
puts -nonewline stdout \x1b\[?1006l
flush stdout
}
proc enable_bracketed_paste {} {
puts -nonewline stdout \x1b\[?2004h
}
proc disable_bracketed_paste {} {
puts -nonewline stdout \x1b\[?2004l
}
proc start_application_mode {} {
#need loop to read events?
puts -nonewline stdout \x1b\[?1049h ;#alt screen
enable_mouse
#puts -nonewline stdout \x1b\[?25l ;#hide cursor
puts -nonewline stdout \x1b\[?1003h\n
enable_bracketed_paste
}
#todo stop_application_mode {} {}
proc mode {{raw_or_line query}} {
#variable is_raw
variable ansi_available
set raw_or_line [string tolower $raw_or_line]
if {$raw_or_line eq "query"} {
if {[tsv::get console is_raw]} {
return "raw"
} else {
return "line"
}
} elseif {$raw_or_line eq "raw"} {
if {[catch {
punk::console::enableRaw
} errM]} {
puts stderr "Warning punk::console::enableRaw failed - $errM"
}
if {[can_ansi]} {
punk::console::enableVirtualTerminal both
}
} elseif {$raw_or_line eq "line"} {
#review -order. disableRaw has memory from enableRaw.. but but for line mode we want vt disabled - so call it after disableRaw (?)
if {[catch {
punk::console::disableRaw
} errM]} {
puts stderr "Warning punk::console::disableRaw failed - $errM"
}
if {[can_ansi]} {
punk::console::disableVirtualTerminal input ;#default readline arrow behaviour etc
punk::console::enableVirtualTerminal output ;#display/use ansi codes
}
} else {
error "punk::console::mode expected 'raw' or 'line' or default value 'query'"
}
}
namespace eval internal {
proc abort_if_loop {{failmsg ""}} {
#puts "il1 [info level 1]"
#puts "thisproc: [lindex [info level 0] 0]"
set would_loop [uplevel 1 {expr {[string match *loopavoidancetoken* [info body [namespace tail [lindex [info level 0] 0]]]]}}]
#puts "would_loop: $would_loop"
if {$would_loop} {
set procname [uplevel 1 {namespace tail [lindex [info level 0] 0]}]
if {$failmsg eq ""} {
set errmsg "[namespace current] Failed to redefine procedure $procname"
} else {
set errmsg $failmsg
}
error $errmsg
}
}
proc define_windows_procs {} {
}
@ -1803,7 +1852,10 @@ namespace eval punk::console {
#don't set ansi_avaliable here - we want to be able to change things, retest etc.
if {"windows" eq "$::tcl_platform(platform)"} {
if {[package provide twapi] ne ""} {
set h_out [twapi::get_console_handle stdout]
if {[catch {twapi::get_console_handle stdout} h_out]} {
puts stderr "test_can_ansi: twapi cannot get console handle for stdout"
return 0
}
set existing_mode [twapi::GetConsoleMode $h_out]
if {[expr {$existing_mode & 4}]} {
#virtual terminal processing happens to be enabled - so it's supported

58
src/bootsupport/modules/punk/libunknown-0.1.tm
Unescape View File

@ -80,16 +80,7 @@ tcl::namespace::eval punk::libunknown {
"Experimental set of replacements for default 'package unknown' entries."
}]
variable epoch
#if {![info exists epoch]} {
# set tmstate [dict create 0 {}]
# set pkgstate [dict create 0 {}]
# set tminfo [dict create current 0 epochs $tmstate]
# set pkginfo [dict create current 0 epochs $pkgstate]
# set epoch [dict create tm $tminfo pkg $pkginfo]
#}
variable epoch ;#don't set - can be pre-set cooperatively
variable has_package_files
if {[catch {package files foobaz}]} {
@ -111,6 +102,33 @@ tcl::namespace::eval punk::libunknown {
#will use standard mechanism for non zipfs paths in the tm list.
proc zipfs_tm_UnknownHandler {original name args} {
#------------------------------
#shortcircuit for builtin static libraries which have no 'package provide' info - review
#This occurs for example when running 'bin\runtime.cmd run src\make.tcl shell' with punk902z.exe
#
#------------------------------
set loaded [lsearch -inline -index 1 -nocase [info loaded] $name]
if {[llength $loaded] == 2 && [lindex $loaded 0] eq ""} {
lassign $loaded _ cased_name
interp create ptest
ptest eval [list load {} $cased_name]
set static_version [ptest eval [list package provide [string tolower $cased_name]]]
set pname [string tolower $cased_name]
if {$static_version eq ""} {
set static_version [ptest eval [list package provide $cased_name]]
set pname $cased_name
}
if {$static_version ne ""} {
if {[package vsatisfies $static_version {*}$args]} {
package ifneeded $pname $static_version [list load {} $cased_name]
interp delete ptest
return
}
}
interp delete ptest
}
#------------------------------
# Import the list of paths to search for packages in module form.
# Import the pattern used to check package names in detail.
variable epoch
@ -1161,7 +1179,12 @@ tcl::namespace::eval punk::libunknown {
set callerposn [lsearch $args -caller]
if {$callerposn > -1} {
set caller [lindex $args $callerposn+1]
#puts stderr "\x1b\[1\;33m punk::libunknown::init - caller:$caller\x1b\[m"
if {[package provide thread] ne ""} {
set tid [thread::id]
} else {
set tid "-"
}
#puts stderr "\x1b\[1\;33m punk::libunknown::init - caller:$caller tid:$tid\x1b\[m"
#puts stderr "punk::libunknown::init auto_path : $::auto_path"
#puts stderr "punk::libunknown::init tcl::tm::list: [tcl::tm::list]"
}
@ -1184,17 +1207,17 @@ tcl::namespace::eval punk::libunknown {
puts stderr "punk::libunknown::init - init while empty/unreadable tcl::tm::list and empty/unreadable ::auto_path"
}
if {[namespace origin ::package] eq "::punk::libunknown::package"} {
#This is far from conclusive - there may be other renamers (e.g commandstack)
if {[info commands ::punk::libunknown::package] ne ""} {
puts stderr "punk::libunknown::init already done - unnecessary call? info frame -1: [info frame -1]"
return
}
#if {[namespace origin ::package] eq "::punk::libunknown::package"} {
# #This is far from conclusive - there may be other renamers (e.g commandstack)
# return
#}
if {[info commands ::punk::libunknown::package] ne ""} {
puts stderr "punk::libunknown::init already done - unnecessary call? info frame -1: [info frame -1]"
return
}
variable epoch
if {![info exists epoch]} {
set tmstate [dict create 0 {added {}}]
@ -1222,6 +1245,7 @@ tcl::namespace::eval punk::libunknown {
# or suffer additional scans.. or document ??
#ideally init should be called in each interp before any scans for packages so that the list of untracked is minimized.
set pkgnames [package names]
#puts stderr "####### punk::libunknown init called with [llength $pkgnames] package names known"
foreach p $pkgnames {
if {[string tolower $p] in {punk::libunknown tcl::zlib tcloo tcl::oo tcl}} {
continue

64
src/bootsupport/modules/punk/repl-0.1.2.tm
Unescape View File

@ -20,18 +20,6 @@ if {[dict exists $stdin_info -mode]} {
#give up for now
set tcl_interactive 1
#if {[info commands ::tcl::zipfs::root] ne ""} {
# set zr [::tcl::zipfs::root]
# if {[file join $zr app modules] in [tcl::tm::list]} {
# #todo - better way to find latest version - without package require
# set lib [file join $zr app modules punk libunknown.tm]
# if {[file exists $lib]} {
# source $lib
# punk::libunknown::init
# #package unknown {punk::libunknown::zipfs_tm_UnknownHandler punk::libunknown::zipfs_tclPkgUnknown}
# }
# }
#}
#-------------------------------------------------------------------------------------
if {[package provide punk::libunknown] eq ""} {
#maintenance - also in src/vfs/_config/punk_main.tcl
@ -59,7 +47,7 @@ if {[package provide punk::libunknown] eq ""} {
}
if {$libunknown ne ""} {
source $libunknown
if {[catch {punk::libunknown::init -caller repl} errM]} {
if {[catch {punk::libunknown::init -caller triggered_by_repl_package_require} errM]} {
puts "error initialising punk::libunknown\n$errM"
}
}
@ -525,11 +513,11 @@ proc repl::start {inchan args} {
set donevalue [set [namespace current]::done]
if {[lindex $donevalue 0] eq "quit"} {
puts "-->repl::start end $inchan $args result:'$donevalue'"
puts stderr "--> returning [lindex $donevalue 1]"
#puts stderr "repl quit --> returning [lindex $donevalue 1]"
return [lindex $donevalue 1]
}
puts "-->repl::start end $inchan $args result:'$donevalue'"
puts stderr "__> returning 0"
#puts stderr "__> returning 0"
return 0
}
proc repl::post_operations {} {
@ -1408,7 +1396,6 @@ proc repl::repl_handler {inputchan prompt_config} {
if {[dict get $original_input_conf -inputmode] eq "raw"} {
#user or script has apparently put stdin into raw mode - update punk::console::is_raw to match
set rawmode 1
#set ::punk::console::is_raw 1
tsv::set console is_raw 1
} else {
#set ::punk::console::is_raw 0
@ -1420,9 +1407,6 @@ proc repl::repl_handler {inputchan prompt_config} {
#if it's been set to raw - assume it is deliberately done this way as the user could have alternatively called punk::mode raw or punk::console::enableVirtualTerminal
#by not doing this automatically - we assume the caller has a reason.
} else {
#JMN FIX!
#this returns 0 in rawmode on 8.6 after repl thread changes
#set rawmode [set ::punk::console::is_raw]
set rawmode [tsv::get console is_raw]
}
@ -1811,8 +1795,6 @@ proc repl::repl_process_data {inputchan chunktype chunk stdinlines prompt_config
set infoprompt [dict get $prompt_config infoprompt]
set debugprompt [dict get $prompt_config debugprompt]
#set rawmode [set ::punk::console::is_raw]
set rawmode [tsv::get console is_raw]
if {!$rawmode} {
#puts stderr "-->got [ansistring VIEW -lf 1 $stdinlines]<--"
@ -2615,6 +2597,34 @@ proc repl::repl_process_data {inputchan chunktype chunk stdinlines prompt_config
}
#editbuf
#after any external command - raw mode as the console sees it can be disabled
#set it to match current state of the tsv
if {[tsv::get console is_raw]} {
if {$::tcl_platform(platform) eq "windows"} {
#review
#we are in parent process - twapi might not be loaded here - even if it is in the code interp
catch {package require twapi}
}
set sinfo [chan configure stdin]
if {[dict exists $sinfo -inputmode]} {
if {[dict get $sinfo -inputmode] ne "raw"} {
set re_enable_required 1
} else {
set re_enable_required 0
}
} else {
# -inputmode unavailable
#tcl 8.6 doesn't have -inputmode - meaning it has to call punk:console::enableRaw each time
#enableRaw on windows without twapi involves launching a pwsh process - which gives a noticeable lag in keyboard input.
#enableRaw on Unix involves a call to stty - which is generally fast - but still to be avoided if not required.
set re_enable_required 1
}
#puts stderr "-here- re-enabling raw"
if {$re_enable_required} {
punk::console::enableRaw
}
}
} else {
#append commandstr \n
if {$::punk::repl::signal_control_c} {
@ -2828,7 +2838,7 @@ namespace eval repl {
}
if {$libunknown ne ""} {
source $libunknown
if {[catch {punk::libunknown::init -caller "repl init_script"} errM]} {
if {[catch {punk::libunknown::init -caller "repl::init init_script parent interp"} errM]} {
puts "repl::init problem - error initialising punk::libunknown\n$errM"
}
#package require punk::lib
@ -2858,10 +2868,10 @@ namespace eval repl {
#thread::send to caller defined interp targets (reference?)
#snit required for icomm
if {[catch {package require snit} errM]} {
puts stdout "punk::repl::initscript lib load fail ---snit $errM"
#puts stdout "punk::repl::initscript: lib load fail ---snit $errM"
}
if {[catch {package require punk::icomm} errM]} {
puts stdout "punk::repl::initscript lib load fail ---icomm $errM"
#puts stdout "punk::repl::initscript: lib load fail ---icomm $errM"
}
#-----
@ -2872,7 +2882,7 @@ namespace eval repl {
#first use can raise error being a version number e.g 0.1.0 - why?
lassign [tcl::chan::fifo2] ::punk::repl::codethread::repltalk replside
} errMsg]} {
puts stdout "punk::repl::initscript tcl::chan::fifo2 error: $errM"
puts stdout "punk::repl::initscript tcl::chan::fifo2 error: $errMsg"
} else {
#experimental?
#puts stdout "transferring chan $replside to thread %replthread%"
@ -3519,6 +3529,8 @@ namespace eval repl {
#-----------------------------------------------------------------------------
if {[package provide punk::libunknown] eq ""} {
namespace eval ::punk::libunknown {}
set ::punk::libunknown::epoch %lib_epoch%
set libunks [list]
foreach tm_path [tcl::tm::list] {
set punkdir [file join $tm_path punk]
@ -3543,7 +3555,7 @@ namespace eval repl {
}
if {$libunknown ne ""} {
source $libunknown
if {[catch {punk::libunknown::init -caller "repl init_script punk"} errM]} {
if {[catch {punk::libunknown::init -caller "repl::init init_script code interp for punk"} errM]} {
puts "error initialising punk::libunknown\n$errM"
}
}

BIN
src/bootsupport/modules_tcl8/Thread-2.8.9.tm
View File

Binary file not shown.

3
src/bootsupport/modules_tcl8/include_modules.config
Unescape View File

@ -4,9 +4,6 @@
#each entry - base module
set bootsupport_modules [list\
modules_tcl8 thread\
modules_tcl8 thread::platform::win32_x86_64_tcl8\
]
# modules_tcl8/thread/platform *\

BIN
src/bootsupport/modules_tcl8/thread/platform/win32_x86_64_tcl8-2.8.9.tm
View File

Binary file not shown.

BIN
src/bootsupport/modules_tcl8/win32_x86_64_tcl8-2.8.9.tm
View File

Binary file not shown.

14
src/lib/app-punk/repl.tcl
Unescape View File

@ -49,16 +49,20 @@ repl::init -safe 0
#flush stderr
set replresult [repl::start stdin -title app-punk]
catch {
puts "app-punk ifneeded: [package ifneeded app-punk 1.0]"
}
#catch {
# puts "app-punk ifneeded: [package ifneeded app-punk 1.0]"
#}
#review
if {[string is integer -strict $replresult]} {
puts stdout "repl.tcl exiting with numeric code $replresult"
#puts stdout "repl.tcl exiting with numeric code $replresult"
exit $replresult
} else {
puts stdout "repl.tcl result $replresult"
if {$replresult ne ""} {
#puts stdout "repl.tcl result $replresult"
puts stdout $replresult
flush stdout
}
exit 0
}
#puts "- repl app done -"

1
src/lib/app-punkshell/punkshell.tcl
Unescape View File

@ -1,6 +1,7 @@
package provide app-punkshell 1.0
package require Thread
package require punk::lib ;#required for compat - lpop for some early Tcl 8.6 versions
package require punk::args
package require shellfilter
package require punk::ansi

157
src/make.tcl
Unescape View File

@ -31,22 +31,28 @@ namespace eval ::punkboot::lib {
#for some purposes (whether a source folder is likely to have any useful content) we are interested in non dotfile/dotfolder immediate contents of a folder, but not whether a particular platform
#considers them hidden or not.
proc folder_nondotted_children {folder} {
if {![file isdirectory $folder]} {error "punkboot::lib::folder_nondotted_children error. Supplied folder '$folder' is not a directory"}
set contents [glob -nocomplain -dir $folder *]
set normfolder [file normalize $folder]
if {![file isdirectory $normfolder]} {error "punkboot::lib::folder_nondotted_children error. Supplied folder '$folder' is not a directory"}
set contents [glob -nocomplain -dir $folder -tails *]
#some platforms (windows) return dotted entries with *, although most don't
return [lsearch -all -inline -not $contents .*]
set nondotted_tails [lsearch -all -inline -not $contents .*]
return [lmap ftail $nondotted_tails {file join $folder $ftail}]
}
proc folder_nondotted_folders {folder} {
if {![file isdirectory $folder]} {error "punkboot::lib::folder_nondotted_folders error. Supplied folder '$folder' is not a directory"}
set contents [glob -nocomplain -dir $folder -types d *]
set normfolder [file normalize $folder]
if {![file isdirectory $normfolder]} {error "punkboot::lib::folder_nondotted_folders error. Supplied folder '$folder' is not a directory"}
set contents [glob -nocomplain -dir $folder -types d -tails *]
#some platforms (windows) return dotted entries with *, although most don't
return [lsearch -all -inline -not $contents .*]
set nondotted_tails [lsearch -all -inline -not $contents .*]
return [lmap ftail $nondotted_tails {file join $folder $ftail}]
}
proc folder_nondotted_files {folder} {
if {![file isdirectory $folder]} {error "punkboot::lib::folder_nondotted_files error. Supplied folder '$folder' is not a directory"}
set contents [glob -nocomplain -dir $folder -types f $folder *]
set normfolder [file normalize $folder]
if {![file isdirectory $normfolder]} {error "punkboot::lib::folder_nondotted_files error. Supplied folder '$folder' is not a directory"}
set contents [glob -nocomplain -dir $folder -types f $folder -tails *]
#some platforms (windows) return dotted entries with *, although most don't
return [lsearch -all -inline -not $contents .*]
set nondotted_tails [lsearch -all -inline -not $contents .*]
return [lmap ftail $nondotted_tails {file join $folder $ftail}]
}
proc tm_version_isvalid {versionpart} {
#Needs to be suitable for use with Tcl's 'package vcompare'
@ -289,6 +295,10 @@ if {"::try" ni [info commands ::try]} {
# This allows a source update via 'fossil update' 'git pull' etc to pull in a minimal set of support modules for the boot script
# and load these in preference to ones that may have been in the interp's tcl::tm::list or auto_path due to environment variables
set startdir [pwd]
set scriptdir [file dirname [file normalize [info script]]]
#puts "SCRIPTDIR: $scriptdir"
#we are focussed on pure-tcl libs/modules in bootsupport for now.
#There may be cases where we want to use compiled packages from src/bootsupport/modules_tcl9 etc
#REVIEW - punkboot can really speed up with appropriate accelerators and/or external binaries
@ -303,18 +313,22 @@ set bootsupport_library_paths [list]
set this_platform_generic [punkboot::lib::platform_generic]
#we always create these lists in order of desired precedence.
# - this is the same order when adding to auto_path - but will need to be reversed when using tcl:tm::add
if {[file exists [file join $startdir src bootsupport]]} {
lappend bootsupport_module_paths [file join $startdir src bootsupport modules_tcl$::tclmajorv] ;#more version-specific modules slightly higher in precedence order
lappend bootsupport_module_paths [file join $startdir src bootsupport modules]
lappend bootsupport_library_paths [file join $startdir src bootsupport lib_tcl$::tclmajorv/allplatforms] ;#more version-specific pkgs slightly higher in precedence order
lappend bootsupport_library_paths [file join $startdir src bootsupport lib_tcl$::tclmajorv/$this_platform_generic] ;#more version-specific pkgs slightly higher in precedence order
lappend bootsupport_library_paths [file join $startdir src bootsupport lib]
if {[file exists [file join $scriptdir bootsupport]]} {
set bootsupportdir [file join $scriptdir bootsupport]
puts stderr "Using bootsupport dir $bootsupportdir"
lappend bootsupport_module_paths [file join $bootsupportdir modules_tcl$::tclmajorv] ;#more version-specific modules slightly higher in precedence order
lappend bootsupport_module_paths [file join $bootsupportdir modules]
lappend bootsupport_library_paths [file join $bootsupportdir lib_tcl$::tclmajorv/allplatforms] ;#more version-specific pkgs slightly higher in precedence order
lappend bootsupport_library_paths [file join $bootsupportdir lib_tcl$::tclmajorv/$this_platform_generic] ;#more version-specific pkgs slightly higher in precedence order
lappend bootsupport_library_paths [file join $bootsupportdir lib]
} else {
lappend bootsupport_module_paths [file join $startdir bootsupport modules_tcl$::tclmajorv]
lappend bootsupport_module_paths [file join $startdir bootsupport modules]
lappend bootsupport_library_paths [file join $startdir bootsupport lib_tcl$::tclmajorv/allplatforms]
lappend bootsupport_library_paths [file join $startdir bootsupport lib_tcl$::tclmajorv/$this_platform_generic]
lappend bootsupport_library_paths [file join $startdir bootsupport lib]
puts stderr "No bootsupport dir for script [info script] at [file join $scriptdir bootsupport]"
#lappend bootsupport_module_paths [file join $startdir bootsupport modules_tcl$::tclmajorv]
#lappend bootsupport_module_paths [file join $startdir bootsupport modules]
#lappend bootsupport_library_paths [file join $startdir bootsupport lib_tcl$::tclmajorv/allplatforms]
#lappend bootsupport_library_paths [file join $startdir bootsupport lib_tcl$::tclmajorv/$this_platform_generic]
#lappend bootsupport_library_paths [file join $startdir bootsupport lib]
}
set bootsupport_paths_exist 0
foreach p [list {*}$bootsupport_module_paths {*}$bootsupport_library_paths] {
@ -406,8 +420,8 @@ if {$bootsupport_paths_exist || $sourcesupport_paths_exist} {
tcl::tm::add {*}[lreverse $bootsupport_module_paths] {*}[lreverse $sourcesupport_module_paths] ;#tm::add works like LIFO. sourcesupport_module_paths end up earliest in resulting tm list.
set ::auto_path [list {*}$sourcesupport_library_paths {*}$bootsupport_library_paths]
}
puts "----> auto_path $::auto_path"
puts "----> tcl::tm::list [tcl::tm::list]"
#puts "----> auto_path $::auto_path"
#puts "----> tcl::tm::list [tcl::tm::list]"
#maint: also in punk::repl package
#--------------------------------------------------------
@ -435,22 +449,26 @@ if {$bootsupport_paths_exist || $sourcesupport_paths_exist} {
}
if {$libunknown ne ""} {
source $libunknown
if {[catch {punk::libunknown::init -caller main.tcl} errM]} {
puts "error initialising punk::libunknown\n$errM"
if {[catch {punk::libunknown::init -caller make.tcl} errM]} {
puts stderr "error initialising punk::libunknown\n$errM"
}
#puts stdout " *** [package names]"
#puts stdout " **** [dict get $::punk::libunknown::epoch pkg untracked]"
} else {
puts stderr "Failed to find punk::libunknown"
}
#--------------------------------------------------------
#package require Thread
puts "---->tcl_library [info library]"
puts "---->loaded [info loaded]"
#puts "---->tcl_library [info library]"
#puts "---->loaded [info loaded]"
# - the full repl requires Threading and punk,shellfilter,shellrun to call and display properly.
# tm list already indexed - need 'package forget' to find modules based on current tcl::tm::list
#These are strong dependencies
package forget punk::mix
package forget punk::repo
package forget punkcheck
#package forget punk::mix
#package forget punk::repo
#package forget punkcheck
package require punk::repo ;#todo - push our requirements to a smaller punk::repo::xxx package with minimal dependencies
package require punk::mix
@ -464,6 +482,7 @@ if {$bootsupport_paths_exist || $sourcesupport_paths_exist} {
set package_paths_modified 1
#------------------------------------------------------------------------------
#puts "----> llength package names [llength [package names]]"
}
set ::punkboot::pkg_requirements_found [list]
@ -479,7 +498,9 @@ set ::punkboot::bootsupport_requirements [dict create\
punkcheck [list]\
fauxlink [list version "0.1.1-"]\
textblock [list version 0.1.1-]\
fileutil [list]\
fileutil::traverse [list]\
struct::list [list]\
md5 [list version 2-]\
]
@ -1282,7 +1303,41 @@ proc ::punkboot::punkboot_gethelp {args} {
return $h
}
set scriptargs $::argv
punk::args::define {
@id -id punkmake
@cmd -name punkmake\
-summary\
"Project builder"\
-help\
""
@form -form help
@leaders
subcommand -type "literal(help)"
@opts
@values
what -type string -choices {modules libs shell}
@form -form modules
subcommand -type "literal(modules)"
@form -form libs
subcommand -type "literal(libs)"
@form -form shell
subcommand -type "literal(shell)"
arg -type any -optional 1 -multiple 1
}
#set argd [punk::args::parse $scriptargs -form 0 withid punkmake]
##lassign [dict values $argd] leaders opts values received
#
#puts stdout [punk::args::usage -scheme nocolour punkmake]
#exit 1
set do_help 0
if {![llength $scriptargs]} {
set do_help 1
@ -1294,6 +1349,8 @@ if {![llength $scriptargs]} {
}
}
}
set commands_found [list]
foreach a $scriptargs {
if {![string match -* $a]} {
@ -1310,6 +1367,8 @@ if {[llength $commands_found] != 1 } {
puts stderr "Unknown command: [lindex $commands_found 0]\n\n"
set do_help 1
}
if {$do_help} {
puts stdout "Checking package availability..."
set ::punkboot::pkg_availability [::punkboot::check_package_availability -quiet 1 $::punkboot::bootsupport_requirements]
@ -1325,6 +1384,8 @@ if {$do_help} {
exit 0
}
set ::punkboot::command [lindex $commands_found 0]
@ -1414,14 +1475,15 @@ if {$::punkboot::command eq "check"} {
if {$package_paths_modified} {
set tm_list_boot [tcl::tm::list]
tcl::tm::remove {*}$tm_list_boot
foreach p [lreverse $original_tm_list] {
set lower_prio [list]
foreach p $original_tm_list {
if {$p ni $tm_list_boot} {
tcl::tm::add $p
}
lappend lower_prio $p
}
foreach p [lreverse $tm_list_boot] {
tcl::tm::add $p
}
tcl::tm::add {*}[lreverse $lower_prio] {*}[lreverse $tm_list_boot]
#set ::auto_path [list $bootsupport_lib {*}$original_auto_path]
lappend ::auto_path {*}$original_auto_path
}
@ -1489,6 +1551,28 @@ if {![array size A]} {
punkboot::define_global_ansi
}
#puts stderr ">>>>>>+ loaded:[info loaded]"
#puts stderr "llength package names: [llength [package names]]"
if {[info exists ::punk::libunknown::epoch]} {
set untracked [dict get $::punk::libunknown::epoch pkg untracked]
#puts stderr "punk::libunknown::epoch exists"
} else {
set untracked [list]
#puts stderr "punk::libunknown::epoch does not exist"
}
#REVIEW - we shouldn't need to manually set the untracked packages - punk::libunknown::init should have done it?
foreach p [package names] {
if {![dict exists $untracked $p]} {
dict set untracked $p ""
}
}
dict set ::punk::libunknown::epoch pkg untracked $untracked
if {[package provide punk::libunknown] eq ""} {
puts "punk::libunknown not loaded"
} else {
puts "punk::libunknown loaded"
}
dict for {pkg pkginfo} $::punkboot::bootsupport_requirements {
set verspec [dict get $pkginfo version] ;#version wanted specification always exists and is empty or normalised
if {[catch {package require $pkg {*}$verspec} errM]} {
@ -1557,14 +1641,13 @@ if {$::punkboot::command eq "info"} {
if {$::punkboot::command eq "shell"} {
puts stderr ">>>>>> loaded:[info loaded]"
package require struct::list
package require punk
package require punk::repl
#todo - make procs vars etc from this file available?
puts stderr "punk boot shell not implemented - dropping into ordinary punk shell."
repl::init
set replresult [repl::start stdin -title make.tcl]
#review
@ -3059,6 +3142,8 @@ foreach vfstail $vfs_tails {
exec {*}$::sdxpath unwrap [file rootname $building_runtime].tail ;#extracts to folder named [file rootname $building_runtime].vfs e.g build_tclkit9.0.2-win64-dyn.vfs
#file rename to existing target dir would copy folder into target dir
if {![file exists $targetvfs]} {
#delay
after 1000
file rename [file rootname $building_runtime].vfs $targetvfs
} else {
merge_over [file rootname $building_runtime].vfs $targetvfs

5
src/modules/punk/args-999999.0a1.0.tm
Unescape View File

@ -3036,8 +3036,11 @@ tcl::namespace::eval punk::args {
#This mechanism gets less-than-useful results for oo methods
#e.g {$obj}
proc Get_caller {} {
set depth [info level]
set maxd [expr {min($depth,4)}]
set call_level [expr {-1 * $maxd}]
#set call_level -3 ;#for get_dict call
set call_level -4
#set call_level -4
set cmdinfo [tcl::dict::get [tcl::info::frame $call_level] cmd]
#puts "-->$cmdinfo"
#puts "-->[tcl::info::frame -3]"

2
src/modules/punk/args/tclcore-999999.0a1.0.tm
Unescape View File

@ -3498,7 +3498,7 @@ tcl::namespace::eval punk::args::tclcore {
example, in ${$B}-dictionary${$N} mode, bigBoy sorts between bigbang and bigboy,
and x10y sorts between x9y and x11y. Overrides the ${$B}-nocase${$N} option."
-integer -type none -help\
"Convert list elements to integers and use integer comparsion."
"Convert list elements to integers and use integer comparison."
-real -type none -help\
"Convert list elements to floating-point values and use floating comparison."
-command -type string -help\

556
src/modules/punk/console-999999.0a1.0.tm
Unescape View File

@ -132,216 +132,22 @@ namespace eval punk::console {
if {"windows" eq $::tcl_platform(platform)} {
#accept args for all dummy/load functions so we don't have to match/update argument signatures here
set has_twapi [expr {! [catch {package require twapi}]}]
proc enableAnsi {args} {
#loopavoidancetoken (don't remove)
internal::define_windows_procs
internal::abort_if_loop
tailcall enableAnsi {*}$args
}
#review what raw mode means with regard to a specific channel vs terminal as a whole
proc enableRaw {args} {
#loopavoidancetoken (don't remove)
internal::define_windows_procs
internal::abort_if_loop
tailcall enableRaw {*}$args
}
proc disableRaw {args} {
#loopavoidancetoken (don't remove)
internal::define_windows_procs
internal::abort_if_loop
tailcall disableRaw {*}$args
}
proc enableVirtualTerminal {args} {
#loopavoidancetoken (don't remove)
internal::define_windows_procs
internal::abort_if_loop
tailcall enableVirtualTerminal {*}$args
}
proc disableVirtualTerminal {args} {
#loopavoidancetoken (don't remove)
internal::define_windows_procs
internal::abort_if_loop
tailcall disableVirtualTerminal {*}$args
}
set funcs [list disableAnsi enableProcessedInput disableProcessedInput]
foreach f $funcs {
proc $f {args} [string map [list %f% $f] {
set mybody [info body %f%]
internal::define_windows_procs
set newbody [info body %f%]
if {$newbody ne $mybody} {
tailcall %f% {*}$args
} else {
#error vs noop?
puts stderr "Unable to set implementation for %f% - check twapi?"
}
}]
}
} else {
proc enableAnsi {} {
#todo?
}
proc disableAnsi {} {
}
#todo - something better - the 'channel' concept may not really apply on unix, as raw mode is set for input and output modes currently - only valid to set on a readable channel?
#on windows they can be set independently (but not with stty) - REVIEW
#NOTE - the is_raw is only being set in current interp - but the channel is shared.
#this is problematic with the repl thread being separate. - must be a tsv? REVIEW
proc enableRaw {{channel stdin}} {
#variable is_raw
variable previous_stty_state_$channel
set sttycmd [auto_execok stty]
if {[set previous_stty_state_$channel] eq ""} {
if {[catch {exec {*}$sttycmd -g <@$channel} previous_stty_state_$channel]} {
set previous_stty_state_$channel ""
}
}
exec {*}$sttycmd raw -echo <@$channel
tsv::set console is_raw 1
return [dict create previous [set previous_stty_state_$channel]]
}
proc disableRaw {{channel stdin}} {
#variable is_raw
variable previous_stty_state_$channel
set sttycmd [auto_execok stty]
if {[set previous_stty_state_$channel] ne ""} {
exec {*}$sttycmd [set previous_stty_state_$channel]
set previous_stty_state_$channel ""
tsv::set console is_raw 0
return restored
}
exec {*}$sttycmd -raw echo <@$channel
tsv::set console is_raw 0
return done
}
proc enableVirtualTerminal {{channels {input output}}} {
}
proc disableVirtualTerminal {args} {
}
}
#review - document and decide granularity required. should we enable/disable more than one at once?
proc enable_mouse {} {
puts -nonewline stdout \x1b\[?1000h
puts -nonewline stdout \x1b\[?1003h
puts -nonewline stdout \x1b\[?1015h
puts -nonewline stdout \x1b\[?1006h
flush stdout
}
proc disable_mouse {} {
puts -nonewline stdout \x1b\[?1000l
puts -nonewline stdout \x1b\[?1003l
puts -nonewline stdout \x1b\[?1015l
puts -nonewline stdout \x1b\[?1006l
flush stdout
}
proc enable_bracketed_paste {} {
puts -nonewline stdout \x1b\[?2004h
}
proc disable_bracketed_paste {} {
puts -nonewline stdout \x1b\[?2004l
}
proc start_application_mode {} {
#need loop to read events?
puts -nonewline stdout \x1b\[?1049h ;#alt screen
enable_mouse
#puts -nonewline stdout \x1b\[?25l ;#hide cursor
puts -nonewline stdout \x1b\[?1003h\n
enable_bracketed_paste
}
#todo stop_application_mode {} {}
proc mode {{raw_or_line query}} {
#variable is_raw
variable ansi_available
set raw_or_line [string tolower $raw_or_line]
if {$raw_or_line eq "query"} {
if {[tsv::get console is_raw]} {
return "raw"
} else {
return "line"
}
} elseif {$raw_or_line eq "raw"} {
if {[catch {
punk::console::enableRaw
} errM]} {
puts stderr "Warning punk::console::enableRaw failed - $errM"
}
if {[can_ansi]} {
punk::console::enableVirtualTerminal both
}
} elseif {$raw_or_line eq "line"} {
#review -order. disableRaw has memory from enableRaw.. but but for line mode we want vt disabled - so call it after disableRaw (?)
if {[catch {
punk::console::disableRaw
} errM]} {
puts stderr "Warning punk::console::disableRaw failed - $errM"
}
if {[can_ansi]} {
punk::console::disableVirtualTerminal input ;#default readline arrow behaviour etc
punk::console::enableVirtualTerminal output ;#display/use ansi codes
}
} else {
error "punk::console::mode expected 'raw' or 'line' or default value 'query'"
}
}
namespace eval internal {
proc abort_if_loop {{failmsg ""}} {
#puts "il1 [info level 1]"
#puts "thisproc: [lindex [info level 0] 0]"
set would_loop [uplevel 1 {expr {[string match *loopavoidancetoken* [info body [namespace tail [lindex [info level 0] 0]]]]}}]
#puts "would_loop: $would_loop"
if {$would_loop} {
set procname [uplevel 1 {namespace tail [lindex [info level 0] 0]}]
if {$failmsg eq ""} {
set errmsg "[namespace current] Failed to redefine procedure $procname"
} else {
set errmsg $failmsg
}
error $errmsg
}
}
proc define_windows_procs {} {
package require zzzload
set loadstate [zzzload::pkg_require twapi]
#loadstate could also be stuck on loading? - review - zzzload not very ripe
#Twapi can be relatively slow to load (on some systems) - can be 1s plus in some cases - and much longer if there are disk performance issues.
if {$loadstate ni [list failed]} {
#possibly still 'loading'
#review zzzload usage
#puts stdout "=========== console loading twapi ============="
set loadstate [zzzload::pkg_wait twapi] ;#can return 'failed' will return version if already loaded or loaded during wait
}
if {$loadstate ni [list failed]} {
package require twapi ;#should be fast once twapi dll loaded in zzzload thread
set ::punk::console::has_twapi 1
#todo - move some of these to the punk::console::local sub-namespace - as they use APIs rather than in-band ANSI to do their work.
#enableAnsi seems like it should be directly under punk::console .. but then it seems inconsistent if other local console-mode setting functions aren't.
#Find a compromise to organise things somewhat sensibly..
if {$has_twapi} {
#this is really enableAnsi *processing*
proc [namespace parent]::enableAnsi {} {
proc enableAnsi {} {
#output handle modes
#Enable virtual terminal processing (sometimes off in older windows terminals)
#ENABLE_PROCESSED_OUTPUT = 0x0001
#ENABLE_WRAP_AT_EOL_OUTPUT = 0x0002
#ENABLE_VIRTUAL_TERMINAL_PROCESSING = 0x0004
#DISABLE_NEWLINE_AUTO_RETURN = 0x0008
set h_out [twapi::get_console_handle stdout]
if {[catch {twapi::get_console_handle stdout} h_out]} {
puts stderr "enableAnsi failed: twapi cannot get console handle for stdout"
return
}
set oldmode_out [twapi::GetConsoleMode $h_out]
set newmode_out [expr {$oldmode_out | 4}] ;#don't enable processed output too, even though it's required. keep symmetrical with disableAnsi?
@ -366,7 +172,7 @@ namespace eval punk::console {
return [list stdout [list from $oldmode_out to $newmode_out] stdin [list from $oldmode_in to $newmode_in]]
}
proc [namespace parent]::disableAnsi {} {
proc disableAnsi {} {
set h_out [twapi::get_console_handle stdout]
set oldmode_out [twapi::GetConsoleMode $h_out]
set newmode_out [expr {$oldmode_out & ~4}]
@ -381,9 +187,7 @@ namespace eval punk::console {
return [list stdout [list from $oldmode_out to $newmode_out] stdin [list from $oldmode_in to $newmode_in]]
}
#
proc [namespace parent]::enableVirtualTerminal {{channels {input output}}} {
proc enableVirtualTerminal {{channels {input output}}} {
set ins [list in input stdin]
set outs [list out output stdout stderr]
set known [concat $ins $outs both]
@ -424,7 +228,8 @@ namespace eval punk::console {
return $result
}
proc [namespace parent]::disableVirtualTerminal {{channels {input output}}} {
proc disableVirtualTerminal {{channels {input output}}} {
set ins [list in input stdin]
set outs [list out output stdout stderr]
set known [concat $ins $outs both]
@ -465,65 +270,158 @@ namespace eval punk::console {
#return [list stdout [list from $oldmode_out to $newmode_out] stdin [list from $oldmode_in to $newmode_in]]
return $result
}
proc [namespace parent]::enableProcessedInput {} {
proc enableProcessedInput {} {
set h_in [twapi::get_console_handle stdin]
set oldmode_in [twapi::GetConsoleMode $h_in]
set newmode_in [expr {$oldmode_in | 1}]
twapi::SetConsoleMode $h_in $newmode_in
return [list stdin [list from $oldmode_in to $newmode_in]]
}
proc [namespace parent]::disableProcessedInput {} {
proc disableProcessedInput {} {
set h_in [twapi::get_console_handle stdin]
set oldmode_in [twapi::GetConsoleMode $h_in]
set newmode_in [expr {$oldmode_in & ~1}]
twapi::SetConsoleMode $h_in $newmode_in
return [list stdin [list from $oldmode_in to $newmode_in]]
}
proc enableRaw {{channel stdin}} {
#variable is_raw
variable previous_stty_state_$channel
if {[catch {twapi::get_console_handle stdin} console_handle]} {
puts stderr "enableRaw error: twapi cannot get console handle for stdin"
#review. If twapi couldn't get a console handle - no point trying other mechanisms(?)
return
}
#returns dictionary
#e.g -processedinput 1 -lineinput 1 -echoinput 1 -windowinput 0 -mouseinput 0 -insertmode 1 -quickeditmode 1 -extendedmode 1 -autoposition 0
set oldmode [twapi::get_console_input_mode]
twapi::modify_console_input_mode $console_handle -lineinput 0 -echoinput 0
# Turn off the echo and line-editing bits
#set newmode [dict merge $oldmode [dict create -lineinput 0 -echoinput 0]]
set newmode [twapi::get_console_input_mode]
tsv::set console is_raw 1
#don't disable handler - it will detect is_raw
### twapi::set_console_control_handler {}
return [list stdin [list from $oldmode to $newmode]]
}
} else {
#note: twapi GetStdHandle & GetConsoleMode & SetConsoleCombo unreliable - fails with invalid handle (somewhat intermittent.. after stdin reopened?)
#could be we were missing a step in reopening stdin and console configuration?
puts stderr "punk::console falling back to stty because twapi load failed"
proc [namespace parent]::enableAnsi {} {
puts stderr "punk::console::enableAnsi todo"
}
proc [namespace parent]::disableAnsi {} {
proc disableRaw {{channel stdin}} {
#variable is_raw
variable previous_stty_state_$channel
set ch_state [chan conf $channel]
if {[dict exists $ch_state -inputmode]} {
chan conf $channel -inputmode normal
tsv::set console is_raw 0
return [list $channel [list from [dict get $ch_state -inputmode] to normal]]
} else {
if {[catch {twapi::get_console_handle stdin} console_handle]} {
#e.g tkcon/wish
puts stderr "disableRaw error: twapi cannot get console handle for stdin"
return ;# ???
}
#?
proc [namespace parent]::enableVirtualTerminal {{channels {input output}}} {
set oldmode [twapi::get_console_input_mode]
# Turn on the echo and line-editing bits
twapi::modify_console_input_mode $console_handle -lineinput 1 -echoinput 1
set newmode [twapi::get_console_input_mode]
tsv::set console is_raw 0
return [list stdin [list from $oldmode to $newmode]]
}
proc [namespace parent]::disableVirtualTerminal {{channels {input output}}} {
}
proc [namespace parent]::enableProcessedInput {args} {
}
proc [namespace parent]::disableProcessedInput {args} {
} else {
variable ps_consolemode_pid
variable ps_consolemode_contents
variable ps_pipename
if {![info exists ps_consolemode_contents]} {
#start persistent powershell consolemode_server.ps1 named pipe server
if {$::argv0 ne ""} {
set pstooldir [file dirname [file dirname [file normalize $::argv0]]]/scriptlib/utils/pwsh
} else {
set pstooldir [pwd]
}
#set ps_script $pstooldir/consolemode_server.ps1
set ps_script $pstooldir/consolemode_server_async.ps1
if {[file exists $ps_script]} {
set fd [open $ps_script r]
chan configure $fd -translation binary
set ps_consoleid [pid]-[expr {int(999 * rand())+1}]
set ps_consolemode_contents [string map [list "<punkshell_consoleid>" $ps_consoleid] [read $fd]]
close $fd
#set ps_consolemode_pipe [twapi::namedpipe_client {//./pipe/punkshell_ps_consolemode} -access write]
#set ps_cmd [auto_execok pwsh.exe]
set ps_cmd [auto_execok pwsh.exe]
if {$ps_cmd eq ""} {
set ps_cmd [auto_execok powershell.exe]
}
if {$ps_cmd ne ""} {
set ps_consolemode_pid [exec {*}$ps_cmd -nop -nol -c $ps_consolemode_contents &]
set ps_pipename {\\.\pipe\punkshell_ps_consolemode_}
append ps_pipename $ps_consoleid
puts stderr "twapi not present, using persistent powershell process: pipename: $ps_pipename pid: $ps_consolemode_pid"
#todo - taskkill /F /PID $ps_consolemode_pid
#when?
#review
#if {[catch {puts "pidinfo: [::tcl::process::status $ps_consolemode_pid]"} errM]} {
# puts stderr "--- failed to get process status for $ps_consolemode_pid\n$errM"
#}
#set p [open {\\.\pipe\punkshell_ps_consolemode} w]
#chan conf $p -buffering none -blocking 1
#puts $p ""
#close $p
}
}
}
proc [namespace parent]::enableRaw {{channel stdin}} {
#enableRaw
proc enableRaw {{channel stdin}} {
#puts stderr "punk::console::enableRaw"
#variable is_raw
variable previous_stty_state_$channel
variable ps_consolemode_contents
variable ps_pipename
if {[package provide twapi] ne ""} {
set console_handle [twapi::get_console_handle stdin]
#returns dictionary
#e.g -processedinput 1 -lineinput 1 -echoinput 1 -windowinput 0 -mouseinput 0 -insertmode 1 -quickeditmode 1 -extendedmode 1 -autoposition 0
set oldmode [twapi::get_console_input_mode]
twapi::modify_console_input_mode $console_handle -lineinput 0 -echoinput 0
# Turn off the echo and line-editing bits
#set newmode [dict merge $oldmode [dict create -lineinput 0 -echoinput 0]]
set newmode [twapi::get_console_input_mode]
if {[info exists ps_consolemode_contents]} {
#ps_pipename e.g \\.\pipe\punkwinshell_ps_consolemode_12345-1223456
set trynum 0
set wrote 0
while {$trynum < 5} {
incr trynum
if {![catch {
set pipe [open $ps_pipename w]
} errMsg]} {
chan conf $pipe -buffering line
puts -nonewline $pipe "enableraw\r\n"
#flush $pipe
#after 10
#close $pipe
set wrote 1
break
} else {
after 100
}
}
if {$wrote} {
tsv::set console is_raw 1
#don't disable handler - it will detect is_raw
### twapi::set_console_control_handler {}
return [list stdin [list from $oldmode to $newmode]]
#after 100
close $pipe
} else {
puts stderr "write to $ps_pipename failed trynum: $trynum\n$errMsg"
}
} elseif {[set sttycmd [auto_execok stty]] ne ""} {
#todo - something else entirely
#this approach does not work on windows
#the msys/cygwin stty command is launched as a subprocess - can be used to retrieve info
# but seems to be useless as far as affecting the calling process/console
if {[set previous_stty_state_$channel] eq ""} {
set previous_stty_state_$channel [exec {*}$sttycmd -g <@$channel]
}
@ -537,25 +435,19 @@ namespace eval punk::console {
}
}
#note: twapi GetStdHandle & GetConsoleMode & SetConsoleCombo unreliable - fails with invalid handle (somewhat intermittent.. after stdin reopened?)
#could be we were missing a step in reopening stdin and console configuration?
proc [namespace parent]::disableRaw {{channel stdin}} {
#variable is_raw
proc disableRaw {{channel stdin}} {
variable previous_stty_state_$channel
if {[package provide twapi] ne ""} {
set console_handle [twapi::get_console_handle stdin]
set oldmode [twapi::get_console_input_mode]
# Turn on the echo and line-editing bits
twapi::modify_console_input_mode $console_handle -lineinput 1 -echoinput 1
set newmode [twapi::get_console_input_mode]
set ch_state [chan conf $channel]
if {[dict exists $ch_state -inputmode]} {
chan conf $channel -inputmode normal
tsv::set console is_raw 0
return [list stdin [list from $oldmode to $newmode]]
} elseif {[set sttycmd [auto_execok stty]] ne ""} {
#stty can return info on windows - but doesn't seem to be able to set anything.
#review - is returned info even valid?
return [list $channel [list from [dict get $ch_state -inputmode] to normal]]
} else {
#tcl <= 8.6x doesn't support -inputmode
if {[set sttycmd [auto_execok stty]] ne ""} {
#this doesn't work on windows
#It may seem to - only because running *any* external utility can exit raw mode
set sttycmd [auto_execok stty]
if {[set previous_stty_state_$channel] ne ""} {
exec {*}$sttycmd [set previous_stty_state_$channel]
@ -571,6 +463,163 @@ namespace eval punk::console {
error "punk::console::disableRaw Unable to use twapi or stty to unset raw mode - aborting"
}
}
}
#enableAnsi
proc enableAnsi {} {
}
#disableAnsi
proc enableAnsi {} {
}
#enableVirtualTerminal
proc enableVirtualTerminal {{channels {input output}}} {
}
#disableVirtualTerminal
proc disableVirtualTerminal {{channels {input output}}} {
}
#enableProcessedInput
#disableProcessedInput
}
} else {
#non-windows platforms
proc enableAnsi {} {
#todo?
}
proc disableAnsi {} {
}
#todo - something better - the 'channel' concept may not really apply on unix, as raw mode is set for input and output modes currently - only valid to set on a readable channel?
#on windows they can be set independently (but not with stty) - REVIEW
proc enableVirtualTerminal {{channels {input output}}} {
}
proc disableVirtualTerminal {args} {
}
#NOTE - the is_raw is only being set in current interp - but the channel is shared.
#this is problematic with the repl thread being separate. - must be a tsv? REVIEW
proc enableRaw {{channel stdin}} {
#variable is_raw
variable previous_stty_state_$channel
set sttycmd [auto_execok stty]
if {[set previous_stty_state_$channel] eq ""} {
if {[catch {exec {*}$sttycmd -g <@$channel} previous_stty_state_$channel]} {
set previous_stty_state_$channel ""
}
}
exec {*}$sttycmd raw -echo <@$channel
tsv::set console is_raw 1
return [dict create previous [set previous_stty_state_$channel]]
}
proc disableRaw {{channel stdin}} {
#variable is_raw
variable previous_stty_state_$channel
set sttycmd [auto_execok stty]
if {[set previous_stty_state_$channel] ne ""} {
exec {*}$sttycmd [set previous_stty_state_$channel]
set previous_stty_state_$channel ""
tsv::set console is_raw 0
return restored
}
exec {*}$sttycmd -raw echo <@$channel
tsv::set console is_raw 0
return done
}
}
#review - document and decide granularity required. should we enable/disable more than one at once?
proc enable_mouse {} {
puts -nonewline stdout \x1b\[?1000h
puts -nonewline stdout \x1b\[?1003h
puts -nonewline stdout \x1b\[?1015h
puts -nonewline stdout \x1b\[?1006h
flush stdout
}
proc disable_mouse {} {
puts -nonewline stdout \x1b\[?1000l
puts -nonewline stdout \x1b\[?1003l
puts -nonewline stdout \x1b\[?1015l
puts -nonewline stdout \x1b\[?1006l
flush stdout
}
proc enable_bracketed_paste {} {
puts -nonewline stdout \x1b\[?2004h
}
proc disable_bracketed_paste {} {
puts -nonewline stdout \x1b\[?2004l
}
proc start_application_mode {} {
#need loop to read events?
puts -nonewline stdout \x1b\[?1049h ;#alt screen
enable_mouse
#puts -nonewline stdout \x1b\[?25l ;#hide cursor
puts -nonewline stdout \x1b\[?1003h\n
enable_bracketed_paste
}
#todo stop_application_mode {} {}
proc mode {{raw_or_line query}} {
#variable is_raw
variable ansi_available
set raw_or_line [string tolower $raw_or_line]
if {$raw_or_line eq "query"} {
if {[tsv::get console is_raw]} {
return "raw"
} else {
return "line"
}
} elseif {$raw_or_line eq "raw"} {
if {[catch {
punk::console::enableRaw
} errM]} {
puts stderr "Warning punk::console::enableRaw failed - $errM"
}
if {[can_ansi]} {
punk::console::enableVirtualTerminal both
}
} elseif {$raw_or_line eq "line"} {
#review -order. disableRaw has memory from enableRaw.. but but for line mode we want vt disabled - so call it after disableRaw (?)
if {[catch {
punk::console::disableRaw
} errM]} {
puts stderr "Warning punk::console::disableRaw failed - $errM"
}
if {[can_ansi]} {
punk::console::disableVirtualTerminal input ;#default readline arrow behaviour etc
punk::console::enableVirtualTerminal output ;#display/use ansi codes
}
} else {
error "punk::console::mode expected 'raw' or 'line' or default value 'query'"
}
}
namespace eval internal {
proc abort_if_loop {{failmsg ""}} {
#puts "il1 [info level 1]"
#puts "thisproc: [lindex [info level 0] 0]"
set would_loop [uplevel 1 {expr {[string match *loopavoidancetoken* [info body [namespace tail [lindex [info level 0] 0]]]]}}]
#puts "would_loop: $would_loop"
if {$would_loop} {
set procname [uplevel 1 {namespace tail [lindex [info level 0] 0]}]
if {$failmsg eq ""} {
set errmsg "[namespace current] Failed to redefine procedure $procname"
} else {
set errmsg $failmsg
}
error $errmsg
}
}
proc define_windows_procs {} {
}
@ -1803,7 +1852,10 @@ namespace eval punk::console {
#don't set ansi_avaliable here - we want to be able to change things, retest etc.
if {"windows" eq "$::tcl_platform(platform)"} {
if {[package provide twapi] ne ""} {
set h_out [twapi::get_console_handle stdout]
if {[catch {twapi::get_console_handle stdout} h_out]} {
puts stderr "test_can_ansi: twapi cannot get console handle for stdout"
return 0
}
set existing_mode [twapi::GetConsoleMode $h_out]
if {[expr {$existing_mode & 4}]} {
#virtual terminal processing happens to be enabled - so it's supported

58
src/modules/punk/libunknown-0.1.tm
Unescape View File

@ -80,16 +80,7 @@ tcl::namespace::eval punk::libunknown {
"Experimental set of replacements for default 'package unknown' entries."
}]
variable epoch
#if {![info exists epoch]} {
# set tmstate [dict create 0 {}]
# set pkgstate [dict create 0 {}]
# set tminfo [dict create current 0 epochs $tmstate]
# set pkginfo [dict create current 0 epochs $pkgstate]
# set epoch [dict create tm $tminfo pkg $pkginfo]
#}
variable epoch ;#don't set - can be pre-set cooperatively
variable has_package_files
if {[catch {package files foobaz}]} {
@ -111,6 +102,33 @@ tcl::namespace::eval punk::libunknown {
#will use standard mechanism for non zipfs paths in the tm list.
proc zipfs_tm_UnknownHandler {original name args} {
#------------------------------
#shortcircuit for builtin static libraries which have no 'package provide' info - review
#This occurs for example when running 'bin\runtime.cmd run src\make.tcl shell' with punk902z.exe
#
#------------------------------
set loaded [lsearch -inline -index 1 -nocase [info loaded] $name]
if {[llength $loaded] == 2 && [lindex $loaded 0] eq ""} {
lassign $loaded _ cased_name
interp create ptest
ptest eval [list load {} $cased_name]
set static_version [ptest eval [list package provide [string tolower $cased_name]]]
set pname [string tolower $cased_name]
if {$static_version eq ""} {
set static_version [ptest eval [list package provide $cased_name]]
set pname $cased_name
}
if {$static_version ne ""} {
if {[package vsatisfies $static_version {*}$args]} {
package ifneeded $pname $static_version [list load {} $cased_name]
interp delete ptest
return
}
}
interp delete ptest
}
#------------------------------
# Import the list of paths to search for packages in module form.
# Import the pattern used to check package names in detail.
variable epoch
@ -1161,7 +1179,12 @@ tcl::namespace::eval punk::libunknown {
set callerposn [lsearch $args -caller]
if {$callerposn > -1} {
set caller [lindex $args $callerposn+1]
#puts stderr "\x1b\[1\;33m punk::libunknown::init - caller:$caller\x1b\[m"
if {[package provide thread] ne ""} {
set tid [thread::id]
} else {
set tid "-"
}
#puts stderr "\x1b\[1\;33m punk::libunknown::init - caller:$caller tid:$tid\x1b\[m"
#puts stderr "punk::libunknown::init auto_path : $::auto_path"
#puts stderr "punk::libunknown::init tcl::tm::list: [tcl::tm::list]"
}
@ -1184,17 +1207,17 @@ tcl::namespace::eval punk::libunknown {
puts stderr "punk::libunknown::init - init while empty/unreadable tcl::tm::list and empty/unreadable ::auto_path"
}
if {[namespace origin ::package] eq "::punk::libunknown::package"} {
#This is far from conclusive - there may be other renamers (e.g commandstack)
if {[info commands ::punk::libunknown::package] ne ""} {
puts stderr "punk::libunknown::init already done - unnecessary call? info frame -1: [info frame -1]"
return
}
#if {[namespace origin ::package] eq "::punk::libunknown::package"} {
# #This is far from conclusive - there may be other renamers (e.g commandstack)
# return
#}
if {[info commands ::punk::libunknown::package] ne ""} {
puts stderr "punk::libunknown::init already done - unnecessary call? info frame -1: [info frame -1]"
return
}
variable epoch
if {![info exists epoch]} {
set tmstate [dict create 0 {added {}}]
@ -1222,6 +1245,7 @@ tcl::namespace::eval punk::libunknown {
# or suffer additional scans.. or document ??
#ideally init should be called in each interp before any scans for packages so that the list of untracked is minimized.
set pkgnames [package names]
#puts stderr "####### punk::libunknown init called with [llength $pkgnames] package names known"
foreach p $pkgnames {
if {[string tolower $p] in {punk::libunknown tcl::zlib tcloo tcl::oo tcl}} {
continue

39
src/modules/punk/mix/templates/utility/scriptappwrappers/multishell.cmd
Unescape View File

@ -1345,8 +1345,33 @@ if 0 {
# -- unbalanced braces { } here *even in comments* will cause problems if there was no Tcl exit or return above
# -- custom script should generally go below the begin_powershell_payload line
# ## ### ### ### ### ### ### ### ### ### ### ### ### ###
function GetScriptName { $myInvocation.ScriptName }
$scriptname = GetScriptName
#$MyInvocation.ScriptName should probably be considered deprecated
# https://stackoverflow.com/questions/78511229/how-can-i-choose-between-myinvocation-scriptname-and-myinvocation-pscommandpat
$runningscriptname = $PSCommandPath
if (-not $MyInvocation.PSCommandPath) {
$callingscriptname = ''
} else {
$callingscriptname = $MyInvocation.PSCommandPath
}
#The problem with psmodulepath
#https://github.com/PowerShell/PowerShell/issues/18108
# psmodulepath is shared by powershell and pwsh despite not all ps modules being compatible.
# It is futzed with by powershell/pwsh based on detecting the child process type.
# a psmodulepath that has been futzed with by pwsh will not work for a child powershell 5 process that isn't launched directly
#This is inherently unfriendly to situations where an intervening process may be something else such as cmd.exe,tcl,perl etc
# nevertheless, powershell/pwsh maintainers seem to have taken the MS-centric view of the world that such situations don't exist :/
#
#symptoms of these shenannigans not working include things like Get-FileHash failing in powershell desktop
#
#We don't know if the original console was pwsh/powershell or cmd.exe, and we need to potentially divert to powershell 5 (desktop)
#via tcl or perl etc - or cmd.exe
if ($PSVersionTable.PSVersion.Major -le 5) {
# For Windows PowerShell, we want to remove any PowerShell 7 paths from PSModulePath
#snipped from https://github.com/PowerShell/DSC/pull/777/commits/af9b99a4d38e0cf1e54c4bbd89cbb6a8a8598c4e
#Presumably users are supposed to know not to have custom paths for powershell desktop containing a 'powershell' subfolder??
$env:PSModulePath = ($env:PSModulePath -split ';' | Where-Object { $_ -notlike '*\powershell\*' }) -join ';'
}
function GetDynamicParamDictionary {
[CmdletBinding()]
param(
@ -1421,11 +1446,11 @@ function GetDynamicParamDictionary {
#}
#psmain @args
#"Timestamp : {0,10:yyyy-MM-dd HH:mm:ss}" -f $(Get-Date) | write-host
"Script Name : {0}" -f $scriptname | write-host
#"Running Script Name : {0}" -f $runningscriptname | write-host
"Powershell Version: {0}" -f $PSVersionTable.PSVersion.Major | write-host
"powershell args : {0}" -f ($args -join ", ") | write-host
#"powershell args : {0}" -f ($args -join ", ") | write-host
# -- --- --- ---
$thisfileContent = Get-Content $scriptname -Raw
$thisfileContent = Get-Content $runningscriptname -Raw
$startTag = ": <<asadmin_start>>"
$endTag = ": <<asadmin_end>>"
$pattern = "(?s)`n$startTag[^`n]*`n(.*?)`n$endTag"
@ -1524,7 +1549,7 @@ if ($match.Success) {
}
if (-not (("pwsh", "powershell", "") -contains $nextshell_type)) {
#nextshell diversion exists for this platform
write-host "os: $os pwsh/powershell launching subshell of type: $nextshell_type shellpath: $nextshell_path on script $scriptname"
write-host "os: $os pwsh/powershell launching subshell of type: $nextshell_type shellpath: $nextshell_path on script $runningscriptname"
# $arguments = @($($MyInvocation.MyCommand.Path))
# $arguments += $args
@ -1532,7 +1557,7 @@ if ($match.Success) {
# $process = (Start-Process -FilePath $nextshell_path -ArgumentList $arguments -NoNewWindow -Wait)
# Exit $process.ExitCode
& $nextshell_path $scriptname $args
& $nextshell_path $runningscriptname $args
exit $LASTEXITCODE
}
}

64
src/modules/punk/repl-999999.0a1.0.tm
Unescape View File

@ -20,18 +20,6 @@ if {[dict exists $stdin_info -mode]} {
#give up for now
set tcl_interactive 1
#if {[info commands ::tcl::zipfs::root] ne ""} {
# set zr [::tcl::zipfs::root]
# if {[file join $zr app modules] in [tcl::tm::list]} {
# #todo - better way to find latest version - without package require
# set lib [file join $zr app modules punk libunknown.tm]
# if {[file exists $lib]} {
# source $lib
# punk::libunknown::init
# #package unknown {punk::libunknown::zipfs_tm_UnknownHandler punk::libunknown::zipfs_tclPkgUnknown}
# }
# }
#}
#-------------------------------------------------------------------------------------
if {[package provide punk::libunknown] eq ""} {
#maintenance - also in src/vfs/_config/punk_main.tcl
@ -59,7 +47,7 @@ if {[package provide punk::libunknown] eq ""} {
}
if {$libunknown ne ""} {
source $libunknown
if {[catch {punk::libunknown::init -caller repl} errM]} {
if {[catch {punk::libunknown::init -caller triggered_by_repl_package_require} errM]} {
puts "error initialising punk::libunknown\n$errM"
}
}
@ -525,11 +513,11 @@ proc repl::start {inchan args} {
set donevalue [set [namespace current]::done]
if {[lindex $donevalue 0] eq "quit"} {
puts "-->repl::start end $inchan $args result:'$donevalue'"
puts stderr "--> returning [lindex $donevalue 1]"
#puts stderr "repl quit --> returning [lindex $donevalue 1]"
return [lindex $donevalue 1]
}
puts "-->repl::start end $inchan $args result:'$donevalue'"
puts stderr "__> returning 0"
#puts stderr "__> returning 0"
return 0
}
proc repl::post_operations {} {
@ -1408,7 +1396,6 @@ proc repl::repl_handler {inputchan prompt_config} {
if {[dict get $original_input_conf -inputmode] eq "raw"} {
#user or script has apparently put stdin into raw mode - update punk::console::is_raw to match
set rawmode 1
#set ::punk::console::is_raw 1
tsv::set console is_raw 1
} else {
#set ::punk::console::is_raw 0
@ -1420,9 +1407,6 @@ proc repl::repl_handler {inputchan prompt_config} {
#if it's been set to raw - assume it is deliberately done this way as the user could have alternatively called punk::mode raw or punk::console::enableVirtualTerminal
#by not doing this automatically - we assume the caller has a reason.
} else {
#JMN FIX!
#this returns 0 in rawmode on 8.6 after repl thread changes
#set rawmode [set ::punk::console::is_raw]
set rawmode [tsv::get console is_raw]
}
@ -1811,8 +1795,6 @@ proc repl::repl_process_data {inputchan chunktype chunk stdinlines prompt_config
set infoprompt [dict get $prompt_config infoprompt]
set debugprompt [dict get $prompt_config debugprompt]
#set rawmode [set ::punk::console::is_raw]
set rawmode [tsv::get console is_raw]
if {!$rawmode} {
#puts stderr "-->got [ansistring VIEW -lf 1 $stdinlines]<--"
@ -2615,6 +2597,34 @@ proc repl::repl_process_data {inputchan chunktype chunk stdinlines prompt_config
}
#editbuf
#after any external command - raw mode as the console sees it can be disabled
#set it to match current state of the tsv
if {[tsv::get console is_raw]} {
if {$::tcl_platform(platform) eq "windows"} {
#review
#we are in parent process - twapi might not be loaded here - even if it is in the code interp
catch {package require twapi}
}
set sinfo [chan configure stdin]
if {[dict exists $sinfo -inputmode]} {
if {[dict get $sinfo -inputmode] ne "raw"} {
set re_enable_required 1
} else {
set re_enable_required 0
}
} else {
# -inputmode unavailable
#tcl 8.6 doesn't have -inputmode - meaning it has to call punk:console::enableRaw each time
#enableRaw on windows without twapi involves launching a pwsh process - which gives a noticeable lag in keyboard input.
#enableRaw on Unix involves a call to stty - which is generally fast - but still to be avoided if not required.
set re_enable_required 1
}
#puts stderr "-here- re-enabling raw"
if {$re_enable_required} {
punk::console::enableRaw
}
}
} else {
#append commandstr \n
if {$::punk::repl::signal_control_c} {
@ -2828,7 +2838,7 @@ namespace eval repl {
}
if {$libunknown ne ""} {
source $libunknown
if {[catch {punk::libunknown::init -caller "repl init_script"} errM]} {
if {[catch {punk::libunknown::init -caller "repl::init init_script parent interp"} errM]} {
puts "repl::init problem - error initialising punk::libunknown\n$errM"
}
#package require punk::lib
@ -2858,10 +2868,10 @@ namespace eval repl {
#thread::send to caller defined interp targets (reference?)
#snit required for icomm
if {[catch {package require snit} errM]} {
puts stdout "punk::repl::initscript lib load fail ---snit $errM"
#puts stdout "punk::repl::initscript: lib load fail ---snit $errM"
}
if {[catch {package require punk::icomm} errM]} {
puts stdout "punk::repl::initscript lib load fail ---icomm $errM"
#puts stdout "punk::repl::initscript: lib load fail ---icomm $errM"
}
#-----
@ -2872,7 +2882,7 @@ namespace eval repl {
#first use can raise error being a version number e.g 0.1.0 - why?
lassign [tcl::chan::fifo2] ::punk::repl::codethread::repltalk replside
} errMsg]} {
puts stdout "punk::repl::initscript tcl::chan::fifo2 error: $errM"
puts stdout "punk::repl::initscript tcl::chan::fifo2 error: $errMsg"
} else {
#experimental?
#puts stdout "transferring chan $replside to thread %replthread%"
@ -3519,6 +3529,8 @@ namespace eval repl {
#-----------------------------------------------------------------------------
if {[package provide punk::libunknown] eq ""} {
namespace eval ::punk::libunknown {}
set ::punk::libunknown::epoch %lib_epoch%
set libunks [list]
foreach tm_path [tcl::tm::list] {
set punkdir [file join $tm_path punk]
@ -3543,7 +3555,7 @@ namespace eval repl {
}
if {$libunknown ne ""} {
source $libunknown
if {[catch {punk::libunknown::init -caller "repl init_script punk"} errM]} {
if {[catch {punk::libunknown::init -caller "repl::init init_script code interp for punk"} errM]} {
puts "error initialising punk::libunknown\n$errM"
}
}

157
src/project_layouts/custom/_project/punk.basic/src/make.tcl
Unescape View File

@ -31,22 +31,28 @@ namespace eval ::punkboot::lib {
#for some purposes (whether a source folder is likely to have any useful content) we are interested in non dotfile/dotfolder immediate contents of a folder, but not whether a particular platform
#considers them hidden or not.
proc folder_nondotted_children {folder} {
if {![file isdirectory $folder]} {error "punkboot::lib::folder_nondotted_children error. Supplied folder '$folder' is not a directory"}
set contents [glob -nocomplain -dir $folder *]
set normfolder [file normalize $folder]
if {![file isdirectory $normfolder]} {error "punkboot::lib::folder_nondotted_children error. Supplied folder '$folder' is not a directory"}
set contents [glob -nocomplain -dir $folder -tails *]
#some platforms (windows) return dotted entries with *, although most don't
return [lsearch -all -inline -not $contents .*]
set nondotted_tails [lsearch -all -inline -not $contents .*]
return [lmap ftail $nondotted_tails {file join $folder $ftail}]
}
proc folder_nondotted_folders {folder} {
if {![file isdirectory $folder]} {error "punkboot::lib::folder_nondotted_folders error. Supplied folder '$folder' is not a directory"}
set contents [glob -nocomplain -dir $folder -types d *]
set normfolder [file normalize $folder]
if {![file isdirectory $normfolder]} {error "punkboot::lib::folder_nondotted_folders error. Supplied folder '$folder' is not a directory"}
set contents [glob -nocomplain -dir $folder -types d -tails *]
#some platforms (windows) return dotted entries with *, although most don't
return [lsearch -all -inline -not $contents .*]
set nondotted_tails [lsearch -all -inline -not $contents .*]
return [lmap ftail $nondotted_tails {file join $folder $ftail}]
}
proc folder_nondotted_files {folder} {
if {![file isdirectory $folder]} {error "punkboot::lib::folder_nondotted_files error. Supplied folder '$folder' is not a directory"}
set contents [glob -nocomplain -dir $folder -types f $folder *]
set normfolder [file normalize $folder]
if {![file isdirectory $normfolder]} {error "punkboot::lib::folder_nondotted_files error. Supplied folder '$folder' is not a directory"}
set contents [glob -nocomplain -dir $folder -types f $folder -tails *]
#some platforms (windows) return dotted entries with *, although most don't
return [lsearch -all -inline -not $contents .*]
set nondotted_tails [lsearch -all -inline -not $contents .*]
return [lmap ftail $nondotted_tails {file join $folder $ftail}]
}
proc tm_version_isvalid {versionpart} {
#Needs to be suitable for use with Tcl's 'package vcompare'
@ -289,6 +295,10 @@ if {"::try" ni [info commands ::try]} {
# This allows a source update via 'fossil update' 'git pull' etc to pull in a minimal set of support modules for the boot script
# and load these in preference to ones that may have been in the interp's tcl::tm::list or auto_path due to environment variables
set startdir [pwd]
set scriptdir [file dirname [file normalize [info script]]]
#puts "SCRIPTDIR: $scriptdir"
#we are focussed on pure-tcl libs/modules in bootsupport for now.
#There may be cases where we want to use compiled packages from src/bootsupport/modules_tcl9 etc
#REVIEW - punkboot can really speed up with appropriate accelerators and/or external binaries
@ -303,18 +313,22 @@ set bootsupport_library_paths [list]
set this_platform_generic [punkboot::lib::platform_generic]
#we always create these lists in order of desired precedence.
# - this is the same order when adding to auto_path - but will need to be reversed when using tcl:tm::add
if {[file exists [file join $startdir src bootsupport]]} {
lappend bootsupport_module_paths [file join $startdir src bootsupport modules_tcl$::tclmajorv] ;#more version-specific modules slightly higher in precedence order
lappend bootsupport_module_paths [file join $startdir src bootsupport modules]
lappend bootsupport_library_paths [file join $startdir src bootsupport lib_tcl$::tclmajorv/allplatforms] ;#more version-specific pkgs slightly higher in precedence order
lappend bootsupport_library_paths [file join $startdir src bootsupport lib_tcl$::tclmajorv/$this_platform_generic] ;#more version-specific pkgs slightly higher in precedence order
lappend bootsupport_library_paths [file join $startdir src bootsupport lib]
if {[file exists [file join $scriptdir bootsupport]]} {
set bootsupportdir [file join $scriptdir bootsupport]
puts stderr "Using bootsupport dir $bootsupportdir"
lappend bootsupport_module_paths [file join $bootsupportdir modules_tcl$::tclmajorv] ;#more version-specific modules slightly higher in precedence order
lappend bootsupport_module_paths [file join $bootsupportdir modules]
lappend bootsupport_library_paths [file join $bootsupportdir lib_tcl$::tclmajorv/allplatforms] ;#more version-specific pkgs slightly higher in precedence order
lappend bootsupport_library_paths [file join $bootsupportdir lib_tcl$::tclmajorv/$this_platform_generic] ;#more version-specific pkgs slightly higher in precedence order
lappend bootsupport_library_paths [file join $bootsupportdir lib]
} else {
lappend bootsupport_module_paths [file join $startdir bootsupport modules_tcl$::tclmajorv]
lappend bootsupport_module_paths [file join $startdir bootsupport modules]
lappend bootsupport_library_paths [file join $startdir bootsupport lib_tcl$::tclmajorv/allplatforms]
lappend bootsupport_library_paths [file join $startdir bootsupport lib_tcl$::tclmajorv/$this_platform_generic]
lappend bootsupport_library_paths [file join $startdir bootsupport lib]
puts stderr "No bootsupport dir for script [info script] at [file join $scriptdir bootsupport]"
#lappend bootsupport_module_paths [file join $startdir bootsupport modules_tcl$::tclmajorv]
#lappend bootsupport_module_paths [file join $startdir bootsupport modules]
#lappend bootsupport_library_paths [file join $startdir bootsupport lib_tcl$::tclmajorv/allplatforms]
#lappend bootsupport_library_paths [file join $startdir bootsupport lib_tcl$::tclmajorv/$this_platform_generic]
#lappend bootsupport_library_paths [file join $startdir bootsupport lib]
}
set bootsupport_paths_exist 0
foreach p [list {*}$bootsupport_module_paths {*}$bootsupport_library_paths] {
@ -406,8 +420,8 @@ if {$bootsupport_paths_exist || $sourcesupport_paths_exist} {
tcl::tm::add {*}[lreverse $bootsupport_module_paths] {*}[lreverse $sourcesupport_module_paths] ;#tm::add works like LIFO. sourcesupport_module_paths end up earliest in resulting tm list.
set ::auto_path [list {*}$sourcesupport_library_paths {*}$bootsupport_library_paths]
}
puts "----> auto_path $::auto_path"
puts "----> tcl::tm::list [tcl::tm::list]"
#puts "----> auto_path $::auto_path"
#puts "----> tcl::tm::list [tcl::tm::list]"
#maint: also in punk::repl package
#--------------------------------------------------------
@ -435,22 +449,26 @@ if {$bootsupport_paths_exist || $sourcesupport_paths_exist} {
}
if {$libunknown ne ""} {
source $libunknown
if {[catch {punk::libunknown::init -caller main.tcl} errM]} {
puts "error initialising punk::libunknown\n$errM"
if {[catch {punk::libunknown::init -caller make.tcl} errM]} {
puts stderr "error initialising punk::libunknown\n$errM"
}
#puts stdout " *** [package names]"
#puts stdout " **** [dict get $::punk::libunknown::epoch pkg untracked]"
} else {
puts stderr "Failed to find punk::libunknown"
}
#--------------------------------------------------------
#package require Thread
puts "---->tcl_library [info library]"
puts "---->loaded [info loaded]"
#puts "---->tcl_library [info library]"
#puts "---->loaded [info loaded]"
# - the full repl requires Threading and punk,shellfilter,shellrun to call and display properly.
# tm list already indexed - need 'package forget' to find modules based on current tcl::tm::list
#These are strong dependencies
package forget punk::mix
package forget punk::repo
package forget punkcheck
#package forget punk::mix
#package forget punk::repo
#package forget punkcheck
package require punk::repo ;#todo - push our requirements to a smaller punk::repo::xxx package with minimal dependencies
package require punk::mix
@ -464,6 +482,7 @@ if {$bootsupport_paths_exist || $sourcesupport_paths_exist} {
set package_paths_modified 1
#------------------------------------------------------------------------------
#puts "----> llength package names [llength [package names]]"
}
set ::punkboot::pkg_requirements_found [list]
@ -479,7 +498,9 @@ set ::punkboot::bootsupport_requirements [dict create\
punkcheck [list]\
fauxlink [list version "0.1.1-"]\
textblock [list version 0.1.1-]\
fileutil [list]\
fileutil::traverse [list]\
struct::list [list]\
md5 [list version 2-]\
]
@ -1282,7 +1303,41 @@ proc ::punkboot::punkboot_gethelp {args} {
return $h
}
set scriptargs $::argv
punk::args::define {
@id -id punkmake
@cmd -name punkmake\
-summary\
"Project builder"\
-help\
""
@form -form help
@leaders
subcommand -type "literal(help)"
@opts
@values
what -type string -choices {modules libs shell}
@form -form modules
subcommand -type "literal(modules)"
@form -form libs
subcommand -type "literal(libs)"
@form -form shell
subcommand -type "literal(shell)"
arg -type any -optional 1 -multiple 1
}
#set argd [punk::args::parse $scriptargs -form 0 withid punkmake]
##lassign [dict values $argd] leaders opts values received
#
#puts stdout [punk::args::usage -scheme nocolour punkmake]
#exit 1
set do_help 0
if {![llength $scriptargs]} {
set do_help 1
@ -1294,6 +1349,8 @@ if {![llength $scriptargs]} {
}
}
}
set commands_found [list]
foreach a $scriptargs {
if {![string match -* $a]} {
@ -1310,6 +1367,8 @@ if {[llength $commands_found] != 1 } {
puts stderr "Unknown command: [lindex $commands_found 0]\n\n"
set do_help 1
}
if {$do_help} {
puts stdout "Checking package availability..."
set ::punkboot::pkg_availability [::punkboot::check_package_availability -quiet 1 $::punkboot::bootsupport_requirements]
@ -1325,6 +1384,8 @@ if {$do_help} {
exit 0
}
set ::punkboot::command [lindex $commands_found 0]
@ -1414,14 +1475,15 @@ if {$::punkboot::command eq "check"} {
if {$package_paths_modified} {
set tm_list_boot [tcl::tm::list]
tcl::tm::remove {*}$tm_list_boot
foreach p [lreverse $original_tm_list] {
set lower_prio [list]
foreach p $original_tm_list {
if {$p ni $tm_list_boot} {
tcl::tm::add $p
}
lappend lower_prio $p
}
foreach p [lreverse $tm_list_boot] {
tcl::tm::add $p
}
tcl::tm::add {*}[lreverse $lower_prio] {*}[lreverse $tm_list_boot]
#set ::auto_path [list $bootsupport_lib {*}$original_auto_path]
lappend ::auto_path {*}$original_auto_path
}
@ -1489,6 +1551,28 @@ if {![array size A]} {
punkboot::define_global_ansi
}
#puts stderr ">>>>>>+ loaded:[info loaded]"
#puts stderr "llength package names: [llength [package names]]"
if {[info exists ::punk::libunknown::epoch]} {
set untracked [dict get $::punk::libunknown::epoch pkg untracked]
#puts stderr "punk::libunknown::epoch exists"
} else {
set untracked [list]
#puts stderr "punk::libunknown::epoch does not exist"
}
#REVIEW - we shouldn't need to manually set the untracked packages - punk::libunknown::init should have done it?
foreach p [package names] {
if {![dict exists $untracked $p]} {
dict set untracked $p ""
}
}
dict set ::punk::libunknown::epoch pkg untracked $untracked
if {[package provide punk::libunknown] eq ""} {
puts "punk::libunknown not loaded"
} else {
puts "punk::libunknown loaded"
}
dict for {pkg pkginfo} $::punkboot::bootsupport_requirements {
set verspec [dict get $pkginfo version] ;#version wanted specification always exists and is empty or normalised
if {[catch {package require $pkg {*}$verspec} errM]} {
@ -1557,14 +1641,13 @@ if {$::punkboot::command eq "info"} {
if {$::punkboot::command eq "shell"} {
puts stderr ">>>>>> loaded:[info loaded]"
package require struct::list
package require punk
package require punk::repl
#todo - make procs vars etc from this file available?
puts stderr "punk boot shell not implemented - dropping into ordinary punk shell."
repl::init
set replresult [repl::start stdin -title make.tcl]
#review
@ -3059,6 +3142,8 @@ foreach vfstail $vfs_tails {
exec {*}$::sdxpath unwrap [file rootname $building_runtime].tail ;#extracts to folder named [file rootname $building_runtime].vfs e.g build_tclkit9.0.2-win64-dyn.vfs
#file rename to existing target dir would copy folder into target dir
if {![file exists $targetvfs]} {
#delay
after 1000
file rename [file rootname $building_runtime].vfs $targetvfs
} else {
merge_over [file rootname $building_runtime].vfs $targetvfs

5
src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args-0.2.tm
Unescape View File

@ -3036,8 +3036,11 @@ tcl::namespace::eval punk::args {
#This mechanism gets less-than-useful results for oo methods
#e.g {$obj}
proc Get_caller {} {
set depth [info level]
set maxd [expr {min($depth,4)}]
set call_level [expr {-1 * $maxd}]
#set call_level -3 ;#for get_dict call
set call_level -4
#set call_level -4
set cmdinfo [tcl::dict::get [tcl::info::frame $call_level] cmd]
#puts "-->$cmdinfo"
#puts "-->[tcl::info::frame -3]"

2
src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args/tclcore-0.1.0.tm
Unescape View File

@ -3498,7 +3498,7 @@ tcl::namespace::eval punk::args::tclcore {
example, in ${$B}-dictionary${$N} mode, bigBoy sorts between bigbang and bigboy,
and x10y sorts between x9y and x11y. Overrides the ${$B}-nocase${$N} option."
-integer -type none -help\
"Convert list elements to integers and use integer comparsion."
"Convert list elements to integers and use integer comparison."
-real -type none -help\
"Convert list elements to floating-point values and use floating comparison."
-command -type string -help\

556
src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/console-0.1.1.tm
Unescape View File

@ -132,216 +132,22 @@ namespace eval punk::console {
if {"windows" eq $::tcl_platform(platform)} {
#accept args for all dummy/load functions so we don't have to match/update argument signatures here
set has_twapi [expr {! [catch {package require twapi}]}]
proc enableAnsi {args} {
#loopavoidancetoken (don't remove)
internal::define_windows_procs
internal::abort_if_loop
tailcall enableAnsi {*}$args
}
#review what raw mode means with regard to a specific channel vs terminal as a whole
proc enableRaw {args} {
#loopavoidancetoken (don't remove)
internal::define_windows_procs
internal::abort_if_loop
tailcall enableRaw {*}$args
}
proc disableRaw {args} {
#loopavoidancetoken (don't remove)
internal::define_windows_procs
internal::abort_if_loop
tailcall disableRaw {*}$args
}
proc enableVirtualTerminal {args} {
#loopavoidancetoken (don't remove)
internal::define_windows_procs
internal::abort_if_loop
tailcall enableVirtualTerminal {*}$args
}
proc disableVirtualTerminal {args} {
#loopavoidancetoken (don't remove)
internal::define_windows_procs
internal::abort_if_loop
tailcall disableVirtualTerminal {*}$args
}
set funcs [list disableAnsi enableProcessedInput disableProcessedInput]
foreach f $funcs {
proc $f {args} [string map [list %f% $f] {
set mybody [info body %f%]
internal::define_windows_procs
set newbody [info body %f%]
if {$newbody ne $mybody} {
tailcall %f% {*}$args
} else {
#error vs noop?
puts stderr "Unable to set implementation for %f% - check twapi?"
}
}]
}
} else {
proc enableAnsi {} {
#todo?
}
proc disableAnsi {} {
}
#todo - something better - the 'channel' concept may not really apply on unix, as raw mode is set for input and output modes currently - only valid to set on a readable channel?
#on windows they can be set independently (but not with stty) - REVIEW
#NOTE - the is_raw is only being set in current interp - but the channel is shared.
#this is problematic with the repl thread being separate. - must be a tsv? REVIEW
proc enableRaw {{channel stdin}} {
#variable is_raw
variable previous_stty_state_$channel
set sttycmd [auto_execok stty]
if {[set previous_stty_state_$channel] eq ""} {
if {[catch {exec {*}$sttycmd -g <@$channel} previous_stty_state_$channel]} {
set previous_stty_state_$channel ""
}
}
exec {*}$sttycmd raw -echo <@$channel
tsv::set console is_raw 1
return [dict create previous [set previous_stty_state_$channel]]
}
proc disableRaw {{channel stdin}} {
#variable is_raw
variable previous_stty_state_$channel
set sttycmd [auto_execok stty]
if {[set previous_stty_state_$channel] ne ""} {
exec {*}$sttycmd [set previous_stty_state_$channel]
set previous_stty_state_$channel ""
tsv::set console is_raw 0
return restored
}
exec {*}$sttycmd -raw echo <@$channel
tsv::set console is_raw 0
return done
}
proc enableVirtualTerminal {{channels {input output}}} {
}
proc disableVirtualTerminal {args} {
}
}
#review - document and decide granularity required. should we enable/disable more than one at once?
proc enable_mouse {} {
puts -nonewline stdout \x1b\[?1000h
puts -nonewline stdout \x1b\[?1003h
puts -nonewline stdout \x1b\[?1015h
puts -nonewline stdout \x1b\[?1006h
flush stdout
}
proc disable_mouse {} {
puts -nonewline stdout \x1b\[?1000l
puts -nonewline stdout \x1b\[?1003l
puts -nonewline stdout \x1b\[?1015l
puts -nonewline stdout \x1b\[?1006l
flush stdout
}
proc enable_bracketed_paste {} {
puts -nonewline stdout \x1b\[?2004h
}
proc disable_bracketed_paste {} {
puts -nonewline stdout \x1b\[?2004l
}
proc start_application_mode {} {
#need loop to read events?
puts -nonewline stdout \x1b\[?1049h ;#alt screen
enable_mouse
#puts -nonewline stdout \x1b\[?25l ;#hide cursor
puts -nonewline stdout \x1b\[?1003h\n
enable_bracketed_paste
}
#todo stop_application_mode {} {}
proc mode {{raw_or_line query}} {
#variable is_raw
variable ansi_available
set raw_or_line [string tolower $raw_or_line]
if {$raw_or_line eq "query"} {
if {[tsv::get console is_raw]} {
return "raw"
} else {
return "line"
}
} elseif {$raw_or_line eq "raw"} {
if {[catch {
punk::console::enableRaw
} errM]} {
puts stderr "Warning punk::console::enableRaw failed - $errM"
}
if {[can_ansi]} {
punk::console::enableVirtualTerminal both
}
} elseif {$raw_or_line eq "line"} {
#review -order. disableRaw has memory from enableRaw.. but but for line mode we want vt disabled - so call it after disableRaw (?)
if {[catch {
punk::console::disableRaw
} errM]} {
puts stderr "Warning punk::console::disableRaw failed - $errM"
}
if {[can_ansi]} {
punk::console::disableVirtualTerminal input ;#default readline arrow behaviour etc
punk::console::enableVirtualTerminal output ;#display/use ansi codes
}
} else {
error "punk::console::mode expected 'raw' or 'line' or default value 'query'"
}
}
namespace eval internal {
proc abort_if_loop {{failmsg ""}} {
#puts "il1 [info level 1]"
#puts "thisproc: [lindex [info level 0] 0]"
set would_loop [uplevel 1 {expr {[string match *loopavoidancetoken* [info body [namespace tail [lindex [info level 0] 0]]]]}}]
#puts "would_loop: $would_loop"
if {$would_loop} {
set procname [uplevel 1 {namespace tail [lindex [info level 0] 0]}]
if {$failmsg eq ""} {
set errmsg "[namespace current] Failed to redefine procedure $procname"
} else {
set errmsg $failmsg
}
error $errmsg
}
}
proc define_windows_procs {} {
package require zzzload
set loadstate [zzzload::pkg_require twapi]
#loadstate could also be stuck on loading? - review - zzzload not very ripe
#Twapi can be relatively slow to load (on some systems) - can be 1s plus in some cases - and much longer if there are disk performance issues.
if {$loadstate ni [list failed]} {
#possibly still 'loading'
#review zzzload usage
#puts stdout "=========== console loading twapi ============="
set loadstate [zzzload::pkg_wait twapi] ;#can return 'failed' will return version if already loaded or loaded during wait
}
if {$loadstate ni [list failed]} {
package require twapi ;#should be fast once twapi dll loaded in zzzload thread
set ::punk::console::has_twapi 1
#todo - move some of these to the punk::console::local sub-namespace - as they use APIs rather than in-band ANSI to do their work.
#enableAnsi seems like it should be directly under punk::console .. but then it seems inconsistent if other local console-mode setting functions aren't.
#Find a compromise to organise things somewhat sensibly..
if {$has_twapi} {
#this is really enableAnsi *processing*
proc [namespace parent]::enableAnsi {} {
proc enableAnsi {} {
#output handle modes
#Enable virtual terminal processing (sometimes off in older windows terminals)
#ENABLE_PROCESSED_OUTPUT = 0x0001
#ENABLE_WRAP_AT_EOL_OUTPUT = 0x0002
#ENABLE_VIRTUAL_TERMINAL_PROCESSING = 0x0004
#DISABLE_NEWLINE_AUTO_RETURN = 0x0008
set h_out [twapi::get_console_handle stdout]
if {[catch {twapi::get_console_handle stdout} h_out]} {
puts stderr "enableAnsi failed: twapi cannot get console handle for stdout"
return
}
set oldmode_out [twapi::GetConsoleMode $h_out]
set newmode_out [expr {$oldmode_out | 4}] ;#don't enable processed output too, even though it's required. keep symmetrical with disableAnsi?
@ -366,7 +172,7 @@ namespace eval punk::console {
return [list stdout [list from $oldmode_out to $newmode_out] stdin [list from $oldmode_in to $newmode_in]]
}
proc [namespace parent]::disableAnsi {} {
proc disableAnsi {} {
set h_out [twapi::get_console_handle stdout]
set oldmode_out [twapi::GetConsoleMode $h_out]
set newmode_out [expr {$oldmode_out & ~4}]
@ -381,9 +187,7 @@ namespace eval punk::console {
return [list stdout [list from $oldmode_out to $newmode_out] stdin [list from $oldmode_in to $newmode_in]]
}
#
proc [namespace parent]::enableVirtualTerminal {{channels {input output}}} {
proc enableVirtualTerminal {{channels {input output}}} {
set ins [list in input stdin]
set outs [list out output stdout stderr]
set known [concat $ins $outs both]
@ -424,7 +228,8 @@ namespace eval punk::console {
return $result
}
proc [namespace parent]::disableVirtualTerminal {{channels {input output}}} {
proc disableVirtualTerminal {{channels {input output}}} {
set ins [list in input stdin]
set outs [list out output stdout stderr]
set known [concat $ins $outs both]
@ -465,65 +270,158 @@ namespace eval punk::console {
#return [list stdout [list from $oldmode_out to $newmode_out] stdin [list from $oldmode_in to $newmode_in]]
return $result
}
proc [namespace parent]::enableProcessedInput {} {
proc enableProcessedInput {} {
set h_in [twapi::get_console_handle stdin]
set oldmode_in [twapi::GetConsoleMode $h_in]
set newmode_in [expr {$oldmode_in | 1}]
twapi::SetConsoleMode $h_in $newmode_in
return [list stdin [list from $oldmode_in to $newmode_in]]
}
proc [namespace parent]::disableProcessedInput {} {
proc disableProcessedInput {} {
set h_in [twapi::get_console_handle stdin]
set oldmode_in [twapi::GetConsoleMode $h_in]
set newmode_in [expr {$oldmode_in & ~1}]
twapi::SetConsoleMode $h_in $newmode_in
return [list stdin [list from $oldmode_in to $newmode_in]]
}
proc enableRaw {{channel stdin}} {
#variable is_raw
variable previous_stty_state_$channel
if {[catch {twapi::get_console_handle stdin} console_handle]} {
puts stderr "enableRaw error: twapi cannot get console handle for stdin"
#review. If twapi couldn't get a console handle - no point trying other mechanisms(?)
return
}
#returns dictionary
#e.g -processedinput 1 -lineinput 1 -echoinput 1 -windowinput 0 -mouseinput 0 -insertmode 1 -quickeditmode 1 -extendedmode 1 -autoposition 0
set oldmode [twapi::get_console_input_mode]
twapi::modify_console_input_mode $console_handle -lineinput 0 -echoinput 0
# Turn off the echo and line-editing bits
#set newmode [dict merge $oldmode [dict create -lineinput 0 -echoinput 0]]
set newmode [twapi::get_console_input_mode]
tsv::set console is_raw 1
#don't disable handler - it will detect is_raw
### twapi::set_console_control_handler {}
return [list stdin [list from $oldmode to $newmode]]
}
} else {
#note: twapi GetStdHandle & GetConsoleMode & SetConsoleCombo unreliable - fails with invalid handle (somewhat intermittent.. after stdin reopened?)
#could be we were missing a step in reopening stdin and console configuration?
puts stderr "punk::console falling back to stty because twapi load failed"
proc [namespace parent]::enableAnsi {} {
puts stderr "punk::console::enableAnsi todo"
}
proc [namespace parent]::disableAnsi {} {
proc disableRaw {{channel stdin}} {
#variable is_raw
variable previous_stty_state_$channel
set ch_state [chan conf $channel]
if {[dict exists $ch_state -inputmode]} {
chan conf $channel -inputmode normal
tsv::set console is_raw 0
return [list $channel [list from [dict get $ch_state -inputmode] to normal]]
} else {
if {[catch {twapi::get_console_handle stdin} console_handle]} {
#e.g tkcon/wish
puts stderr "disableRaw error: twapi cannot get console handle for stdin"
return ;# ???
}
#?
proc [namespace parent]::enableVirtualTerminal {{channels {input output}}} {
set oldmode [twapi::get_console_input_mode]
# Turn on the echo and line-editing bits
twapi::modify_console_input_mode $console_handle -lineinput 1 -echoinput 1
set newmode [twapi::get_console_input_mode]
tsv::set console is_raw 0
return [list stdin [list from $oldmode to $newmode]]
}
proc [namespace parent]::disableVirtualTerminal {{channels {input output}}} {
}
proc [namespace parent]::enableProcessedInput {args} {
}
proc [namespace parent]::disableProcessedInput {args} {
} else {
variable ps_consolemode_pid
variable ps_consolemode_contents
variable ps_pipename
if {![info exists ps_consolemode_contents]} {
#start persistent powershell consolemode_server.ps1 named pipe server
if {$::argv0 ne ""} {
set pstooldir [file dirname [file dirname [file normalize $::argv0]]]/scriptlib/utils/pwsh
} else {
set pstooldir [pwd]
}
#set ps_script $pstooldir/consolemode_server.ps1
set ps_script $pstooldir/consolemode_server_async.ps1
if {[file exists $ps_script]} {
set fd [open $ps_script r]
chan configure $fd -translation binary
set ps_consoleid [pid]-[expr {int(999 * rand())+1}]
set ps_consolemode_contents [string map [list "<punkshell_consoleid>" $ps_consoleid] [read $fd]]
close $fd
#set ps_consolemode_pipe [twapi::namedpipe_client {//./pipe/punkshell_ps_consolemode} -access write]
#set ps_cmd [auto_execok pwsh.exe]
set ps_cmd [auto_execok pwsh.exe]
if {$ps_cmd eq ""} {
set ps_cmd [auto_execok powershell.exe]
}
if {$ps_cmd ne ""} {
set ps_consolemode_pid [exec {*}$ps_cmd -nop -nol -c $ps_consolemode_contents &]
set ps_pipename {\\.\pipe\punkshell_ps_consolemode_}
append ps_pipename $ps_consoleid
puts stderr "twapi not present, using persistent powershell process: pipename: $ps_pipename pid: $ps_consolemode_pid"
#todo - taskkill /F /PID $ps_consolemode_pid
#when?
#review
#if {[catch {puts "pidinfo: [::tcl::process::status $ps_consolemode_pid]"} errM]} {
# puts stderr "--- failed to get process status for $ps_consolemode_pid\n$errM"
#}
#set p [open {\\.\pipe\punkshell_ps_consolemode} w]
#chan conf $p -buffering none -blocking 1
#puts $p ""
#close $p
}
}
}
proc [namespace parent]::enableRaw {{channel stdin}} {
#enableRaw
proc enableRaw {{channel stdin}} {
#puts stderr "punk::console::enableRaw"
#variable is_raw
variable previous_stty_state_$channel
variable ps_consolemode_contents
variable ps_pipename
if {[package provide twapi] ne ""} {
set console_handle [twapi::get_console_handle stdin]
#returns dictionary
#e.g -processedinput 1 -lineinput 1 -echoinput 1 -windowinput 0 -mouseinput 0 -insertmode 1 -quickeditmode 1 -extendedmode 1 -autoposition 0
set oldmode [twapi::get_console_input_mode]
twapi::modify_console_input_mode $console_handle -lineinput 0 -echoinput 0
# Turn off the echo and line-editing bits
#set newmode [dict merge $oldmode [dict create -lineinput 0 -echoinput 0]]
set newmode [twapi::get_console_input_mode]
if {[info exists ps_consolemode_contents]} {
#ps_pipename e.g \\.\pipe\punkwinshell_ps_consolemode_12345-1223456
set trynum 0
set wrote 0
while {$trynum < 5} {
incr trynum
if {![catch {
set pipe [open $ps_pipename w]
} errMsg]} {
chan conf $pipe -buffering line
puts -nonewline $pipe "enableraw\r\n"
#flush $pipe
#after 10
#close $pipe
set wrote 1
break
} else {
after 100
}
}
if {$wrote} {
tsv::set console is_raw 1
#don't disable handler - it will detect is_raw
### twapi::set_console_control_handler {}
return [list stdin [list from $oldmode to $newmode]]
after 100
close $pipe
} else {
puts stderr "write to $ps_pipename failed trynum: $trynum\n$errMsg"
}
} elseif {[set sttycmd [auto_execok stty]] ne ""} {
#todo - something else entirely
#this approach does not work on windows
#the msys/cygwin stty command is launched as a subprocess - can be used to retrieve info
# but seems to be useless as far as affecting the calling process/console
if {[set previous_stty_state_$channel] eq ""} {
set previous_stty_state_$channel [exec {*}$sttycmd -g <@$channel]
}
@ -537,25 +435,19 @@ namespace eval punk::console {
}
}
#note: twapi GetStdHandle & GetConsoleMode & SetConsoleCombo unreliable - fails with invalid handle (somewhat intermittent.. after stdin reopened?)
#could be we were missing a step in reopening stdin and console configuration?
proc [namespace parent]::disableRaw {{channel stdin}} {
#variable is_raw
proc disableRaw {{channel stdin}} {
variable previous_stty_state_$channel
if {[package provide twapi] ne ""} {
set console_handle [twapi::get_console_handle stdin]
set oldmode [twapi::get_console_input_mode]
# Turn on the echo and line-editing bits
twapi::modify_console_input_mode $console_handle -lineinput 1 -echoinput 1
set newmode [twapi::get_console_input_mode]
set ch_state [chan conf $channel]
if {[dict exists $ch_state -inputmode]} {
chan conf $channel -inputmode normal
tsv::set console is_raw 0
return [list stdin [list from $oldmode to $newmode]]
} elseif {[set sttycmd [auto_execok stty]] ne ""} {
#stty can return info on windows - but doesn't seem to be able to set anything.
#review - is returned info even valid?
return [list $channel [list from [dict get $ch_state -inputmode] to normal]]
} else {
#tcl <= 8.6x doesn't support -inputmode
if {[set sttycmd [auto_execok stty]] ne ""} {
#this doesn't work on windows
#It may seem to - only because running *any* external utility can exit raw mode
set sttycmd [auto_execok stty]
if {[set previous_stty_state_$channel] ne ""} {
exec {*}$sttycmd [set previous_stty_state_$channel]
@ -571,6 +463,163 @@ namespace eval punk::console {
error "punk::console::disableRaw Unable to use twapi or stty to unset raw mode - aborting"
}
}
}
#enableAnsi
proc enableAnsi {} {
}
#disableAnsi
proc enableAnsi {} {
}
#enableVirtualTerminal
proc enableVirtualTerminal {{channels {input output}}} {
}
#disableVirtualTerminal
proc disableVirtualTerminal {{channels {input output}}} {
}
#enableProcessedInput
#disableProcessedInput
}
} else {
#non-windows platforms
proc enableAnsi {} {
#todo?
}
proc disableAnsi {} {
}
#todo - something better - the 'channel' concept may not really apply on unix, as raw mode is set for input and output modes currently - only valid to set on a readable channel?
#on windows they can be set independently (but not with stty) - REVIEW
proc enableVirtualTerminal {{channels {input output}}} {
}
proc disableVirtualTerminal {args} {
}
#NOTE - the is_raw is only being set in current interp - but the channel is shared.
#this is problematic with the repl thread being separate. - must be a tsv? REVIEW
proc enableRaw {{channel stdin}} {
#variable is_raw
variable previous_stty_state_$channel
set sttycmd [auto_execok stty]
if {[set previous_stty_state_$channel] eq ""} {
if {[catch {exec {*}$sttycmd -g <@$channel} previous_stty_state_$channel]} {
set previous_stty_state_$channel ""
}
}
exec {*}$sttycmd raw -echo <@$channel
tsv::set console is_raw 1
return [dict create previous [set previous_stty_state_$channel]]
}
proc disableRaw {{channel stdin}} {
#variable is_raw
variable previous_stty_state_$channel
set sttycmd [auto_execok stty]
if {[set previous_stty_state_$channel] ne ""} {
exec {*}$sttycmd [set previous_stty_state_$channel]
set previous_stty_state_$channel ""
tsv::set console is_raw 0
return restored
}
exec {*}$sttycmd -raw echo <@$channel
tsv::set console is_raw 0
return done
}
}
#review - document and decide granularity required. should we enable/disable more than one at once?
proc enable_mouse {} {
puts -nonewline stdout \x1b\[?1000h
puts -nonewline stdout \x1b\[?1003h
puts -nonewline stdout \x1b\[?1015h
puts -nonewline stdout \x1b\[?1006h
flush stdout
}
proc disable_mouse {} {
puts -nonewline stdout \x1b\[?1000l
puts -nonewline stdout \x1b\[?1003l
puts -nonewline stdout \x1b\[?1015l
puts -nonewline stdout \x1b\[?1006l
flush stdout
}
proc enable_bracketed_paste {} {
puts -nonewline stdout \x1b\[?2004h
}
proc disable_bracketed_paste {} {
puts -nonewline stdout \x1b\[?2004l
}
proc start_application_mode {} {
#need loop to read events?
puts -nonewline stdout \x1b\[?1049h ;#alt screen
enable_mouse
#puts -nonewline stdout \x1b\[?25l ;#hide cursor
puts -nonewline stdout \x1b\[?1003h\n
enable_bracketed_paste
}
#todo stop_application_mode {} {}
proc mode {{raw_or_line query}} {
#variable is_raw
variable ansi_available
set raw_or_line [string tolower $raw_or_line]
if {$raw_or_line eq "query"} {
if {[tsv::get console is_raw]} {
return "raw"
} else {
return "line"
}
} elseif {$raw_or_line eq "raw"} {
if {[catch {
punk::console::enableRaw
} errM]} {
puts stderr "Warning punk::console::enableRaw failed - $errM"
}
if {[can_ansi]} {
punk::console::enableVirtualTerminal both
}
} elseif {$raw_or_line eq "line"} {
#review -order. disableRaw has memory from enableRaw.. but but for line mode we want vt disabled - so call it after disableRaw (?)
if {[catch {
punk::console::disableRaw
} errM]} {
puts stderr "Warning punk::console::disableRaw failed - $errM"
}
if {[can_ansi]} {
punk::console::disableVirtualTerminal input ;#default readline arrow behaviour etc
punk::console::enableVirtualTerminal output ;#display/use ansi codes
}
} else {
error "punk::console::mode expected 'raw' or 'line' or default value 'query'"
}
}
namespace eval internal {
proc abort_if_loop {{failmsg ""}} {
#puts "il1 [info level 1]"
#puts "thisproc: [lindex [info level 0] 0]"
set would_loop [uplevel 1 {expr {[string match *loopavoidancetoken* [info body [namespace tail [lindex [info level 0] 0]]]]}}]
#puts "would_loop: $would_loop"
if {$would_loop} {
set procname [uplevel 1 {namespace tail [lindex [info level 0] 0]}]
if {$failmsg eq ""} {
set errmsg "[namespace current] Failed to redefine procedure $procname"
} else {
set errmsg $failmsg
}
error $errmsg
}
}
proc define_windows_procs {} {
}
@ -1803,7 +1852,10 @@ namespace eval punk::console {
#don't set ansi_avaliable here - we want to be able to change things, retest etc.
if {"windows" eq "$::tcl_platform(platform)"} {
if {[package provide twapi] ne ""} {
set h_out [twapi::get_console_handle stdout]
if {[catch {twapi::get_console_handle stdout} h_out]} {
puts stderr "test_can_ansi: twapi cannot get console handle for stdout"
return 0
}
set existing_mode [twapi::GetConsoleMode $h_out]
if {[expr {$existing_mode & 4}]} {
#virtual terminal processing happens to be enabled - so it's supported

58
src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/libunknown-0.1.tm
Unescape View File

@ -80,16 +80,7 @@ tcl::namespace::eval punk::libunknown {
"Experimental set of replacements for default 'package unknown' entries."
}]
variable epoch
#if {![info exists epoch]} {
# set tmstate [dict create 0 {}]
# set pkgstate [dict create 0 {}]
# set tminfo [dict create current 0 epochs $tmstate]
# set pkginfo [dict create current 0 epochs $pkgstate]
# set epoch [dict create tm $tminfo pkg $pkginfo]
#}
variable epoch ;#don't set - can be pre-set cooperatively
variable has_package_files
if {[catch {package files foobaz}]} {
@ -111,6 +102,33 @@ tcl::namespace::eval punk::libunknown {
#will use standard mechanism for non zipfs paths in the tm list.
proc zipfs_tm_UnknownHandler {original name args} {
#------------------------------
#shortcircuit for builtin static libraries which have no 'package provide' info - review
#This occurs for example when running 'bin\runtime.cmd run src\make.tcl shell' with punk902z.exe
#
#------------------------------
set loaded [lsearch -inline -index 1 -nocase [info loaded] $name]
if {[llength $loaded] == 2 && [lindex $loaded 0] eq ""} {
lassign $loaded _ cased_name
interp create ptest
ptest eval [list load {} $cased_name]
set static_version [ptest eval [list package provide [string tolower $cased_name]]]
set pname [string tolower $cased_name]
if {$static_version eq ""} {
set static_version [ptest eval [list package provide $cased_name]]
set pname $cased_name
}
if {$static_version ne ""} {
if {[package vsatisfies $static_version {*}$args]} {
package ifneeded $pname $static_version [list load {} $cased_name]
interp delete ptest
return
}
}
interp delete ptest
}
#------------------------------
# Import the list of paths to search for packages in module form.
# Import the pattern used to check package names in detail.
variable epoch
@ -1161,7 +1179,12 @@ tcl::namespace::eval punk::libunknown {
set callerposn [lsearch $args -caller]
if {$callerposn > -1} {
set caller [lindex $args $callerposn+1]
#puts stderr "\x1b\[1\;33m punk::libunknown::init - caller:$caller\x1b\[m"
if {[package provide thread] ne ""} {
set tid [thread::id]
} else {
set tid "-"
}
#puts stderr "\x1b\[1\;33m punk::libunknown::init - caller:$caller tid:$tid\x1b\[m"
#puts stderr "punk::libunknown::init auto_path : $::auto_path"
#puts stderr "punk::libunknown::init tcl::tm::list: [tcl::tm::list]"
}
@ -1184,17 +1207,17 @@ tcl::namespace::eval punk::libunknown {
puts stderr "punk::libunknown::init - init while empty/unreadable tcl::tm::list and empty/unreadable ::auto_path"
}
if {[namespace origin ::package] eq "::punk::libunknown::package"} {
#This is far from conclusive - there may be other renamers (e.g commandstack)
if {[info commands ::punk::libunknown::package] ne ""} {
puts stderr "punk::libunknown::init already done - unnecessary call? info frame -1: [info frame -1]"
return
}
#if {[namespace origin ::package] eq "::punk::libunknown::package"} {
# #This is far from conclusive - there may be other renamers (e.g commandstack)
# return
#}
if {[info commands ::punk::libunknown::package] ne ""} {
puts stderr "punk::libunknown::init already done - unnecessary call? info frame -1: [info frame -1]"
return
}
variable epoch
if {![info exists epoch]} {
set tmstate [dict create 0 {added {}}]
@ -1222,6 +1245,7 @@ tcl::namespace::eval punk::libunknown {
# or suffer additional scans.. or document ??
#ideally init should be called in each interp before any scans for packages so that the list of untracked is minimized.
set pkgnames [package names]
#puts stderr "####### punk::libunknown init called with [llength $pkgnames] package names known"
foreach p $pkgnames {
if {[string tolower $p] in {punk::libunknown tcl::zlib tcloo tcl::oo tcl}} {
continue

64
src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/repl-0.1.2.tm
Unescape View File

@ -20,18 +20,6 @@ if {[dict exists $stdin_info -mode]} {
#give up for now
set tcl_interactive 1
#if {[info commands ::tcl::zipfs::root] ne ""} {
# set zr [::tcl::zipfs::root]
# if {[file join $zr app modules] in [tcl::tm::list]} {
# #todo - better way to find latest version - without package require
# set lib [file join $zr app modules punk libunknown.tm]
# if {[file exists $lib]} {
# source $lib
# punk::libunknown::init
# #package unknown {punk::libunknown::zipfs_tm_UnknownHandler punk::libunknown::zipfs_tclPkgUnknown}
# }
# }
#}
#-------------------------------------------------------------------------------------
if {[package provide punk::libunknown] eq ""} {
#maintenance - also in src/vfs/_config/punk_main.tcl
@ -59,7 +47,7 @@ if {[package provide punk::libunknown] eq ""} {
}
if {$libunknown ne ""} {
source $libunknown
if {[catch {punk::libunknown::init -caller repl} errM]} {
if {[catch {punk::libunknown::init -caller triggered_by_repl_package_require} errM]} {
puts "error initialising punk::libunknown\n$errM"
}
}
@ -525,11 +513,11 @@ proc repl::start {inchan args} {
set donevalue [set [namespace current]::done]
if {[lindex $donevalue 0] eq "quit"} {
puts "-->repl::start end $inchan $args result:'$donevalue'"
puts stderr "--> returning [lindex $donevalue 1]"
#puts stderr "repl quit --> returning [lindex $donevalue 1]"
return [lindex $donevalue 1]
}
puts "-->repl::start end $inchan $args result:'$donevalue'"
puts stderr "__> returning 0"
#puts stderr "__> returning 0"
return 0
}
proc repl::post_operations {} {
@ -1408,7 +1396,6 @@ proc repl::repl_handler {inputchan prompt_config} {
if {[dict get $original_input_conf -inputmode] eq "raw"} {
#user or script has apparently put stdin into raw mode - update punk::console::is_raw to match
set rawmode 1
#set ::punk::console::is_raw 1
tsv::set console is_raw 1
} else {
#set ::punk::console::is_raw 0
@ -1420,9 +1407,6 @@ proc repl::repl_handler {inputchan prompt_config} {
#if it's been set to raw - assume it is deliberately done this way as the user could have alternatively called punk::mode raw or punk::console::enableVirtualTerminal
#by not doing this automatically - we assume the caller has a reason.
} else {
#JMN FIX!
#this returns 0 in rawmode on 8.6 after repl thread changes
#set rawmode [set ::punk::console::is_raw]
set rawmode [tsv::get console is_raw]
}
@ -1811,8 +1795,6 @@ proc repl::repl_process_data {inputchan chunktype chunk stdinlines prompt_config
set infoprompt [dict get $prompt_config infoprompt]
set debugprompt [dict get $prompt_config debugprompt]
#set rawmode [set ::punk::console::is_raw]
set rawmode [tsv::get console is_raw]
if {!$rawmode} {
#puts stderr "-->got [ansistring VIEW -lf 1 $stdinlines]<--"
@ -2615,6 +2597,34 @@ proc repl::repl_process_data {inputchan chunktype chunk stdinlines prompt_config
}
#editbuf
#after any external command - raw mode as the console sees it can be disabled
#set it to match current state of the tsv
if {[tsv::get console is_raw]} {
if {$::tcl_platform(platform) eq "windows"} {
#review
#we are in parent process - twapi might not be loaded here - even if it is in the code interp
catch {package require twapi}
}
set sinfo [chan configure stdin]
if {[dict exists $sinfo -inputmode]} {
if {[dict get $sinfo -inputmode] ne "raw"} {
set re_enable_required 1
} else {
set re_enable_required 0
}
} else {
# -inputmode unavailable
#tcl 8.6 doesn't have -inputmode - meaning it has to call punk:console::enableRaw each time
#enableRaw on windows without twapi involves launching a pwsh process - which gives a noticeable lag in keyboard input.
#enableRaw on Unix involves a call to stty - which is generally fast - but still to be avoided if not required.
set re_enable_required 1
}
#puts stderr "-here- re-enabling raw"
if {$re_enable_required} {
punk::console::enableRaw
}
}
} else {
#append commandstr \n
if {$::punk::repl::signal_control_c} {
@ -2828,7 +2838,7 @@ namespace eval repl {
}
if {$libunknown ne ""} {
source $libunknown
if {[catch {punk::libunknown::init -caller "repl init_script"} errM]} {
if {[catch {punk::libunknown::init -caller "repl::init init_script parent interp"} errM]} {
puts "repl::init problem - error initialising punk::libunknown\n$errM"
}
#package require punk::lib
@ -2858,10 +2868,10 @@ namespace eval repl {
#thread::send to caller defined interp targets (reference?)
#snit required for icomm
if {[catch {package require snit} errM]} {
puts stdout "punk::repl::initscript lib load fail ---snit $errM"
#puts stdout "punk::repl::initscript: lib load fail ---snit $errM"
}
if {[catch {package require punk::icomm} errM]} {
puts stdout "punk::repl::initscript lib load fail ---icomm $errM"
#puts stdout "punk::repl::initscript: lib load fail ---icomm $errM"
}
#-----
@ -2872,7 +2882,7 @@ namespace eval repl {
#first use can raise error being a version number e.g 0.1.0 - why?
lassign [tcl::chan::fifo2] ::punk::repl::codethread::repltalk replside
} errMsg]} {
puts stdout "punk::repl::initscript tcl::chan::fifo2 error: $errM"
puts stdout "punk::repl::initscript tcl::chan::fifo2 error: $errMsg"
} else {
#experimental?
#puts stdout "transferring chan $replside to thread %replthread%"
@ -3519,6 +3529,8 @@ namespace eval repl {
#-----------------------------------------------------------------------------
if {[package provide punk::libunknown] eq ""} {
namespace eval ::punk::libunknown {}
set ::punk::libunknown::epoch %lib_epoch%
set libunks [list]
foreach tm_path [tcl::tm::list] {
set punkdir [file join $tm_path punk]
@ -3543,7 +3555,7 @@ namespace eval repl {
}
if {$libunknown ne ""} {
source $libunknown
if {[catch {punk::libunknown::init -caller "repl init_script punk"} errM]} {
if {[catch {punk::libunknown::init -caller "repl::init init_script code interp for punk"} errM]} {
puts "error initialising punk::libunknown\n$errM"
}
}

157
src/project_layouts/custom/_project/punk.project-0.1/src/make.tcl
Unescape View File

@ -31,22 +31,28 @@ namespace eval ::punkboot::lib {
#for some purposes (whether a source folder is likely to have any useful content) we are interested in non dotfile/dotfolder immediate contents of a folder, but not whether a particular platform
#considers them hidden or not.
proc folder_nondotted_children {folder} {
if {![file isdirectory $folder]} {error "punkboot::lib::folder_nondotted_children error. Supplied folder '$folder' is not a directory"}
set contents [glob -nocomplain -dir $folder *]
set normfolder [file normalize $folder]
if {![file isdirectory $normfolder]} {error "punkboot::lib::folder_nondotted_children error. Supplied folder '$folder' is not a directory"}
set contents [glob -nocomplain -dir $folder -tails *]
#some platforms (windows) return dotted entries with *, although most don't
return [lsearch -all -inline -not $contents .*]
set nondotted_tails [lsearch -all -inline -not $contents .*]
return [lmap ftail $nondotted_tails {file join $folder $ftail}]
}
proc folder_nondotted_folders {folder} {
if {![file isdirectory $folder]} {error "punkboot::lib::folder_nondotted_folders error. Supplied folder '$folder' is not a directory"}
set contents [glob -nocomplain -dir $folder -types d *]
set normfolder [file normalize $folder]
if {![file isdirectory $normfolder]} {error "punkboot::lib::folder_nondotted_folders error. Supplied folder '$folder' is not a directory"}
set contents [glob -nocomplain -dir $folder -types d -tails *]
#some platforms (windows) return dotted entries with *, although most don't
return [lsearch -all -inline -not $contents .*]
set nondotted_tails [lsearch -all -inline -not $contents .*]
return [lmap ftail $nondotted_tails {file join $folder $ftail}]
}
proc folder_nondotted_files {folder} {
if {![file isdirectory $folder]} {error "punkboot::lib::folder_nondotted_files error. Supplied folder '$folder' is not a directory"}
set contents [glob -nocomplain -dir $folder -types f $folder *]
set normfolder [file normalize $folder]
if {![file isdirectory $normfolder]} {error "punkboot::lib::folder_nondotted_files error. Supplied folder '$folder' is not a directory"}
set contents [glob -nocomplain -dir $folder -types f $folder -tails *]
#some platforms (windows) return dotted entries with *, although most don't
return [lsearch -all -inline -not $contents .*]
set nondotted_tails [lsearch -all -inline -not $contents .*]
return [lmap ftail $nondotted_tails {file join $folder $ftail}]
}
proc tm_version_isvalid {versionpart} {
#Needs to be suitable for use with Tcl's 'package vcompare'
@ -289,6 +295,10 @@ if {"::try" ni [info commands ::try]} {
# This allows a source update via 'fossil update' 'git pull' etc to pull in a minimal set of support modules for the boot script
# and load these in preference to ones that may have been in the interp's tcl::tm::list or auto_path due to environment variables
set startdir [pwd]
set scriptdir [file dirname [file normalize [info script]]]
#puts "SCRIPTDIR: $scriptdir"
#we are focussed on pure-tcl libs/modules in bootsupport for now.
#There may be cases where we want to use compiled packages from src/bootsupport/modules_tcl9 etc
#REVIEW - punkboot can really speed up with appropriate accelerators and/or external binaries
@ -303,18 +313,22 @@ set bootsupport_library_paths [list]
set this_platform_generic [punkboot::lib::platform_generic]
#we always create these lists in order of desired precedence.
# - this is the same order when adding to auto_path - but will need to be reversed when using tcl:tm::add
if {[file exists [file join $startdir src bootsupport]]} {
lappend bootsupport_module_paths [file join $startdir src bootsupport modules_tcl$::tclmajorv] ;#more version-specific modules slightly higher in precedence order
lappend bootsupport_module_paths [file join $startdir src bootsupport modules]
lappend bootsupport_library_paths [file join $startdir src bootsupport lib_tcl$::tclmajorv/allplatforms] ;#more version-specific pkgs slightly higher in precedence order
lappend bootsupport_library_paths [file join $startdir src bootsupport lib_tcl$::tclmajorv/$this_platform_generic] ;#more version-specific pkgs slightly higher in precedence order
lappend bootsupport_library_paths [file join $startdir src bootsupport lib]
if {[file exists [file join $scriptdir bootsupport]]} {
set bootsupportdir [file join $scriptdir bootsupport]
puts stderr "Using bootsupport dir $bootsupportdir"
lappend bootsupport_module_paths [file join $bootsupportdir modules_tcl$::tclmajorv] ;#more version-specific modules slightly higher in precedence order
lappend bootsupport_module_paths [file join $bootsupportdir modules]
lappend bootsupport_library_paths [file join $bootsupportdir lib_tcl$::tclmajorv/allplatforms] ;#more version-specific pkgs slightly higher in precedence order
lappend bootsupport_library_paths [file join $bootsupportdir lib_tcl$::tclmajorv/$this_platform_generic] ;#more version-specific pkgs slightly higher in precedence order
lappend bootsupport_library_paths [file join $bootsupportdir lib]
} else {
lappend bootsupport_module_paths [file join $startdir bootsupport modules_tcl$::tclmajorv]
lappend bootsupport_module_paths [file join $startdir bootsupport modules]
lappend bootsupport_library_paths [file join $startdir bootsupport lib_tcl$::tclmajorv/allplatforms]
lappend bootsupport_library_paths [file join $startdir bootsupport lib_tcl$::tclmajorv/$this_platform_generic]
lappend bootsupport_library_paths [file join $startdir bootsupport lib]
puts stderr "No bootsupport dir for script [info script] at [file join $scriptdir bootsupport]"
#lappend bootsupport_module_paths [file join $startdir bootsupport modules_tcl$::tclmajorv]
#lappend bootsupport_module_paths [file join $startdir bootsupport modules]
#lappend bootsupport_library_paths [file join $startdir bootsupport lib_tcl$::tclmajorv/allplatforms]
#lappend bootsupport_library_paths [file join $startdir bootsupport lib_tcl$::tclmajorv/$this_platform_generic]
#lappend bootsupport_library_paths [file join $startdir bootsupport lib]
}
set bootsupport_paths_exist 0
foreach p [list {*}$bootsupport_module_paths {*}$bootsupport_library_paths] {
@ -406,8 +420,8 @@ if {$bootsupport_paths_exist || $sourcesupport_paths_exist} {
tcl::tm::add {*}[lreverse $bootsupport_module_paths] {*}[lreverse $sourcesupport_module_paths] ;#tm::add works like LIFO. sourcesupport_module_paths end up earliest in resulting tm list.
set ::auto_path [list {*}$sourcesupport_library_paths {*}$bootsupport_library_paths]
}
puts "----> auto_path $::auto_path"
puts "----> tcl::tm::list [tcl::tm::list]"
#puts "----> auto_path $::auto_path"
#puts "----> tcl::tm::list [tcl::tm::list]"
#maint: also in punk::repl package
#--------------------------------------------------------
@ -435,22 +449,26 @@ if {$bootsupport_paths_exist || $sourcesupport_paths_exist} {
}
if {$libunknown ne ""} {
source $libunknown
if {[catch {punk::libunknown::init -caller main.tcl} errM]} {
puts "error initialising punk::libunknown\n$errM"
if {[catch {punk::libunknown::init -caller make.tcl} errM]} {
puts stderr "error initialising punk::libunknown\n$errM"
}
#puts stdout " *** [package names]"
#puts stdout " **** [dict get $::punk::libunknown::epoch pkg untracked]"
} else {
puts stderr "Failed to find punk::libunknown"
}
#--------------------------------------------------------
#package require Thread
puts "---->tcl_library [info library]"
puts "---->loaded [info loaded]"
#puts "---->tcl_library [info library]"
#puts "---->loaded [info loaded]"
# - the full repl requires Threading and punk,shellfilter,shellrun to call and display properly.
# tm list already indexed - need 'package forget' to find modules based on current tcl::tm::list
#These are strong dependencies
package forget punk::mix
package forget punk::repo
package forget punkcheck
#package forget punk::mix
#package forget punk::repo
#package forget punkcheck
package require punk::repo ;#todo - push our requirements to a smaller punk::repo::xxx package with minimal dependencies
package require punk::mix
@ -464,6 +482,7 @@ if {$bootsupport_paths_exist || $sourcesupport_paths_exist} {
set package_paths_modified 1
#------------------------------------------------------------------------------
#puts "----> llength package names [llength [package names]]"
}
set ::punkboot::pkg_requirements_found [list]
@ -479,7 +498,9 @@ set ::punkboot::bootsupport_requirements [dict create\
punkcheck [list]\
fauxlink [list version "0.1.1-"]\
textblock [list version 0.1.1-]\
fileutil [list]\
fileutil::traverse [list]\
struct::list [list]\
md5 [list version 2-]\
]
@ -1282,7 +1303,41 @@ proc ::punkboot::punkboot_gethelp {args} {
return $h
}
set scriptargs $::argv
punk::args::define {
@id -id punkmake
@cmd -name punkmake\
-summary\
"Project builder"\
-help\
""
@form -form help
@leaders
subcommand -type "literal(help)"
@opts
@values
what -type string -choices {modules libs shell}
@form -form modules
subcommand -type "literal(modules)"
@form -form libs
subcommand -type "literal(libs)"
@form -form shell
subcommand -type "literal(shell)"
arg -type any -optional 1 -multiple 1
}
#set argd [punk::args::parse $scriptargs -form 0 withid punkmake]
##lassign [dict values $argd] leaders opts values received
#
#puts stdout [punk::args::usage -scheme nocolour punkmake]
#exit 1
set do_help 0
if {![llength $scriptargs]} {
set do_help 1
@ -1294,6 +1349,8 @@ if {![llength $scriptargs]} {
}
}
}
set commands_found [list]
foreach a $scriptargs {
if {![string match -* $a]} {
@ -1310,6 +1367,8 @@ if {[llength $commands_found] != 1 } {
puts stderr "Unknown command: [lindex $commands_found 0]\n\n"
set do_help 1
}
if {$do_help} {
puts stdout "Checking package availability..."
set ::punkboot::pkg_availability [::punkboot::check_package_availability -quiet 1 $::punkboot::bootsupport_requirements]
@ -1325,6 +1384,8 @@ if {$do_help} {
exit 0
}
set ::punkboot::command [lindex $commands_found 0]
@ -1414,14 +1475,15 @@ if {$::punkboot::command eq "check"} {
if {$package_paths_modified} {
set tm_list_boot [tcl::tm::list]
tcl::tm::remove {*}$tm_list_boot
foreach p [lreverse $original_tm_list] {
set lower_prio [list]
foreach p $original_tm_list {
if {$p ni $tm_list_boot} {
tcl::tm::add $p
}
lappend lower_prio $p
}
foreach p [lreverse $tm_list_boot] {
tcl::tm::add $p
}
tcl::tm::add {*}[lreverse $lower_prio] {*}[lreverse $tm_list_boot]
#set ::auto_path [list $bootsupport_lib {*}$original_auto_path]
lappend ::auto_path {*}$original_auto_path
}
@ -1489,6 +1551,28 @@ if {![array size A]} {
punkboot::define_global_ansi
}
#puts stderr ">>>>>>+ loaded:[info loaded]"
#puts stderr "llength package names: [llength [package names]]"
if {[info exists ::punk::libunknown::epoch]} {
set untracked [dict get $::punk::libunknown::epoch pkg untracked]
#puts stderr "punk::libunknown::epoch exists"
} else {
set untracked [list]
#puts stderr "punk::libunknown::epoch does not exist"
}
#REVIEW - we shouldn't need to manually set the untracked packages - punk::libunknown::init should have done it?
foreach p [package names] {
if {![dict exists $untracked $p]} {
dict set untracked $p ""
}
}
dict set ::punk::libunknown::epoch pkg untracked $untracked
if {[package provide punk::libunknown] eq ""} {
puts "punk::libunknown not loaded"
} else {
puts "punk::libunknown loaded"
}
dict for {pkg pkginfo} $::punkboot::bootsupport_requirements {
set verspec [dict get $pkginfo version] ;#version wanted specification always exists and is empty or normalised
if {[catch {package require $pkg {*}$verspec} errM]} {
@ -1557,14 +1641,13 @@ if {$::punkboot::command eq "info"} {
if {$::punkboot::command eq "shell"} {
puts stderr ">>>>>> loaded:[info loaded]"
package require struct::list
package require punk
package require punk::repl
#todo - make procs vars etc from this file available?
puts stderr "punk boot shell not implemented - dropping into ordinary punk shell."
repl::init
set replresult [repl::start stdin -title make.tcl]
#review
@ -3059,6 +3142,8 @@ foreach vfstail $vfs_tails {
exec {*}$::sdxpath unwrap [file rootname $building_runtime].tail ;#extracts to folder named [file rootname $building_runtime].vfs e.g build_tclkit9.0.2-win64-dyn.vfs
#file rename to existing target dir would copy folder into target dir
if {![file exists $targetvfs]} {
#delay
after 1000
file rename [file rootname $building_runtime].vfs $targetvfs
} else {
merge_over [file rootname $building_runtime].vfs $targetvfs

5
src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/args-0.2.tm
Unescape View File

@ -3036,8 +3036,11 @@ tcl::namespace::eval punk::args {
#This mechanism gets less-than-useful results for oo methods
#e.g {$obj}
proc Get_caller {} {
set depth [info level]
set maxd [expr {min($depth,4)}]
set call_level [expr {-1 * $maxd}]
#set call_level -3 ;#for get_dict call
set call_level -4
#set call_level -4
set cmdinfo [tcl::dict::get [tcl::info::frame $call_level] cmd]
#puts "-->$cmdinfo"
#puts "-->[tcl::info::frame -3]"

2
src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/args/tclcore-0.1.0.tm
Unescape View File

@ -3498,7 +3498,7 @@ tcl::namespace::eval punk::args::tclcore {
example, in ${$B}-dictionary${$N} mode, bigBoy sorts between bigbang and bigboy,
and x10y sorts between x9y and x11y. Overrides the ${$B}-nocase${$N} option."
-integer -type none -help\
"Convert list elements to integers and use integer comparsion."
"Convert list elements to integers and use integer comparison."
-real -type none -help\
"Convert list elements to floating-point values and use floating comparison."
-command -type string -help\

556
src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/console-0.1.1.tm
Unescape View File

@ -132,216 +132,22 @@ namespace eval punk::console {
if {"windows" eq $::tcl_platform(platform)} {
#accept args for all dummy/load functions so we don't have to match/update argument signatures here
set has_twapi [expr {! [catch {package require twapi}]}]
proc enableAnsi {args} {
#loopavoidancetoken (don't remove)
internal::define_windows_procs
internal::abort_if_loop
tailcall enableAnsi {*}$args
}
#review what raw mode means with regard to a specific channel vs terminal as a whole
proc enableRaw {args} {
#loopavoidancetoken (don't remove)
internal::define_windows_procs
internal::abort_if_loop
tailcall enableRaw {*}$args
}
proc disableRaw {args} {
#loopavoidancetoken (don't remove)
internal::define_windows_procs
internal::abort_if_loop
tailcall disableRaw {*}$args
}
proc enableVirtualTerminal {args} {
#loopavoidancetoken (don't remove)
internal::define_windows_procs
internal::abort_if_loop
tailcall enableVirtualTerminal {*}$args
}
proc disableVirtualTerminal {args} {
#loopavoidancetoken (don't remove)
internal::define_windows_procs
internal::abort_if_loop
tailcall disableVirtualTerminal {*}$args
}
set funcs [list disableAnsi enableProcessedInput disableProcessedInput]
foreach f $funcs {
proc $f {args} [string map [list %f% $f] {
set mybody [info body %f%]
internal::define_windows_procs
set newbody [info body %f%]
if {$newbody ne $mybody} {
tailcall %f% {*}$args
} else {
#error vs noop?
puts stderr "Unable to set implementation for %f% - check twapi?"
}
}]
}
} else {
proc enableAnsi {} {
#todo?
}
proc disableAnsi {} {
}
#todo - something better - the 'channel' concept may not really apply on unix, as raw mode is set for input and output modes currently - only valid to set on a readable channel?
#on windows they can be set independently (but not with stty) - REVIEW
#NOTE - the is_raw is only being set in current interp - but the channel is shared.
#this is problematic with the repl thread being separate. - must be a tsv? REVIEW
proc enableRaw {{channel stdin}} {
#variable is_raw
variable previous_stty_state_$channel
set sttycmd [auto_execok stty]
if {[set previous_stty_state_$channel] eq ""} {
if {[catch {exec {*}$sttycmd -g <@$channel} previous_stty_state_$channel]} {
set previous_stty_state_$channel ""
}
}
exec {*}$sttycmd raw -echo <@$channel
tsv::set console is_raw 1
return [dict create previous [set previous_stty_state_$channel]]
}
proc disableRaw {{channel stdin}} {
#variable is_raw
variable previous_stty_state_$channel
set sttycmd [auto_execok stty]
if {[set previous_stty_state_$channel] ne ""} {
exec {*}$sttycmd [set previous_stty_state_$channel]
set previous_stty_state_$channel ""
tsv::set console is_raw 0
return restored
}
exec {*}$sttycmd -raw echo <@$channel
tsv::set console is_raw 0
return done
}
proc enableVirtualTerminal {{channels {input output}}} {
}
proc disableVirtualTerminal {args} {
}
}
#review - document and decide granularity required. should we enable/disable more than one at once?
proc enable_mouse {} {
puts -nonewline stdout \x1b\[?1000h
puts -nonewline stdout \x1b\[?1003h
puts -nonewline stdout \x1b\[?1015h
puts -nonewline stdout \x1b\[?1006h
flush stdout
}
proc disable_mouse {} {
puts -nonewline stdout \x1b\[?1000l
puts -nonewline stdout \x1b\[?1003l
puts -nonewline stdout \x1b\[?1015l
puts -nonewline stdout \x1b\[?1006l
flush stdout
}
proc enable_bracketed_paste {} {
puts -nonewline stdout \x1b\[?2004h
}
proc disable_bracketed_paste {} {
puts -nonewline stdout \x1b\[?2004l
}
proc start_application_mode {} {
#need loop to read events?
puts -nonewline stdout \x1b\[?1049h ;#alt screen
enable_mouse
#puts -nonewline stdout \x1b\[?25l ;#hide cursor
puts -nonewline stdout \x1b\[?1003h\n
enable_bracketed_paste
}
#todo stop_application_mode {} {}
proc mode {{raw_or_line query}} {
#variable is_raw
variable ansi_available
set raw_or_line [string tolower $raw_or_line]
if {$raw_or_line eq "query"} {
if {[tsv::get console is_raw]} {
return "raw"
} else {
return "line"
}
} elseif {$raw_or_line eq "raw"} {
if {[catch {
punk::console::enableRaw
} errM]} {
puts stderr "Warning punk::console::enableRaw failed - $errM"
}
if {[can_ansi]} {
punk::console::enableVirtualTerminal both
}
} elseif {$raw_or_line eq "line"} {
#review -order. disableRaw has memory from enableRaw.. but but for line mode we want vt disabled - so call it after disableRaw (?)
if {[catch {
punk::console::disableRaw
} errM]} {
puts stderr "Warning punk::console::disableRaw failed - $errM"
}
if {[can_ansi]} {
punk::console::disableVirtualTerminal input ;#default readline arrow behaviour etc
punk::console::enableVirtualTerminal output ;#display/use ansi codes
}
} else {
error "punk::console::mode expected 'raw' or 'line' or default value 'query'"
}
}
namespace eval internal {
proc abort_if_loop {{failmsg ""}} {
#puts "il1 [info level 1]"
#puts "thisproc: [lindex [info level 0] 0]"
set would_loop [uplevel 1 {expr {[string match *loopavoidancetoken* [info body [namespace tail [lindex [info level 0] 0]]]]}}]
#puts "would_loop: $would_loop"
if {$would_loop} {
set procname [uplevel 1 {namespace tail [lindex [info level 0] 0]}]
if {$failmsg eq ""} {
set errmsg "[namespace current] Failed to redefine procedure $procname"
} else {
set errmsg $failmsg
}
error $errmsg
}
}
proc define_windows_procs {} {
package require zzzload
set loadstate [zzzload::pkg_require twapi]
#loadstate could also be stuck on loading? - review - zzzload not very ripe
#Twapi can be relatively slow to load (on some systems) - can be 1s plus in some cases - and much longer if there are disk performance issues.
if {$loadstate ni [list failed]} {
#possibly still 'loading'
#review zzzload usage
#puts stdout "=========== console loading twapi ============="
set loadstate [zzzload::pkg_wait twapi] ;#can return 'failed' will return version if already loaded or loaded during wait
}
if {$loadstate ni [list failed]} {
package require twapi ;#should be fast once twapi dll loaded in zzzload thread
set ::punk::console::has_twapi 1
#todo - move some of these to the punk::console::local sub-namespace - as they use APIs rather than in-band ANSI to do their work.
#enableAnsi seems like it should be directly under punk::console .. but then it seems inconsistent if other local console-mode setting functions aren't.
#Find a compromise to organise things somewhat sensibly..
if {$has_twapi} {
#this is really enableAnsi *processing*
proc [namespace parent]::enableAnsi {} {
proc enableAnsi {} {
#output handle modes
#Enable virtual terminal processing (sometimes off in older windows terminals)
#ENABLE_PROCESSED_OUTPUT = 0x0001
#ENABLE_WRAP_AT_EOL_OUTPUT = 0x0002
#ENABLE_VIRTUAL_TERMINAL_PROCESSING = 0x0004
#DISABLE_NEWLINE_AUTO_RETURN = 0x0008
set h_out [twapi::get_console_handle stdout]
if {[catch {twapi::get_console_handle stdout} h_out]} {
puts stderr "enableAnsi failed: twapi cannot get console handle for stdout"
return
}
set oldmode_out [twapi::GetConsoleMode $h_out]
set newmode_out [expr {$oldmode_out | 4}] ;#don't enable processed output too, even though it's required. keep symmetrical with disableAnsi?
@ -366,7 +172,7 @@ namespace eval punk::console {
return [list stdout [list from $oldmode_out to $newmode_out] stdin [list from $oldmode_in to $newmode_in]]
}
proc [namespace parent]::disableAnsi {} {
proc disableAnsi {} {
set h_out [twapi::get_console_handle stdout]
set oldmode_out [twapi::GetConsoleMode $h_out]
set newmode_out [expr {$oldmode_out & ~4}]
@ -381,9 +187,7 @@ namespace eval punk::console {
return [list stdout [list from $oldmode_out to $newmode_out] stdin [list from $oldmode_in to $newmode_in]]
}
#
proc [namespace parent]::enableVirtualTerminal {{channels {input output}}} {
proc enableVirtualTerminal {{channels {input output}}} {
set ins [list in input stdin]
set outs [list out output stdout stderr]
set known [concat $ins $outs both]
@ -424,7 +228,8 @@ namespace eval punk::console {
return $result
}
proc [namespace parent]::disableVirtualTerminal {{channels {input output}}} {
proc disableVirtualTerminal {{channels {input output}}} {
set ins [list in input stdin]
set outs [list out output stdout stderr]
set known [concat $ins $outs both]
@ -465,65 +270,158 @@ namespace eval punk::console {
#return [list stdout [list from $oldmode_out to $newmode_out] stdin [list from $oldmode_in to $newmode_in]]
return $result
}
proc [namespace parent]::enableProcessedInput {} {
proc enableProcessedInput {} {
set h_in [twapi::get_console_handle stdin]
set oldmode_in [twapi::GetConsoleMode $h_in]
set newmode_in [expr {$oldmode_in | 1}]
twapi::SetConsoleMode $h_in $newmode_in
return [list stdin [list from $oldmode_in to $newmode_in]]
}
proc [namespace parent]::disableProcessedInput {} {
proc disableProcessedInput {} {
set h_in [twapi::get_console_handle stdin]
set oldmode_in [twapi::GetConsoleMode $h_in]
set newmode_in [expr {$oldmode_in & ~1}]
twapi::SetConsoleMode $h_in $newmode_in
return [list stdin [list from $oldmode_in to $newmode_in]]
}
proc enableRaw {{channel stdin}} {
#variable is_raw
variable previous_stty_state_$channel
if {[catch {twapi::get_console_handle stdin} console_handle]} {
puts stderr "enableRaw error: twapi cannot get console handle for stdin"
#review. If twapi couldn't get a console handle - no point trying other mechanisms(?)
return
}
#returns dictionary
#e.g -processedinput 1 -lineinput 1 -echoinput 1 -windowinput 0 -mouseinput 0 -insertmode 1 -quickeditmode 1 -extendedmode 1 -autoposition 0
set oldmode [twapi::get_console_input_mode]
twapi::modify_console_input_mode $console_handle -lineinput 0 -echoinput 0
# Turn off the echo and line-editing bits
#set newmode [dict merge $oldmode [dict create -lineinput 0 -echoinput 0]]
set newmode [twapi::get_console_input_mode]
tsv::set console is_raw 1
#don't disable handler - it will detect is_raw
### twapi::set_console_control_handler {}
return [list stdin [list from $oldmode to $newmode]]
}
} else {
#note: twapi GetStdHandle & GetConsoleMode & SetConsoleCombo unreliable - fails with invalid handle (somewhat intermittent.. after stdin reopened?)
#could be we were missing a step in reopening stdin and console configuration?
puts stderr "punk::console falling back to stty because twapi load failed"
proc [namespace parent]::enableAnsi {} {
puts stderr "punk::console::enableAnsi todo"
}
proc [namespace parent]::disableAnsi {} {
proc disableRaw {{channel stdin}} {
#variable is_raw
variable previous_stty_state_$channel
set ch_state [chan conf $channel]
if {[dict exists $ch_state -inputmode]} {
chan conf $channel -inputmode normal
tsv::set console is_raw 0
return [list $channel [list from [dict get $ch_state -inputmode] to normal]]
} else {
if {[catch {twapi::get_console_handle stdin} console_handle]} {
#e.g tkcon/wish
puts stderr "disableRaw error: twapi cannot get console handle for stdin"
return ;# ???
}
#?
proc [namespace parent]::enableVirtualTerminal {{channels {input output}}} {
set oldmode [twapi::get_console_input_mode]
# Turn on the echo and line-editing bits
twapi::modify_console_input_mode $console_handle -lineinput 1 -echoinput 1
set newmode [twapi::get_console_input_mode]
tsv::set console is_raw 0
return [list stdin [list from $oldmode to $newmode]]
}
proc [namespace parent]::disableVirtualTerminal {{channels {input output}}} {
}
proc [namespace parent]::enableProcessedInput {args} {
}
proc [namespace parent]::disableProcessedInput {args} {
} else {
variable ps_consolemode_pid
variable ps_consolemode_contents
variable ps_pipename
if {![info exists ps_consolemode_contents]} {
#start persistent powershell consolemode_server.ps1 named pipe server
if {$::argv0 ne ""} {
set pstooldir [file dirname [file dirname [file normalize $::argv0]]]/scriptlib/utils/pwsh
} else {
set pstooldir [pwd]
}
#set ps_script $pstooldir/consolemode_server.ps1
set ps_script $pstooldir/consolemode_server_async.ps1
if {[file exists $ps_script]} {
set fd [open $ps_script r]
chan configure $fd -translation binary
set ps_consoleid [pid]-[expr {int(999 * rand())+1}]
set ps_consolemode_contents [string map [list "<punkshell_consoleid>" $ps_consoleid] [read $fd]]
close $fd
#set ps_consolemode_pipe [twapi::namedpipe_client {//./pipe/punkshell_ps_consolemode} -access write]
#set ps_cmd [auto_execok pwsh.exe]
set ps_cmd [auto_execok pwsh.exe]
if {$ps_cmd eq ""} {
set ps_cmd [auto_execok powershell.exe]
}
if {$ps_cmd ne ""} {
set ps_consolemode_pid [exec {*}$ps_cmd -nop -nol -c $ps_consolemode_contents &]
set ps_pipename {\\.\pipe\punkshell_ps_consolemode_}
append ps_pipename $ps_consoleid
puts stderr "twapi not present, using persistent powershell process: pipename: $ps_pipename pid: $ps_consolemode_pid"
#todo - taskkill /F /PID $ps_consolemode_pid
#when?
#review
#if {[catch {puts "pidinfo: [::tcl::process::status $ps_consolemode_pid]"} errM]} {
# puts stderr "--- failed to get process status for $ps_consolemode_pid\n$errM"
#}
#set p [open {\\.\pipe\punkshell_ps_consolemode} w]
#chan conf $p -buffering none -blocking 1
#puts $p ""
#close $p
}
}
}
proc [namespace parent]::enableRaw {{channel stdin}} {
#enableRaw
proc enableRaw {{channel stdin}} {
#puts stderr "punk::console::enableRaw"
#variable is_raw
variable previous_stty_state_$channel
variable ps_consolemode_contents
variable ps_pipename
if {[package provide twapi] ne ""} {
set console_handle [twapi::get_console_handle stdin]
#returns dictionary
#e.g -processedinput 1 -lineinput 1 -echoinput 1 -windowinput 0 -mouseinput 0 -insertmode 1 -quickeditmode 1 -extendedmode 1 -autoposition 0
set oldmode [twapi::get_console_input_mode]
twapi::modify_console_input_mode $console_handle -lineinput 0 -echoinput 0
# Turn off the echo and line-editing bits
#set newmode [dict merge $oldmode [dict create -lineinput 0 -echoinput 0]]
set newmode [twapi::get_console_input_mode]
if {[info exists ps_consolemode_contents]} {
#ps_pipename e.g \\.\pipe\punkwinshell_ps_consolemode_12345-1223456
set trynum 0
set wrote 0
while {$trynum < 5} {
incr trynum
if {![catch {
set pipe [open $ps_pipename w]
} errMsg]} {
chan conf $pipe -buffering line
puts -nonewline $pipe "enableraw\r\n"
#flush $pipe
#after 10
#close $pipe
set wrote 1
break
} else {
after 100
}
}
if {$wrote} {
tsv::set console is_raw 1
#don't disable handler - it will detect is_raw
### twapi::set_console_control_handler {}
return [list stdin [list from $oldmode to $newmode]]
after 100
close $pipe
} else {
puts stderr "write to $ps_pipename failed trynum: $trynum\n$errMsg"
}
} elseif {[set sttycmd [auto_execok stty]] ne ""} {
#todo - something else entirely
#this approach does not work on windows
#the msys/cygwin stty command is launched as a subprocess - can be used to retrieve info
# but seems to be useless as far as affecting the calling process/console
if {[set previous_stty_state_$channel] eq ""} {
set previous_stty_state_$channel [exec {*}$sttycmd -g <@$channel]
}
@ -537,25 +435,19 @@ namespace eval punk::console {
}
}
#note: twapi GetStdHandle & GetConsoleMode & SetConsoleCombo unreliable - fails with invalid handle (somewhat intermittent.. after stdin reopened?)
#could be we were missing a step in reopening stdin and console configuration?
proc [namespace parent]::disableRaw {{channel stdin}} {
#variable is_raw
proc disableRaw {{channel stdin}} {
variable previous_stty_state_$channel
if {[package provide twapi] ne ""} {
set console_handle [twapi::get_console_handle stdin]
set oldmode [twapi::get_console_input_mode]
# Turn on the echo and line-editing bits
twapi::modify_console_input_mode $console_handle -lineinput 1 -echoinput 1
set newmode [twapi::get_console_input_mode]
set ch_state [chan conf $channel]
if {[dict exists $ch_state -inputmode]} {
chan conf $channel -inputmode normal
tsv::set console is_raw 0
return [list stdin [list from $oldmode to $newmode]]
} elseif {[set sttycmd [auto_execok stty]] ne ""} {
#stty can return info on windows - but doesn't seem to be able to set anything.
#review - is returned info even valid?
return [list $channel [list from [dict get $ch_state -inputmode] to normal]]
} else {
#tcl <= 8.6x doesn't support -inputmode
if {[set sttycmd [auto_execok stty]] ne ""} {
#this doesn't work on windows
#It may seem to - only because running *any* external utility can exit raw mode
set sttycmd [auto_execok stty]
if {[set previous_stty_state_$channel] ne ""} {
exec {*}$sttycmd [set previous_stty_state_$channel]
@ -571,6 +463,163 @@ namespace eval punk::console {
error "punk::console::disableRaw Unable to use twapi or stty to unset raw mode - aborting"
}
}
}
#enableAnsi
proc enableAnsi {} {
}
#disableAnsi
proc enableAnsi {} {
}
#enableVirtualTerminal
proc enableVirtualTerminal {{channels {input output}}} {
}
#disableVirtualTerminal
proc disableVirtualTerminal {{channels {input output}}} {
}
#enableProcessedInput
#disableProcessedInput
}
} else {
#non-windows platforms
proc enableAnsi {} {
#todo?
}
proc disableAnsi {} {
}
#todo - something better - the 'channel' concept may not really apply on unix, as raw mode is set for input and output modes currently - only valid to set on a readable channel?
#on windows they can be set independently (but not with stty) - REVIEW
proc enableVirtualTerminal {{channels {input output}}} {
}
proc disableVirtualTerminal {args} {
}
#NOTE - the is_raw is only being set in current interp - but the channel is shared.
#this is problematic with the repl thread being separate. - must be a tsv? REVIEW
proc enableRaw {{channel stdin}} {
#variable is_raw
variable previous_stty_state_$channel
set sttycmd [auto_execok stty]
if {[set previous_stty_state_$channel] eq ""} {
if {[catch {exec {*}$sttycmd -g <@$channel} previous_stty_state_$channel]} {
set previous_stty_state_$channel ""
}
}
exec {*}$sttycmd raw -echo <@$channel
tsv::set console is_raw 1
return [dict create previous [set previous_stty_state_$channel]]
}
proc disableRaw {{channel stdin}} {
#variable is_raw
variable previous_stty_state_$channel
set sttycmd [auto_execok stty]
if {[set previous_stty_state_$channel] ne ""} {
exec {*}$sttycmd [set previous_stty_state_$channel]
set previous_stty_state_$channel ""
tsv::set console is_raw 0
return restored
}
exec {*}$sttycmd -raw echo <@$channel
tsv::set console is_raw 0
return done
}
}
#review - document and decide granularity required. should we enable/disable more than one at once?
proc enable_mouse {} {
puts -nonewline stdout \x1b\[?1000h
puts -nonewline stdout \x1b\[?1003h
puts -nonewline stdout \x1b\[?1015h
puts -nonewline stdout \x1b\[?1006h
flush stdout
}
proc disable_mouse {} {
puts -nonewline stdout \x1b\[?1000l
puts -nonewline stdout \x1b\[?1003l
puts -nonewline stdout \x1b\[?1015l
puts -nonewline stdout \x1b\[?1006l
flush stdout
}
proc enable_bracketed_paste {} {
puts -nonewline stdout \x1b\[?2004h
}
proc disable_bracketed_paste {} {
puts -nonewline stdout \x1b\[?2004l
}
proc start_application_mode {} {
#need loop to read events?
puts -nonewline stdout \x1b\[?1049h ;#alt screen
enable_mouse
#puts -nonewline stdout \x1b\[?25l ;#hide cursor
puts -nonewline stdout \x1b\[?1003h\n
enable_bracketed_paste
}
#todo stop_application_mode {} {}
proc mode {{raw_or_line query}} {
#variable is_raw
variable ansi_available
set raw_or_line [string tolower $raw_or_line]
if {$raw_or_line eq "query"} {
if {[tsv::get console is_raw]} {
return "raw"
} else {
return "line"
}
} elseif {$raw_or_line eq "raw"} {
if {[catch {
punk::console::enableRaw
} errM]} {
puts stderr "Warning punk::console::enableRaw failed - $errM"
}
if {[can_ansi]} {
punk::console::enableVirtualTerminal both
}
} elseif {$raw_or_line eq "line"} {
#review -order. disableRaw has memory from enableRaw.. but but for line mode we want vt disabled - so call it after disableRaw (?)
if {[catch {
punk::console::disableRaw
} errM]} {
puts stderr "Warning punk::console::disableRaw failed - $errM"
}
if {[can_ansi]} {
punk::console::disableVirtualTerminal input ;#default readline arrow behaviour etc
punk::console::enableVirtualTerminal output ;#display/use ansi codes
}
} else {
error "punk::console::mode expected 'raw' or 'line' or default value 'query'"
}
}
namespace eval internal {
proc abort_if_loop {{failmsg ""}} {
#puts "il1 [info level 1]"
#puts "thisproc: [lindex [info level 0] 0]"
set would_loop [uplevel 1 {expr {[string match *loopavoidancetoken* [info body [namespace tail [lindex [info level 0] 0]]]]}}]
#puts "would_loop: $would_loop"
if {$would_loop} {
set procname [uplevel 1 {namespace tail [lindex [info level 0] 0]}]
if {$failmsg eq ""} {
set errmsg "[namespace current] Failed to redefine procedure $procname"
} else {
set errmsg $failmsg
}
error $errmsg
}
}
proc define_windows_procs {} {
}
@ -1803,7 +1852,10 @@ namespace eval punk::console {
#don't set ansi_avaliable here - we want to be able to change things, retest etc.
if {"windows" eq "$::tcl_platform(platform)"} {
if {[package provide twapi] ne ""} {
set h_out [twapi::get_console_handle stdout]
if {[catch {twapi::get_console_handle stdout} h_out]} {
puts stderr "test_can_ansi: twapi cannot get console handle for stdout"
return 0
}
set existing_mode [twapi::GetConsoleMode $h_out]
if {[expr {$existing_mode & 4}]} {
#virtual terminal processing happens to be enabled - so it's supported

58
src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/libunknown-0.1.tm
Unescape View File

@ -80,16 +80,7 @@ tcl::namespace::eval punk::libunknown {
"Experimental set of replacements for default 'package unknown' entries."
}]
variable epoch
#if {![info exists epoch]} {
# set tmstate [dict create 0 {}]
# set pkgstate [dict create 0 {}]
# set tminfo [dict create current 0 epochs $tmstate]
# set pkginfo [dict create current 0 epochs $pkgstate]
# set epoch [dict create tm $tminfo pkg $pkginfo]
#}
variable epoch ;#don't set - can be pre-set cooperatively
variable has_package_files
if {[catch {package files foobaz}]} {
@ -111,6 +102,33 @@ tcl::namespace::eval punk::libunknown {
#will use standard mechanism for non zipfs paths in the tm list.
proc zipfs_tm_UnknownHandler {original name args} {
#------------------------------
#shortcircuit for builtin static libraries which have no 'package provide' info - review
#This occurs for example when running 'bin\runtime.cmd run src\make.tcl shell' with punk902z.exe
#
#------------------------------
set loaded [lsearch -inline -index 1 -nocase [info loaded] $name]
if {[llength $loaded] == 2 && [lindex $loaded 0] eq ""} {
lassign $loaded _ cased_name
interp create ptest
ptest eval [list load {} $cased_name]
set static_version [ptest eval [list package provide [string tolower $cased_name]]]
set pname [string tolower $cased_name]
if {$static_version eq ""} {
set static_version [ptest eval [list package provide $cased_name]]
set pname $cased_name
}
if {$static_version ne ""} {
if {[package vsatisfies $static_version {*}$args]} {
package ifneeded $pname $static_version [list load {} $cased_name]
interp delete ptest
return
}
}
interp delete ptest
}
#------------------------------
# Import the list of paths to search for packages in module form.
# Import the pattern used to check package names in detail.
variable epoch
@ -1161,7 +1179,12 @@ tcl::namespace::eval punk::libunknown {
set callerposn [lsearch $args -caller]
if {$callerposn > -1} {
set caller [lindex $args $callerposn+1]
#puts stderr "\x1b\[1\;33m punk::libunknown::init - caller:$caller\x1b\[m"
if {[package provide thread] ne ""} {
set tid [thread::id]
} else {
set tid "-"
}
#puts stderr "\x1b\[1\;33m punk::libunknown::init - caller:$caller tid:$tid\x1b\[m"
#puts stderr "punk::libunknown::init auto_path : $::auto_path"
#puts stderr "punk::libunknown::init tcl::tm::list: [tcl::tm::list]"
}
@ -1184,17 +1207,17 @@ tcl::namespace::eval punk::libunknown {
puts stderr "punk::libunknown::init - init while empty/unreadable tcl::tm::list and empty/unreadable ::auto_path"
}
if {[namespace origin ::package] eq "::punk::libunknown::package"} {
#This is far from conclusive - there may be other renamers (e.g commandstack)
if {[info commands ::punk::libunknown::package] ne ""} {
puts stderr "punk::libunknown::init already done - unnecessary call? info frame -1: [info frame -1]"
return
}
#if {[namespace origin ::package] eq "::punk::libunknown::package"} {
# #This is far from conclusive - there may be other renamers (e.g commandstack)
# return
#}
if {[info commands ::punk::libunknown::package] ne ""} {
puts stderr "punk::libunknown::init already done - unnecessary call? info frame -1: [info frame -1]"
return
}
variable epoch
if {![info exists epoch]} {
set tmstate [dict create 0 {added {}}]
@ -1222,6 +1245,7 @@ tcl::namespace::eval punk::libunknown {
# or suffer additional scans.. or document ??
#ideally init should be called in each interp before any scans for packages so that the list of untracked is minimized.
set pkgnames [package names]
#puts stderr "####### punk::libunknown init called with [llength $pkgnames] package names known"
foreach p $pkgnames {
if {[string tolower $p] in {punk::libunknown tcl::zlib tcloo tcl::oo tcl}} {
continue

64
src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/repl-0.1.2.tm
Unescape View File

@ -20,18 +20,6 @@ if {[dict exists $stdin_info -mode]} {
#give up for now
set tcl_interactive 1
#if {[info commands ::tcl::zipfs::root] ne ""} {
# set zr [::tcl::zipfs::root]
# if {[file join $zr app modules] in [tcl::tm::list]} {
# #todo - better way to find latest version - without package require
# set lib [file join $zr app modules punk libunknown.tm]
# if {[file exists $lib]} {
# source $lib
# punk::libunknown::init
# #package unknown {punk::libunknown::zipfs_tm_UnknownHandler punk::libunknown::zipfs_tclPkgUnknown}
# }
# }
#}
#-------------------------------------------------------------------------------------
if {[package provide punk::libunknown] eq ""} {
#maintenance - also in src/vfs/_config/punk_main.tcl
@ -59,7 +47,7 @@ if {[package provide punk::libunknown] eq ""} {
}
if {$libunknown ne ""} {
source $libunknown
if {[catch {punk::libunknown::init -caller repl} errM]} {
if {[catch {punk::libunknown::init -caller triggered_by_repl_package_require} errM]} {
puts "error initialising punk::libunknown\n$errM"
}
}
@ -525,11 +513,11 @@ proc repl::start {inchan args} {
set donevalue [set [namespace current]::done]
if {[lindex $donevalue 0] eq "quit"} {
puts "-->repl::start end $inchan $args result:'$donevalue'"
puts stderr "--> returning [lindex $donevalue 1]"
#puts stderr "repl quit --> returning [lindex $donevalue 1]"
return [lindex $donevalue 1]
}
puts "-->repl::start end $inchan $args result:'$donevalue'"
puts stderr "__> returning 0"
#puts stderr "__> returning 0"
return 0
}
proc repl::post_operations {} {
@ -1408,7 +1396,6 @@ proc repl::repl_handler {inputchan prompt_config} {
if {[dict get $original_input_conf -inputmode] eq "raw"} {
#user or script has apparently put stdin into raw mode - update punk::console::is_raw to match
set rawmode 1
#set ::punk::console::is_raw 1
tsv::set console is_raw 1
} else {
#set ::punk::console::is_raw 0
@ -1420,9 +1407,6 @@ proc repl::repl_handler {inputchan prompt_config} {
#if it's been set to raw - assume it is deliberately done this way as the user could have alternatively called punk::mode raw or punk::console::enableVirtualTerminal
#by not doing this automatically - we assume the caller has a reason.
} else {
#JMN FIX!
#this returns 0 in rawmode on 8.6 after repl thread changes
#set rawmode [set ::punk::console::is_raw]
set rawmode [tsv::get console is_raw]
}
@ -1811,8 +1795,6 @@ proc repl::repl_process_data {inputchan chunktype chunk stdinlines prompt_config
set infoprompt [dict get $prompt_config infoprompt]
set debugprompt [dict get $prompt_config debugprompt]
#set rawmode [set ::punk::console::is_raw]
set rawmode [tsv::get console is_raw]
if {!$rawmode} {
#puts stderr "-->got [ansistring VIEW -lf 1 $stdinlines]<--"
@ -2615,6 +2597,34 @@ proc repl::repl_process_data {inputchan chunktype chunk stdinlines prompt_config
}
#editbuf
#after any external command - raw mode as the console sees it can be disabled
#set it to match current state of the tsv
if {[tsv::get console is_raw]} {
if {$::tcl_platform(platform) eq "windows"} {
#review
#we are in parent process - twapi might not be loaded here - even if it is in the code interp
catch {package require twapi}
}
set sinfo [chan configure stdin]
if {[dict exists $sinfo -inputmode]} {
if {[dict get $sinfo -inputmode] ne "raw"} {
set re_enable_required 1
} else {
set re_enable_required 0
}
} else {
# -inputmode unavailable
#tcl 8.6 doesn't have -inputmode - meaning it has to call punk:console::enableRaw each time
#enableRaw on windows without twapi involves launching a pwsh process - which gives a noticeable lag in keyboard input.
#enableRaw on Unix involves a call to stty - which is generally fast - but still to be avoided if not required.
set re_enable_required 1
}
#puts stderr "-here- re-enabling raw"
if {$re_enable_required} {
punk::console::enableRaw
}
}
} else {
#append commandstr \n
if {$::punk::repl::signal_control_c} {
@ -2828,7 +2838,7 @@ namespace eval repl {
}
if {$libunknown ne ""} {
source $libunknown
if {[catch {punk::libunknown::init -caller "repl init_script"} errM]} {
if {[catch {punk::libunknown::init -caller "repl::init init_script parent interp"} errM]} {
puts "repl::init problem - error initialising punk::libunknown\n$errM"
}
#package require punk::lib
@ -2858,10 +2868,10 @@ namespace eval repl {
#thread::send to caller defined interp targets (reference?)
#snit required for icomm
if {[catch {package require snit} errM]} {
puts stdout "punk::repl::initscript lib load fail ---snit $errM"
#puts stdout "punk::repl::initscript: lib load fail ---snit $errM"
}
if {[catch {package require punk::icomm} errM]} {
puts stdout "punk::repl::initscript lib load fail ---icomm $errM"
#puts stdout "punk::repl::initscript: lib load fail ---icomm $errM"
}
#-----
@ -2872,7 +2882,7 @@ namespace eval repl {
#first use can raise error being a version number e.g 0.1.0 - why?
lassign [tcl::chan::fifo2] ::punk::repl::codethread::repltalk replside
} errMsg]} {
puts stdout "punk::repl::initscript tcl::chan::fifo2 error: $errM"
puts stdout "punk::repl::initscript tcl::chan::fifo2 error: $errMsg"
} else {
#experimental?
#puts stdout "transferring chan $replside to thread %replthread%"
@ -3519,6 +3529,8 @@ namespace eval repl {
#-----------------------------------------------------------------------------
if {[package provide punk::libunknown] eq ""} {
namespace eval ::punk::libunknown {}
set ::punk::libunknown::epoch %lib_epoch%
set libunks [list]
foreach tm_path [tcl::tm::list] {
set punkdir [file join $tm_path punk]
@ -3543,7 +3555,7 @@ namespace eval repl {
}
if {$libunknown ne ""} {
source $libunknown
if {[catch {punk::libunknown::init -caller "repl init_script punk"} errM]} {
if {[catch {punk::libunknown::init -caller "repl::init init_script code interp for punk"} errM]} {
puts "error initialising punk::libunknown\n$errM"
}
}

157
src/project_layouts/custom/_project/punk.shell-0.1/src/make.tcl
Unescape View File

@ -31,22 +31,28 @@ namespace eval ::punkboot::lib {
#for some purposes (whether a source folder is likely to have any useful content) we are interested in non dotfile/dotfolder immediate contents of a folder, but not whether a particular platform
#considers them hidden or not.
proc folder_nondotted_children {folder} {
if {![file isdirectory $folder]} {error "punkboot::lib::folder_nondotted_children error. Supplied folder '$folder' is not a directory"}
set contents [glob -nocomplain -dir $folder *]
set normfolder [file normalize $folder]
if {![file isdirectory $normfolder]} {error "punkboot::lib::folder_nondotted_children error. Supplied folder '$folder' is not a directory"}
set contents [glob -nocomplain -dir $folder -tails *]
#some platforms (windows) return dotted entries with *, although most don't
return [lsearch -all -inline -not $contents .*]
set nondotted_tails [lsearch -all -inline -not $contents .*]
return [lmap ftail $nondotted_tails {file join $folder $ftail}]
}
proc folder_nondotted_folders {folder} {
if {![file isdirectory $folder]} {error "punkboot::lib::folder_nondotted_folders error. Supplied folder '$folder' is not a directory"}
set contents [glob -nocomplain -dir $folder -types d *]
set normfolder [file normalize $folder]
if {![file isdirectory $normfolder]} {error "punkboot::lib::folder_nondotted_folders error. Supplied folder '$folder' is not a directory"}
set contents [glob -nocomplain -dir $folder -types d -tails *]
#some platforms (windows) return dotted entries with *, although most don't
return [lsearch -all -inline -not $contents .*]
set nondotted_tails [lsearch -all -inline -not $contents .*]
return [lmap ftail $nondotted_tails {file join $folder $ftail}]
}
proc folder_nondotted_files {folder} {
if {![file isdirectory $folder]} {error "punkboot::lib::folder_nondotted_files error. Supplied folder '$folder' is not a directory"}
set contents [glob -nocomplain -dir $folder -types f $folder *]
set normfolder [file normalize $folder]
if {![file isdirectory $normfolder]} {error "punkboot::lib::folder_nondotted_files error. Supplied folder '$folder' is not a directory"}
set contents [glob -nocomplain -dir $folder -types f $folder -tails *]
#some platforms (windows) return dotted entries with *, although most don't
return [lsearch -all -inline -not $contents .*]
set nondotted_tails [lsearch -all -inline -not $contents .*]
return [lmap ftail $nondotted_tails {file join $folder $ftail}]
}
proc tm_version_isvalid {versionpart} {
#Needs to be suitable for use with Tcl's 'package vcompare'
@ -289,6 +295,10 @@ if {"::try" ni [info commands ::try]} {
# This allows a source update via 'fossil update' 'git pull' etc to pull in a minimal set of support modules for the boot script
# and load these in preference to ones that may have been in the interp's tcl::tm::list or auto_path due to environment variables
set startdir [pwd]
set scriptdir [file dirname [file normalize [info script]]]
#puts "SCRIPTDIR: $scriptdir"
#we are focussed on pure-tcl libs/modules in bootsupport for now.
#There may be cases where we want to use compiled packages from src/bootsupport/modules_tcl9 etc
#REVIEW - punkboot can really speed up with appropriate accelerators and/or external binaries
@ -303,18 +313,22 @@ set bootsupport_library_paths [list]
set this_platform_generic [punkboot::lib::platform_generic]
#we always create these lists in order of desired precedence.
# - this is the same order when adding to auto_path - but will need to be reversed when using tcl:tm::add
if {[file exists [file join $startdir src bootsupport]]} {
lappend bootsupport_module_paths [file join $startdir src bootsupport modules_tcl$::tclmajorv] ;#more version-specific modules slightly higher in precedence order
lappend bootsupport_module_paths [file join $startdir src bootsupport modules]
lappend bootsupport_library_paths [file join $startdir src bootsupport lib_tcl$::tclmajorv/allplatforms] ;#more version-specific pkgs slightly higher in precedence order
lappend bootsupport_library_paths [file join $startdir src bootsupport lib_tcl$::tclmajorv/$this_platform_generic] ;#more version-specific pkgs slightly higher in precedence order
lappend bootsupport_library_paths [file join $startdir src bootsupport lib]
if {[file exists [file join $scriptdir bootsupport]]} {
set bootsupportdir [file join $scriptdir bootsupport]
puts stderr "Using bootsupport dir $bootsupportdir"
lappend bootsupport_module_paths [file join $bootsupportdir modules_tcl$::tclmajorv] ;#more version-specific modules slightly higher in precedence order
lappend bootsupport_module_paths [file join $bootsupportdir modules]
lappend bootsupport_library_paths [file join $bootsupportdir lib_tcl$::tclmajorv/allplatforms] ;#more version-specific pkgs slightly higher in precedence order
lappend bootsupport_library_paths [file join $bootsupportdir lib_tcl$::tclmajorv/$this_platform_generic] ;#more version-specific pkgs slightly higher in precedence order
lappend bootsupport_library_paths [file join $bootsupportdir lib]
} else {
lappend bootsupport_module_paths [file join $startdir bootsupport modules_tcl$::tclmajorv]
lappend bootsupport_module_paths [file join $startdir bootsupport modules]
lappend bootsupport_library_paths [file join $startdir bootsupport lib_tcl$::tclmajorv/allplatforms]
lappend bootsupport_library_paths [file join $startdir bootsupport lib_tcl$::tclmajorv/$this_platform_generic]
lappend bootsupport_library_paths [file join $startdir bootsupport lib]
puts stderr "No bootsupport dir for script [info script] at [file join $scriptdir bootsupport]"
#lappend bootsupport_module_paths [file join $startdir bootsupport modules_tcl$::tclmajorv]
#lappend bootsupport_module_paths [file join $startdir bootsupport modules]
#lappend bootsupport_library_paths [file join $startdir bootsupport lib_tcl$::tclmajorv/allplatforms]
#lappend bootsupport_library_paths [file join $startdir bootsupport lib_tcl$::tclmajorv/$this_platform_generic]
#lappend bootsupport_library_paths [file join $startdir bootsupport lib]
}
set bootsupport_paths_exist 0
foreach p [list {*}$bootsupport_module_paths {*}$bootsupport_library_paths] {
@ -406,8 +420,8 @@ if {$bootsupport_paths_exist || $sourcesupport_paths_exist} {
tcl::tm::add {*}[lreverse $bootsupport_module_paths] {*}[lreverse $sourcesupport_module_paths] ;#tm::add works like LIFO. sourcesupport_module_paths end up earliest in resulting tm list.
set ::auto_path [list {*}$sourcesupport_library_paths {*}$bootsupport_library_paths]
}
puts "----> auto_path $::auto_path"
puts "----> tcl::tm::list [tcl::tm::list]"
#puts "----> auto_path $::auto_path"
#puts "----> tcl::tm::list [tcl::tm::list]"
#maint: also in punk::repl package
#--------------------------------------------------------
@ -435,22 +449,26 @@ if {$bootsupport_paths_exist || $sourcesupport_paths_exist} {
}
if {$libunknown ne ""} {
source $libunknown
if {[catch {punk::libunknown::init -caller main.tcl} errM]} {
puts "error initialising punk::libunknown\n$errM"
if {[catch {punk::libunknown::init -caller make.tcl} errM]} {
puts stderr "error initialising punk::libunknown\n$errM"
}
#puts stdout " *** [package names]"
#puts stdout " **** [dict get $::punk::libunknown::epoch pkg untracked]"
} else {
puts stderr "Failed to find punk::libunknown"
}
#--------------------------------------------------------
#package require Thread
puts "---->tcl_library [info library]"
puts "---->loaded [info loaded]"
#puts "---->tcl_library [info library]"
#puts "---->loaded [info loaded]"
# - the full repl requires Threading and punk,shellfilter,shellrun to call and display properly.
# tm list already indexed - need 'package forget' to find modules based on current tcl::tm::list
#These are strong dependencies
package forget punk::mix
package forget punk::repo
package forget punkcheck
#package forget punk::mix
#package forget punk::repo
#package forget punkcheck
package require punk::repo ;#todo - push our requirements to a smaller punk::repo::xxx package with minimal dependencies
package require punk::mix
@ -464,6 +482,7 @@ if {$bootsupport_paths_exist || $sourcesupport_paths_exist} {
set package_paths_modified 1
#------------------------------------------------------------------------------
#puts "----> llength package names [llength [package names]]"
}
set ::punkboot::pkg_requirements_found [list]
@ -479,7 +498,9 @@ set ::punkboot::bootsupport_requirements [dict create\
punkcheck [list]\
fauxlink [list version "0.1.1-"]\
textblock [list version 0.1.1-]\
fileutil [list]\
fileutil::traverse [list]\
struct::list [list]\
md5 [list version 2-]\
]
@ -1282,7 +1303,41 @@ proc ::punkboot::punkboot_gethelp {args} {
return $h
}
set scriptargs $::argv
punk::args::define {
@id -id punkmake
@cmd -name punkmake\
-summary\
"Project builder"\
-help\
""
@form -form help
@leaders
subcommand -type "literal(help)"
@opts
@values
what -type string -choices {modules libs shell}
@form -form modules
subcommand -type "literal(modules)"
@form -form libs
subcommand -type "literal(libs)"
@form -form shell
subcommand -type "literal(shell)"
arg -type any -optional 1 -multiple 1
}
#set argd [punk::args::parse $scriptargs -form 0 withid punkmake]
##lassign [dict values $argd] leaders opts values received
#
#puts stdout [punk::args::usage -scheme nocolour punkmake]
#exit 1
set do_help 0
if {![llength $scriptargs]} {
set do_help 1
@ -1294,6 +1349,8 @@ if {![llength $scriptargs]} {
}
}
}
set commands_found [list]
foreach a $scriptargs {
if {![string match -* $a]} {
@ -1310,6 +1367,8 @@ if {[llength $commands_found] != 1 } {
puts stderr "Unknown command: [lindex $commands_found 0]\n\n"
set do_help 1
}
if {$do_help} {
puts stdout "Checking package availability..."
set ::punkboot::pkg_availability [::punkboot::check_package_availability -quiet 1 $::punkboot::bootsupport_requirements]
@ -1325,6 +1384,8 @@ if {$do_help} {
exit 0
}
set ::punkboot::command [lindex $commands_found 0]
@ -1414,14 +1475,15 @@ if {$::punkboot::command eq "check"} {
if {$package_paths_modified} {
set tm_list_boot [tcl::tm::list]
tcl::tm::remove {*}$tm_list_boot
foreach p [lreverse $original_tm_list] {
set lower_prio [list]
foreach p $original_tm_list {
if {$p ni $tm_list_boot} {
tcl::tm::add $p
}
lappend lower_prio $p
}
foreach p [lreverse $tm_list_boot] {
tcl::tm::add $p
}
tcl::tm::add {*}[lreverse $lower_prio] {*}[lreverse $tm_list_boot]
#set ::auto_path [list $bootsupport_lib {*}$original_auto_path]
lappend ::auto_path {*}$original_auto_path
}
@ -1489,6 +1551,28 @@ if {![array size A]} {
punkboot::define_global_ansi
}
#puts stderr ">>>>>>+ loaded:[info loaded]"
#puts stderr "llength package names: [llength [package names]]"
if {[info exists ::punk::libunknown::epoch]} {
set untracked [dict get $::punk::libunknown::epoch pkg untracked]
#puts stderr "punk::libunknown::epoch exists"
} else {
set untracked [list]
#puts stderr "punk::libunknown::epoch does not exist"
}
#REVIEW - we shouldn't need to manually set the untracked packages - punk::libunknown::init should have done it?
foreach p [package names] {
if {![dict exists $untracked $p]} {
dict set untracked $p ""
}
}
dict set ::punk::libunknown::epoch pkg untracked $untracked
if {[package provide punk::libunknown] eq ""} {
puts "punk::libunknown not loaded"
} else {
puts "punk::libunknown loaded"
}
dict for {pkg pkginfo} $::punkboot::bootsupport_requirements {
set verspec [dict get $pkginfo version] ;#version wanted specification always exists and is empty or normalised
if {[catch {package require $pkg {*}$verspec} errM]} {
@ -1557,14 +1641,13 @@ if {$::punkboot::command eq "info"} {
if {$::punkboot::command eq "shell"} {
puts stderr ">>>>>> loaded:[info loaded]"
package require struct::list
package require punk
package require punk::repl
#todo - make procs vars etc from this file available?
puts stderr "punk boot shell not implemented - dropping into ordinary punk shell."
repl::init
set replresult [repl::start stdin -title make.tcl]
#review
@ -3059,6 +3142,8 @@ foreach vfstail $vfs_tails {
exec {*}$::sdxpath unwrap [file rootname $building_runtime].tail ;#extracts to folder named [file rootname $building_runtime].vfs e.g build_tclkit9.0.2-win64-dyn.vfs
#file rename to existing target dir would copy folder into target dir
if {![file exists $targetvfs]} {
#delay
after 1000
file rename [file rootname $building_runtime].vfs $targetvfs
} else {
merge_over [file rootname $building_runtime].vfs $targetvfs

4
src/runtime/mapvfs.config
Unescape View File

@ -13,7 +13,7 @@
#- myproject.vfs
#- punk86.vfs
#AAA
#tclkit86bi.exe {punk8win.vfs punkbi kit}
tclkit86bi.exe {punk8win.vfs punkbi kit}
#c:\tcl.bawt tcl 8.6.13 bawt
##tclkit-win64-dyn.exe {punk86bawt.vfs punkbawt kit}
@ -29,6 +29,8 @@
#magicsplat modified tclkit - added tk, changed icon
##tclkit8613punk.exe punk86.vfs {punk8win.vfs punk86}
##tclkit8613punk.exe punk86.vfs {punk8win.vfs punk86}
#tclkit87a5.exe {punk86.vfs punk87} {punk.vfs punkmain}

1
src/scriptapps/bin/readme.txt
Unescape View File

@ -0,0 +1 @@
scriptapps targeting the project's bin directory go here.

743
src/scriptapps/example_out.bat
Unescape View File

@ -1,743 +0,0 @@
: "punk MULTISHELL - shebangless polyglot for Tcl Perl sh bash cmd pwsh powershell" + "[rename set s;proc Hide x {proc $x args {}};Hide :]" + "\$(function : {<#pwsh#>})" + "perlhide" + qw^
set -- "$@" "a=[Hide <#;Hide set;s 1 list]"; set -- : "$@";$1 = @'
: heredoc1 - hide from powershell using @ and squote above. close sqote for unix shells + ' \
: .bat/.cmd launch section, leading colon hides from cmd, trailing slash hides next line from tcl + \
: "[Hide @GOTO; Hide =begin; Hide @REM] #not necessary but can help avoid errs in testing" +
: << 'HEREDOC1B_HIDE_FROM_BASH_AND_SH'
: STRONG SUGGESTION: DO NOT MODIFY FIRST LINE OF THIS SCRIPT - except for first double quoted section.
: shebang line is not required on unix or windows and will reduce functionality and/or portability.
: Even comment lines can be part of the functionality of this script (both on unix and windows) - modify with care.
@GOTO :skip_perl_pod_start ^;
=begin excludeperl
: skip_perl_pod_start
: Continuation char at end of this line and rem with curly-braces used to exlude Tcl from the whole cmd block \
: {
@REM ############################################################################################################################
@REM THIS IS A POLYGLOT SCRIPT - supporting payloads in Tcl, bash, (some sh) and/or powershelll (powershell.exe or pwsh.exe)
@REM It should remain portable between unix-like OSes & windows if the proper structure is maintained.
@REM ############################################################################################################################
@REM On windows, change the value of nextshell to one of the listed 2 digit values if desired, and add code within payload sections for tcl,sh,bash,powershell as appropriate.
@REM This wrapper can be edited manually (carefully!) - or sh,bash,tcl,powershell scripts can be wrapped using the Tcl-based punkshell system
@REM e.g from within a running punkshell: deck scriptwrap.multishell <inputfilepath> -outputfolder <folderpath>
@REM On unix-like systems, call with sh, bash or tclsh. (powershell untested on unix - and requires wscript if security elevation is used)
@REM Due to lack of shebang (#! line) Unix-like systems will probably (hopefully) default to sh if the script is called without an interpreter - but it may depend on the shell in use when called.
@REM If you find yourself really wanting/needing to add a shebang line - do so on the basis that the script will exist on unix-like systems only.
@REM in batch scripts - array syntax with square brackets is a simulation of arrays or associative arrays.
@REM note that many shells linked as sh do not support substition syntax and may fail - e.g dash etc - generally bash should be used in this context
@SETLOCAL EnableExtensions EnableDelayedExpansion
@SET "validshelltypes= powershell______ sh______________ wslbash_________ bash____________ tcl_____________ perl____________"
@REM for batch - only win32 is relevant - but other scripts on other platforms also parse the nextshell block to determine next shell to launch
@REM nextshellpath and nextshelltype indices (underscore-padded to 16wide) are "other" plus those returned by Tcl platform pkg e.g win32,linux,freebsd,macosx
@REM The horrible underscore-padded fixed-widths are to keep the batch labels aligned whilst allowing values to be set
@REM If more than 32 chars needed for a target, it can still be done but overall script padding may need checking/adjusting
@REM Supporting more explicit oses than those listed may also require script padding adjustment
: <nextshell>
@SET "nextshellpath[win32___________]=tclsh___________________________"
@SET "nextshelltype[win32___________]=tcl_____________"
@SET "nextshellpath[dragonflybsd____]=/usr/bin/env tclsh______________"
@SET "nextshelltype[dragonflybsd____]=tcl_____________"
@SET "nextshellpath[freebsd_________]=/usr/bin/env tclsh______________"
@SET "nextshelltype[freebsd_________]=tcl_____________"
@SET "nextshellpath[netbsd__________]=/usr/bin/env tclsh______________"
@SET "nextshelltype[netbsd__________]=tcl_____________"
@SET "nextshellpath[linux___________]=/usr/bin/env tclsh______________"
@SET "nextshelltype[linux___________]=tcl_____________"
@SET "nextshellpath[macosx__________]=/usr/bin/env tclsh______________"
@SET "nextshelltype[macosx__________]=tcl_____________"
@SET "nextshellpath[other___________]=/usr/bin/env tclsh______________"
@SET "nextshelltype[other___________]=tcl_____________"
: </nextshell>
@rem asadmin is for automatic elevation to administrator. Separate window will be created (seems unavoidable with current elevation mechanism) and user will still get security prompt (probably reasonable).
: <asadmin>
@SET "asadmin=0"
: </asadmin>
@REM @ECHO nextshelltype is %nextshelltype[win32___________]%
@REM @SET "selected_shelltype=%nextshelltype[win32___________]%"
@SET "selected_shelltype=%nextshelltype[win32___________]%"
@REM @ECHO selected_shelltype %selected_shelltype%
@CALL :stringTrimTrailingUnderscores %selected_shelltype% selected_shelltype_trimmed
@REM @ECHO selected_shelltype_trimmed %selected_shelltype_trimmed%
@SET "selected_shellpath=%nextshellpath[win32___________]%"
@CALL :stringTrimTrailingUnderscores %selected_shellpath% selected_shellpath_trimmed
@CALL SET "keyRemoved=%%validshelltypes:!selected_shelltype!=%%"
@REM @ECHO keyremoved %keyRemoved%
@REM Note that 'powershell' e.g v5 is just a fallback for when pwsh is not available
@REM ## ### ### ### ### ### ### ### ### ### ### ### ### ###
@REM -- cmd/batch file section (ignored on unix but should be left in place)
@REM -- This section intended mainly to launch the next shell (and to escalate privileges if necessary)
@REM -- Avoid customising this if you are not familiar with batch scripting. cmd/batch script can be useful, but is probably the least expressive language and most error prone.
@REM -- For example - as this file needs to use unix-style lf line-endings - the label scanner is susceptible to the 512Byte boundary issue: https://www.dostips.com/forum/viewtopic.php?t=8988#p58888
@REM -- This label issue can be triggered/abused in files with crlf line endings too - but it is less likely to happen accidentaly.
@REm -- See also: https://stackoverflow.com/questions/4094699/how-does-the-windows-command-interpreter-cmd-exe-parse-scripts/4095133#4095133
@REM ############################################################################################################################
@REM -- Due to this issue -seemingly trivial edits of the batch file section can break the script! (for Windows anyway)
@REM -- Even something as simple as adding or removing an @REM
@REM -- From within punkshell - use:
@REM -- deck scriptwrap.checkfile <filepath>
@REM -- to check your templates or final wrapped scripts for byte boundary issues
@REM -- It will report any labels that are on boundaries
@REM -- This is why the nextshell value above is a 2 digit key instead of a string - so that editing the value doesn't change the byte offsets.
@REM -- Editing your sh,bash,tcl,pwsh payloads is much less likely to cause an issue. There is the possibility of the final batch :exit_multishell label spanning a boundary - so testing using deck scriptwrap.checkfile is still recommended.
@REM -- Alternatively, as you should do anyway - test the final script on windows
@REM -- Aside from adding comments/whitespace to tweak the location of labels - you can try duplicating the label (e.g just add the label on a line above) but this is not guaranteed to work in all situations.
@REM -- '@REM' is a safer comment mechanism than a leading colon - which is used sparingly here.
@REM -- A colon anywhere in the script that happens to land on a 512 Byte boundary (from file start or from a callsite) could be misinterpreted as a label
@REM -- It is unknown what versions of cmd interpreters behave this way - and deck scriptwrap.checkfile doesn't check all such boundaries.
@REm -- For this reason, batch labels should be chosen to be relatively unlikely to collide with other strings in the file, and simple names such as :exit or :end should probably be avoided
@REM ############################################################################################################################
@REM -- custom windows payloads should be in powershell,tclsh (or sh/bash if available) code sections
@REM ## ### ### ### ### ### ### ### ### ### ### ### ### ###
@SET "winpath=%~dp0"
@SET "fname=%~nx0"
@REM @ECHO fname %fname%
@REM @ECHO winpath %winpath%
@REM @ECHO commandlineascalled %0
@REM @ECHO commandlineresolved %~f0
@CALL :getNormalizedScriptTail nftail
@REM @ECHO normalizedscripttail %nftail%
@CALL :getFileTail %0 clinetail
@REM @ECHO clinetail %clinetail%
@CALL :stringToUpper %~nx0 capscripttail
@REM @ECHO capscriptname: %capscripttail%
@IF "%nftail%"=="%capscripttail%" (
@ECHO forcing asadmin=1 due to file name on filesystem being uppercase
@SET "asadmin=1"
) else (
@CALL :stringToUpper %clinetail% capcmdlinetail
@REM @ECHO capcmdlinetail !capcmdlinetail!
IF "%clinetail%"=="!capcmdlinetail!" (
@ECHO forcing asadmin=1 due to cmdline scriptname in uppercase
@set "asadmin=1"
)
)
@SET "vbsGetPrivileges=%temp%\punk_bat_elevate_%fname%.vbs"
@SET arglist=%*
@SET "qstrippedargs=args%arglist%"
@SET "qstrippedargs=%qstrippedargs:"=%"
@IF "is%qstrippedargs:~4,13%"=="isPUNK-ELEVATED" (
GOTO :gotPrivileges
)
@IF !asadmin!==1 (
net file 1>NUL 2>NUL
@IF '!errorlevel!'=='0' ( GOTO :gotPrivileges ) else ( GOTO :getPrivileges )
)
@REM padding
@REM padding
@REM padding
@REM padding
@REM padding
@REM padding
@REM padding
@REM padding
@REM padding
@REM padding
@REM padding
@REM padding
@GOTO skip_privileges
:getPrivileges
@IF "is%qstrippedargs:~4,13%"=="isPUNK-ELEVATED" (echo PUNK-ELEVATED & shift /1 & goto :gotPrivileges )
@ECHO Set UAC = CreateObject^("Shell.Application"^) > "%vbsGetPrivileges%"
@ECHO args = "PUNK-ELEVATED " >> "%vbsGetPrivileges%"
@ECHO For Each strArg in WScript.Arguments >> "%vbsGetPrivileges%"
@ECHO args = args ^& strArg ^& " " >> "%vbsGetPrivileges%"
@ECHO Next >> "%vbsGetPrivileges%"
@ECHO UAC.ShellExecute "%~dp0%~n0%~x0", args, "", "runas", 1 >> "%vbsGetPrivileges%"
@ECHO Launching script in new windows due to administrator elevation
@"%SystemRoot%\System32\WScript.exe" "%vbsGetPrivileges%" %*
@EXIT /B
:gotPrivileges
@REM setlocal & pushd .
@PUSHD .
@cd /d %~dp0
@IF "is%qstrippedargs:~4,13%"=="isPUNK-ELEVATED" (
@DEL "%vbsGetPrivileges%" 1>nul 2>nul
@SET arglist=%arglist:~14%
)
:skip_privileges
@SET need_ps1=0
@REM we want the ps1 to exist even if the nextshell isn't powershell
@if not exist "%~dp0%~n0.ps1" (
@SET need_ps1=1
) ELSE (
fc "%~dp0%~n0%~x0" "%~dp0%~n0.ps1" >nul || goto different
@REM @ECHO "files same"
@SET need_ps1=0
)
@GOTO :pscontinue
:different
@REM @ECHO "files differ"
@SET need_ps1=1
:pscontinue
@IF !need_ps1!==1 (
COPY "%~dp0%~n0%~x0" "%~dp0%~n0.ps1" >NUL
)
@REM avoid using CALL to launch pwsh,tclsh etc - it will intercept some args such as /?
@IF "%selected_shelltype_trimmed%"=="powershell" (
REM pws vs powershell hasn't been tested because we didn't need to copy cmd to ps1 this time
REM test availability of preferred option of powershell7+ pwsh
pwsh -nop -nol -c set-executionpolicy -Scope Process Unrestricted; write-host "statusmessage: pwsh-found" >NUL
SET pwshtest_exitcode=!errorlevel!
REM ECHO pwshtest_exitcode !pwshtest_exitcode!
REM fallback to powershell if pwsh failed
IF !pwshtest_exitcode!==0 (
pwsh -nop -nol -c set-executionpolicy -Scope Process Unrestricted; "%~dp0%~n0.ps1" %arglist%
SET task_exitcode=!errorlevel!
) ELSE (
REM CALL powershell -nop -nol -c write-host powershell-found
REM powershell -nop -nol -file "%~dp0%~n0.ps1" %*
powershell -nop -nol -c set-executionpolicy -Scope Process Unrestricted; %~dp0%~n0.ps1" %arglist%
SET task_exitcode=!errorlevel!
)
) ELSE (
IF "%selected_shelltype_trimmed%"=="wslbash" (
CALL :getWslPath %winpath% wslpath
REM ECHO wslfullpath "!wslpath!%fname%"
%selected_shellpath_trimmed% "!wslpath!%fname%" %arglist%
SET task_exitcode=!errorlevel!
) ELSE (
REM perl or tcl or sh or bash
IF NOT "x%keyRemoved%"=="x%validshelltypes%" (
REM sh on windows uses /c/ instead of /mnt/c - at least if using msys. Todo, review what is the norm on windows with and without msys2,cygwin,wsl
REM and what logic if any may be needed. For now sh with /c/xxx seems to work the same as sh with c:/xxx
REM The compound statement with trailing call is required to stop batch termination confirmation, whilst still capturing exitcode
%selected_shellpath_trimmed% "%~dp0%fname%" %arglist% & SET task_exitcode=!errorlevel! & Call;
) ELSE (
ECHO %fname% has invalid nextshelltype value %selected_shelltype% valid options are %validshelltypes%
SET task_exitcode=66
@REM boundary padding
@REM boundary padding
@REM boundary padding
@REM boundary padding
GOTO :exit_multishell
)
)
)
@REM batch file library functions
@REM boundary padding
@GOTO :endlib
:getWslPath
@SETLOCAL
@SET "_path=%~p1"
@SET "name=%~nx1"
@SET "drive=%~d1"
@SET "rtrn=%~2"
@REM Although drive letters on windows are normally upper case wslbash seems to expect lower case drive letters
@CALL :stringToLower %drive ldrive
@SET "result=/mnt/%ldrive:~0,1%%_path:\=/%%name%"
@ENDLOCAL & (
@if "%~2" neq "" (
SET "%rtrn%=%result%"
) ELSE (
ECHO %result%
)
)
@EXIT /B
:getFileTail
@REM return tail of file without any normalization e.g c:/punkshell/bin/Punk.cmd returns Punk.cmd even if file is punk.cmd
@REM we can't use things such as %~nx1 as it can change capitalisation
@REM This function is designed explicitly to preserve capitalisation
@REM accepts full paths with either / or \ as delimiters - or
@SETLOCAL
@SET "rtrn=%~2"
@SET "arg=%~1"
@REM @SET "result=%_arg:*/=%"
@REM @SET "result=%~1"
@SET LF=^
: The above 2 empty lines are important. Don't remove
@CALL :stringContains "!arg!" "\" hasBackSlash
@IF "!hasBackslash!"=="true" (
@for %%A in ("!LF!") do @(
@FOR /F %%B in ("!arg:\=%%~A!") do @set "result=%%B"
)
) ELSE (
@CALL :stringContains "!arg!" "/" hasForwardSlash
@IF "!hasForwardSlash!"=="true" (
@FOR %%A in ("!LF!") do @(
@FOR /F %%B in ("!arg:/=%%~A!") do @set "result=%%B"
)
) ELSE (
@set "result=%arg%"
)
)
@ENDLOCAL & (
@if "%~2" neq "" (
@SET "%rtrn%=%result%"
) ELSE (
@ECHO %result%
)
)
@EXIT /B
@REM boundary padding
@REM boundary padding
:getNormalizedScriptTail
@SETLOCAL
@SET "result=%~nx0"
@SET "rtrn=%~1"
@ENDLOCAL & (
@IF "%~1" neq "" (
@SET "%rtrn%=%result%"
) ELSE (
@ECHO %result%
)
)
@EXIT /B
:getNormalizedFileTailFromPath
@REM warn via echo, and do not set return variable if path not found
@REM note that %~nx1 does not preserve case of provided path - hence the name 'normalized'
@REM boundary padding
@REM boundary padding
@REM boundary padding
@REM boundary padding
@SETLOCAL
@CALL :stringContains %~1 "\" hasBackSlash
@CALL :stringContains %~1 "/" hasForwardSlash
@IF "%hasBackslash%-%hasForwardslash%"=="false-false" (
@SET "P=%cd%%~1"
@CALL :getNormalizedFileTailFromPath "!P!" ftail2
@SET "result=!ftail2!"
) else (
@IF EXIST "%~1" (
@SET "result=%~nx1"
) else (
@ECHO error getNormalizedFileTailFromPath file not found: %~1
@EXIT /B 1
)
)
@SET "rtrn=%~2"
@ENDLOCAL & (
@IF "%~2" neq "" (
SET "%rtrn%=%result%"
) ELSE (
@ECHO getNormalizedFileTailFromPath %1 result: %result%
)
)
@EXIT /B
:stringContains
@REM usage: @CALL:stringContains string needle returnvarname
@SETLOCAL
@SET "rtrn=%~3"
@SET "string=%~1"
@SET "needle=%~2"
@IF "!string:%needle%=!"=="!string!" @(
@SET "result=false"
) ELSE (
@SET "result=true"
)
@ENDLOCAL & (
@IF "%~3" neq "" (
@SET "%rtrn%=%result%"
) ELSE (
@ECHO stringContains %string% %needle% result: %result%
)
)
@EXIT /B
@REM boundary padding
@REM boundary padding
:stringToUpper
@SETLOCAL
@SET "rtrn=%~2"
@SET "string=%~1"
@SET "capstring=%~1"
@FOR %%A in (A B C D E F G H I J K L M N O P Q R S T U V W X Y Z) DO @(
@SET "capstring=!capstring:%%A=%%A!"
)
@SET "result=!capstring!"
@ENDLOCAL & (
@IF "%~2" neq "" (
@SET "%rtrn%=%result%"
) ELSE (
@ECHO stringToUpper %string% result: %result%
)
)
@EXIT /B
:stringToLower
@SETLOCAL
@SET "rtrn=%~2"
@SET "string=%~1"
@SET "retstring=%~1"
@FOR %%A in (a b c d e f g h i j k l m n o p q r s t u v w x y z) DO @(
@SET "retstring=!retstring:%%A=%%A!"
)
@SET "result=!retstring!"
@ENDLOCAL & (
@IF "%~2" neq "" (
@SET "%rtrn%=%result%"
) ELSE (
@ECHO stringToLower %string% result: %result%
)
)
@EXIT /B
@REM boundary padding
@REM boundary padding
:stringTrimTrailingUnderscores
@SETLOCAL
@SET "rtrn=%~2"
@SET "string=%~1"
@SET "trimstring=%~1"
@REM trim up to 31 underscores from the end of a string using string substitution
@SET trimstring=%trimstring%###
@SET trimstring=%trimstring:________________###=###%
@SET trimstring=%trimstring:________###=###%
@SET trimstring=%trimstring:____###=###%
@SET trimstring=%trimstring:__###=###%
@SET trimstring=%trimstring:_###=###%
@SET trimstring=%trimstring:###=%
@SET "result=!trimstring!"
@ENDLOCAL & (
@IF "%~2" neq "" (
@SET "%rtrn%=%result%"
) ELSE (
@ECHO stringTrimTrailingUnderscores %string% result: %result%
)
)
@EXIT /B
:isNumeric
@SETLOCAL
@SET "notnumeric="&FOR /F "delims=0123456789" %%i in ("%1") do set "notnumeric=%%i"
@IF defined notnumeric (
@SET "result=false"
) else (
@SET "result=true"
)
@SET "rtrn=%~2"
@ENDLOCAL & (
@IF "%~2" neq "" (
@SET "%rtrn%=%result%"
) ELSE (
@ECHO %result%
)
)
@EXIT /B
:endlib
: \
@REM padding
@REM padding
@REM @SET taskexit_code=!errorlevel! & goto :exit_multishell
@GOTO :exit_multishell
# }
# -*- tcl -*-
# ## ### ### ### ### ### ### ### ### ### ### ### ### ###
# -- tcl script section
# -- This is a punk multishell file
# -- Primary payload target is Tcl, with sh,bash,powershell as helpers
# -- but it may equally be used with any of these being the primary script.
# -- It is tuned to run when called as a batch file, a tcl script a sh/bash script or a pwsh/powershell script
# -- i.e it is a polyglot file.
# -- The specific layout including some lines that appear just as comments is quite sensitive to change.
# -- It can be called on unix or windows platforms with or without the interpreter being specified on the commandline.
# -- e.g ./filename.polypunk.cmd in sh or bash
# -- e.g tclsh filename.cmd
# --
# ## ### ### ### ### ### ### ### ### ### ### ### ### ###
rename set ""; rename s set; set k {-- "$@" "a}; if {[info exists ::env($k)]} {unset ::env($k)} ;# tidyup and restore
Hide :exit_multishell;Hide {<#};Hide '@
namespace eval ::punk::multishell {
set last_script_root [file dirname [file normalize ${::argv0}/__]]
set last_script [file dirname [file normalize [info script]/__]]
if {[info exists ::argv0] &&
$last_script eq $last_script_root
} {
set ::punk::multishell::is_main($last_script) 1 ;#run as executable/script - likely desirable to launch application and return an exitcode
} else {
set ::punk::multishell::is_main($last_script) 0 ;#sourced - likely to be being used as a library - no launch, no exit. Can use return.
}
if {"::punk::multishell::is_main" ni [info commands ::punk::multishell::is_main]} {
proc ::punk::multishell::is_main {{script_name {}}} {
if {$script_name eq ""} {
set script_name [file dirname [file normalize [info script]/--]]
}
if {![info exists ::punk::multishell::is_main($script_name)]} {
#e.g a .dll or something else unanticipated
puts stderr "Warning punk::multishell didn't recognize info script result: $script_name - will treat as if sourced and return instead of exiting"
puts stderr "Info: script_root: [file dirname [file normalize ${::argv0}/__]]"
return 0
}
return [set ::punk::multishell::is_main($script_name)]
}
}
}
# -- --- --- --- --- --- --- --- --- --- --- --- --- ---begin Tcl Payload
#puts "script : [info script]"
#puts "argcount : $::argc"
#puts "argvalues: $::argv"
#puts "argv0 : $::argv0"
# -- --- --- --- --- --- --- --- --- --- --- ---
#<tcl-pre-launch-subprocess>
#</tcl-pre-launch-subprocess>
#<tcl-launch-subprocess>
#</tcl-launch-subprocess>
#<tcl-post-launch-subprocess>
#</tcl-post-launch-subprocess>
# -- --- --- --- --- --- --- --- --- --- --- ---
# -- Best practice is to always return or exit above, or just by leaving the below defaults in place.
# -- If the multishell script is modified to have Tcl below the Tcl Payload section,
# -- then Tcl bracket balancing needs to be carefully managed in the shell and powershell sections below.
# -- Only the # in front of the two relevant if statements below needs to be removed to enable Tcl below
# -- but the sh/bash 'then' and 'fi' would also need to be uncommented.
# -- This facility left in place for experiments on whether configuration payloads etc can be appended
# -- to tail of file - possibly binary with ctrl-z char - but utility is dependent on which other interpreters/shells
# -- can be made to ignore/cope with such data.
if {[::punk::multishell::is_main]} {
exit 0
} else {
return
}
# -- --- --- --- --- --- --- --- --- --- --- --- --- ---end Tcl Payload
# end hide from unix shells \
HEREDOC1B_HIDE_FROM_BASH_AND_SH
# sh/bash \
shift && set -- "${@:1:$#-1}"
#------------------------------------------------------
# -- This if block only needed if Tcl didn't exit or return above.
if false==false # else {
then
: #
# ## ### ### ### ### ### ### ### ### ### ### ### ### ###
# -- sh/bash script section
# -- leave as is if all that is required is launching the Tcl payload"
# --
# -- Note that sh/bash script isn't called when running a .bat/.cmd from cmd.exe on windows by default
# -- adjust the %nextshell% value above
# -- if sh/bash scripting needs to run on windows too.
# --
# ## ### ### ### ### ### ### ### ### ### ### ### ### ###
# -- --- --- --- --- --- --- --- --- --- --- --- --- ---begin sh Payload
exitcode=0
#printf "start of bash or sh code"
#<shell-pre-launch-subprocess>
echo "output from example.sh wrapped in polyglot script"
#</shell-pre-launch-subprocess>
# -- --- --- --- --- --- --- ---
#<shell-launch-subprocess>
#-- sh/bash launches Tcl here instead of shebang line at top
#-- use exec to use exitcode (if any) directly from the tcl script
#exec /usr/bin/env tclsh "$0" "$@"
#-- alternative - can run sh/bash script after the tcl call.
/usr/bin/env tclsh "$0" "$@"
exitcode=$?
#echo "sh/bash reporting tcl exitcode: ${exitcode}"
#-- override exitcode example
#exit 66
#</shell-launch-subprocess>
# -- --- --- --- --- --- --- ---
#<shell-post-launch-subprocess>
#</shell-post-launch-subprocess>
#printf "sh/bash done \n"
# -- --- --- --- --- --- --- --- --- --- --- --- --- ---end sh Payload
#------------------------------------------------------
fi
exit ${exitcode}
# ## ### ### ### ### ### ### ### ### ### ### ### ### ###
# -- Perl script section
# -- leave the script below as is, if all that is required is launching the Tcl payload"
# --
# -- Note that perl script isn't called by default when simply running this script by name
# -- adjust the nextshell value at the top of the script to point to perl
# --
# ## ### ### ### ### ### ### ### ### ### ### ### ### ###
=cut
#!/user/bin/perl
# -- --- --- --- --- --- --- --- --- --- --- --- --- ---begin perl Payload
my $exit_code = 0;
#use ExtUtils::Installed;
#my $installed = ExtUtils::Installed->new();
#my @modules = $installed->modules();
#print "Modules:\n";
#foreach my $m (@modules) {
# print "$m\n";
#}
# -- --- ---
my $scriptname = $0;
print "perl $scriptname\n";
my $i =1;
foreach my $a(@ARGV) {
print "Arg # $i: $a\n";
}
#<perl-pre-launch-subprocess>
#</perl-pre-launch-subprocess>
# -- --- --- --- --- --- --- ---
#<perl-launch-subprocess>
$exit_code=system("tclsh", $scriptname, @ARGV);
#print "perl reporting tcl exitcode: $exit_code";
#</perl-launch-subprocess>
# -- --- --- --- --- --- --- ---
#<perl-post-launch-subprocess>
#</perl-post-launch-subprocess>
# -- --- --- --- --- --- --- --- --- --- --- --- --- ---end perl Payload
exit $exit_code;
__END__
# end hide sh/bash/perl block from Tcl
# This comment with closing brace should stay in place whether if commented or not }
#------------------------------------------------------
# begin hide powershell-block from Tcl - only needed if Tcl didn't exit or return above
if 0 {
: end heredoc1 - end hide from powershell \
'@
# ## ### ### ### ### ### ### ### ### ### ### ### ### ###
# -- powershell/pwsh section
# -- Do not edit if current file is the .ps1
# -- Edit the corresponding .cmd and it will autocopy
# -- unbalanced braces { } here *even in comments* will cause problems if there was no Tcl exit or return above
# -- custom script should generally go below the begin_powershell_payload line
# ## ### ### ### ### ### ### ### ### ### ### ### ### ###
function GetScriptName { $myInvocation.ScriptName }
$scriptname = GetScriptName
function GetDynamicParamDictionary {
[CmdletBinding()]
param(
[Parameter(ValueFromPipeline=$true, Mandatory=$true)]
[string] $CommandName
)
begin {
# Get a list of params that should be ignored (they're common to all advanced functions)
$CommonParameterNames = [System.Runtime.Serialization.FormatterServices]::GetUninitializedObject([type] [System.Management.Automation.Internal.CommonParameters]) |
Get-Member -MemberType Properties |
Select-Object -ExpandProperty Name
}
process {
# Create the dictionary that this scriptblock will return:
$DynParamDictionary = New-Object System.Management.Automation.RuntimeDefinedParameterDictionary
# Convert to object array and get rid of Common params:
(Get-Command $CommandName | select -exp Parameters).GetEnumerator() |
Where-Object { $CommonParameterNames -notcontains $_.Key } |
ForEach-Object {
$DynamicParameter = New-Object System.Management.Automation.RuntimeDefinedParameter (
$_.Key,
$_.Value.ParameterType,
$_.Value.Attributes
)
$DynParamDictionary.Add($_.Key, $DynamicParameter)
}
# Return the dynamic parameters
return $DynParamDictionary
}
}
# GetDynamicParamDictionary
# - This can make it easier to share a single set of param definitions between functions
# - sample usage
#function ParameterDefinitions {
# param(
# [Parameter(Mandatory)][string] $myargument
# )
#}
#function psmain {
# [CmdletBinding()]
# param()
# dynamicparam { GetDynamicParamDictionary ParameterDefinitions }
# process {
# #called once with $PSBoundParameters dictionary
# #can be used to validate arguments, or set a simpler variable name for access
# switch ($PSBoundParameters.keys) {
# 'myargumentname' {
# Set-Variable -Name $_ -Value $PSBoundParameters."$_"
# }
# #...
# }
# foreach ($boundparam in $PSBoundParameters.GetEnumerator()) {
# #...
# }
# }
# end {
# #Main function logic
# Write-Host "myargumentname value is: $myargumentname"
# #myotherfunction @PSBoundParameters
# }
#}
#psmain @args
# -- --- --- --- --- --- --- --- --- --- --- --- --- ---begin powershell Payload
#"Timestamp : {0,10:yyyy-MM-dd HH:mm:ss}" -f $(Get-Date) | write-host
#"Script Name : {0}" -f $scriptname | write-host
#"Powershell Version: {0}" -f $PSVersionTable.PSVersion.Major | write-host
#"powershell args : {0}" -f ($args -join ", ") | write-host
# -- --- --- ---
#<powershell-pre-launch-subprocess>
#</powershell-pre-launch-subprocess>
# -- --- --- --- --- --- --- ---
#<powershell-launch-subprocess>
tclsh $scriptname $args
#"powershell reporting exitcode: {0}" -f $LASTEXITCODE | write-host
#</powershell-launch-subprocess>
# -- --- --- --- --- --- --- ---
#<powershell-post-launch-subprocess>
#</powershell-post-launch-subprocess>
# -- --- --- --- --- --- --- --- --- --- --- --- --- ---end powershell Payload
Exit $LASTEXITCODE
# heredoc2 for powershell to ignore block below
$1 = @'
'
: comment end hide powershell-block from Tcl \
# This comment with closing brace should stay in place whether 'if' commented or not }
: multishell doubled-up cmd exit label - return exitcode
:exit_multishell
:exit_multishell
: \
@REM @ECHO exitcode: !task_exitcode!
: \
@IF "is%qstrippedargs:~4,13%"=="isPUNK-ELEVATED" (echo. & @cmd /k echo elevated prompt: type exit to quit)
: \
@EXIT /B !task_exitcode!
# cmd has exited
: comment end heredoc2 \
'@
<#
# id:tailblock0
# -- powershell multiline comment
#>
<#
no script engine should try to run me
# id:tailblock1
# <ctrl-z>

# </ctrl-z>
# -- unreachable by tcl directly if ctrl-z character is in the <ctrl-z> section above. (but file can be read and split on \x1A)
# -- Potential for zip and/or base64 contents, but we can't stop pwsh parser from slurping in the data
# -- so for example a plain text tar archive could cause problems depending on the content.
# -- final line in file must be the powershell multiline comment terminator or other data it can handle.
# -- e.g plain # comment lines will work too
# -- (for example a powershell digital signature is a # commented block of data at the end of the file)
#>

25
src/scriptapps/example_wrap.toml
Unescape View File

@ -10,17 +10,30 @@
"example.sh"
]
default_outputfile="example_out.sh"
default_nextshellpath="/usr/bin/env tclsh"
default_nextshelltype="tcl"
default_outputfile='example_out.sh'
default_nextshellpath='/usr/bin/env tclsh'
default_nextshelltype='tcl'
#valid nextshelltype entries are: tcl perl powershell bash.
#nextshellpath entries must be 64 characters or less.
#review - zsh : bash-like, more appropriate license, but array index-base 1 vs 0?
#nextshellpath entries must be 128 characters or less.
# win32.nextshellpath="c:/program files/git/usr/bin/bash.exe"
#----------------
#experimental - cmd with spaces
#first level of quoting is for toml - for strings with no internal single quotes and no escaping - x='value'
# win32.nextshellpath='"c:\program files\git\usr\bin\bash.exe"'
# win32.nextshelltype="bash"
# win32.nextshellpath="c:/program files/powershell/7/pwsh.exe"
# win32.nextshellpath='"c:/program files/powershell/7/pwsh.exe" -nop -nol -ExecutionPolicy bypass -f'
# win32.nextshelltype='pwsh'
#----------------
# win32.nextshellpath="pwsh -nop -nol -ExecutionPolicy bypass -f"
# win32.nextshelltype="pwsh"
#cmd /c for older 'desktop' powershell (v5) to preserve arguments with spaces
# win32.nextshellpath="cmd /c powershell -nop -nol -ExecutionPolicy bypass -f"
# win32.nextshelltype="powershell"
win32.nextshellpath="tclsh"

Write Preview
Loading…
Cancel
Save