diff --git a/.gitignore b/.gitignore index 8ecbb93a..7fa98142 100644 --- a/.gitignore +++ b/.gitignore @@ -1,5 +1,6 @@ -*.lastrun +/*.lastrun +/*.ps1 #/bin/ /bin/* diff --git a/bin/fetchruntime.cmd b/bin/fetchruntime.cmd deleted file mode 100644 index f496014c..00000000 --- a/bin/fetchruntime.cmd +++ /dev/null @@ -1,1046 +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 Change the value of nextshell to one of the supported types, and add code within payload sections for tcl,sh,bash,powershell as appropriate. -@REM This wrapper can be edited manually (carefully!) - or bash,tcl,perl,powershell scripts can be wrapped using the Tcl-based punkshell system -@REM e.g from within a running punkshell: dev scriptwrap.multishell -outputfolder -@REM Call with sh, bash, perl, or tclsh. (powershell untested on unix) -@REM Due to lack of shebang (#! line) Unix-like systems will hopefully default to a flavour of sh that can divert to bash 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= pwsh____________ powershell______ sh______________ wslbash_________ bash____________ tcl_____________ perl____________ none____________" -@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 64 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 -: <> -@SET "nextshellpath[win32___________]=powershell______________________________________________________" -@SET "nextshelltype[win32___________]=powershell______" -@SET "nextshellpath[dragonflybsd____]=/usr/bin/env bash_______________________________________________" -@SET "nextshelltype[dragonflybsd____]=bash____________" -@SET "nextshellpath[freebsd_________]=/usr/bin/env bash_______________________________________________" -@SET "nextshelltype[freebsd_________]=bash____________" -@SET "nextshellpath[netbsd__________]=/usr/bin/env bash_______________________________________________" -@SET "nextshelltype[netbsd__________]=bash____________" -@SET "nextshellpath[linux___________]=/usr/bin/env bash_______________________________________________" -@SET "nextshelltype[linux___________]=bash____________" -@SET "nextshellpath[macosx__________]=/usr/bin/env bash_______________________________________________" -@SET "nextshelltype[macosx__________]=bash____________" -@SET "nextshellpath[other___________]=/usr/bin/env bash_______________________________________________" -@SET "nextshelltype[other___________]=bash____________" -: <> -@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). -: <> -@SET "asadmin=0" -: <> -@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 -@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 window 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!"=="none" ( - SET selected_shelltype_trimmed=pwsh -) -@IF "!selected_shelltype_trimmed!"=="pwsh" ( - REM pwsh 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 2>NUL; 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 TODO prompt user with option to call script to install pwsh using winget - REM powershell -nop -nol -c set-executionpolicy -Scope Process Unrestricted; "%~dp0%~n0.ps1" %arglist% - powershell -nop -nol -ExecutionPolicy Bypass -c "%~dp0%~n0.ps1" %arglist% - SET task_exitcode=!errorlevel! - ) -) ELSE ( - IF "!selected_shelltype_trimmed!"=="powershell" ( - powershell -nop -nol -ExecutionPolicy Bypass -c "%~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 - @ECHO HERE "!selected_shelltype_trimmed!" "!selected_shellpath_trimmed!" - %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 - 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 63 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 "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" -# -- --- --- --- --- --- --- --- --- --- --- --- - -# - -set url_kitbase "https://www.gitea1.intx.com.au/jn/punkbin/raw/branch/master" - -package require http -package require tls -http::register https 443 [list ::tls::socket -autoservername true] -package require platform -set plat [platform::identify] -set os [lindex [split $plat -] 0] -set runtime_available 0 -set scriptdir [file dirname [info script]] -switch -- $os { - "win32" { - set url "$url_kitbase/win32-x86_64/tclsh902z.exe" - set output [file join $scriptdir "../src/runtime/tclsh902z.exe"] - set runtime_available 1 - } - "linux" { - switch -glob -- $plat { - *x86_64 { - set url "$url_kitbase/linux-x86_64/tclkit-902-Linux64-intel-dyn" - set output [file join $scriptdir "../src/runtime/tclkit-902-Linux64-intel-dyn"] - set runtime_available 1 - } - *arm { - set url "$url_kitbase/linux-x86_64/tclkit-902-Linux64-arm-dyn" - set output [file join $scriptdir "../src/runtime/tclkit-902-Linux64-arm-dyn"] - set runtime_available 1 - } - default { - # - puts stderr "No runtime currently available for linux $::tcl_platform(machine)" - } - } - } - "macosx" { - set url "$url_kitbase/macosx/tclkit-902-Darwin64-dyn" - set output [file join $scriptdir "../src/runtime/tclkit-902-Darwin64-dyn"] - set runtime_available 1 - } - "freebsd" { - puts stderr "No runtime currently available for freebsd" - } - default { - puts stderr "No runtime currently available for $os" - } -} - -if {$runtime_available} { - if {[file exists $output]} { - puts stderr "Runtime already found at $output" - exit 1 - } - puts stdout "Attempting to download $url" - set fd [open $output wb] - set tok [http::geturl $url -channel $fd -binary 1] - close $fd - if {[http::status $tok] eq "ok" && [http::ncode $tok] == 200} { - puts "Download complete." - } - http::cleanup $tok -} - -# - -# -# - -# -# - - -# -# - - -# -- --- --- --- --- --- --- --- --- --- --- --- -# -- 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 -# csh/tcsh/sh/bash use oldschool backticks and sed lowest common denominator \ -echo "script: `echo $0 | sed 's/^-//'`" -# csh/tcsh/sh/bash use oldschool backticks and sed lowest common denominator \ -echo "shell: " `ps -p $$ | awk '$1 != "PID" {print $(NF)}' | tr -d '()' | sed -E 's/^.*\/|^-//'` -#csh/tcsh diversion \ -test "$argv[*]" != "[*]" && ( /usr/bin/env bash $argv[*]; exit ) -#other non-bash diversion \ -test `ps -p $$ | awk '$1 != "PID" {print $(NF)}' | tr -d '()' | sed -E 's/^.*\/|^-//'` != "bash" && /usr/bin/env bash $0 -#review \ -test `ps -p $$ | awk '$1 != "PID" {print $(NF)}' | tr -d '()' | sed -E 's/^.*\/|^-//'` != "bash" && exit -# sh/bash \ -shift && set -- "${@:1:$#-1}" - -#echo "shell:" `ps -o args= $$ | sed -E 's/^.*\/|^-//' | awk '{print $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. -# -- -# ## ### ### ### ### ### ### ### ### ### ### ### ### ### - -if [[ "$OSTYPE" == "linux"* ]]; then - os="linux" -elif [[ "$OSTYPE" == "darwin"* ]]; then - os="macosx" -elif [[ "$OSTYPE" == "freebsd"* ]]; then - os="freebsd" -elif [[ "$OSTYPE" == "dragonflybsd"* ]]; then - os="dragonflybsd" -elif [[ "$OSTYPE" == "netbsd"* ]]; then - os="netbsd" -elif [[ "$OSTYPE" == "win32" ]]; then - os="win32" -elif [[ "$OSTYPE" == "msys" ]]; then - echo MSYS - os="win32" - #review - need ps/sed/awk to determine shell? - interp = `ps -p $$ | awk '$1 != "PID" {print $(NF)}' | tr -d '()' | sed -E 's/^.*\/|^-//'` - #use 'command -v' (shell builtin preferred over external which) - shellpath=`command -v $interp` - shellfolder="${shellpath%/*}" #avoid dependency on basename or dirname - #"c:/windows/system32/" is quite likely in the path ahead of msys,git etc. - #This breaks calls to various unix utils such as sed etc (wsl related?) - export PATH="$shellfolder${PATH:+:${PATH}}" -else - #os="$OSTYPE" - os="other" -fi -echo ostype: $OSTYPE -shellconfigline=$( sed -n "/: <>/{:a;n;/: <>/q;p;ba}" "$0" | grep $os) -#echo $shellconfigline; -if [[ $shellconfigline == *"nextshelltype"* ]]; then - echo "found config for os $os" - split1="${shellconfigline#*=}" #remove everything through the first '=' - #echo "split1: $split1" - pathraw="${split1%%\"*}" #take everything before the quote - use %% to get longest match - pathraw="${pathraw//\"/}" #remove quote - nextshellpath="${pathraw/%_*/}" #remove trailing underscores (% = must match at end) - #echo "nextshellpath: $nextshellpath" - split2="${split1#*=}" - #echo "split2: $split2" - split2="${split2//\"/}" - nextshelltype="${split2/%_*/}" - echo "nextshelltype: $nextshelltype" -else - echo "unable to find config for os $os" - echo "shellconfigline: $shellconfigline" - nextshellpath="" - nextshelltype="" -fi -exitcode=0 -#-- sh/bash launches nextscript here instead of shebang line at top -if [[ "$nextshelltype" != "bash" && "$nextshelltype" != "none" ]]; then - #echo bash launching subshell of type $nextshelltype $nextshellpath on "$0" - #/usr/bin/env tclsh "$0" "$@" - ${nextshellpath} "$0" "$@" - - exitcode=$? - #echo "sh/bash reporting exitcode: ${exitcode}" - exit $exitcode - #-- override exitcode example - #exit 66 -else - #already in bash - don't launch another process or we would loop - #echo "bash payload" - : -fi -# -- --- --- --- --- --- --- --- --- --- --- --- --- ---begin sh Payload -#printf "start of bash or sh code" - -# - -url_kitbase="https://www.gitea1.intx.com.au/jn/punkbin/raw/branch/master" - -wdir="$(pwd)"; [ "$(pwd)" = "/" ] && wdir="" -case "$0" in - /*) scriptpath="${0}";; - *) scriptpath="$wdir/${0#./}";; -esac -scriptdir="${scriptpath%/*}" -scriptdir=$(realpath $scriptdir) -scriptpath=$(realpath $scriptpath) -basename=$(basename "$scriptpath") #e.g fetchruntime.bash -scriptroot="${basename%.*}" #e.g "fetchruntime" - - -runtime_available=0 -if [[ "$OSTYPE" == "linux"* ]]; then - arch=$(uname -i) - if [[ "$arch" == "x86_64"* ]]; then - url="${url_kitbase}/linux-x86_64/tclkit-902-Linux64-intel-dyn" - outdir="${scriptdir}/runtime/linux-x86_64"; mkdir -p $outdir - output="${outdir}/tclkit-902-Linux64-intel-dyn" - runtime_available=1 - elif [[ "$arch" == "arm"* ]]; then - url="${url_kitbase}/linux-arm/tclkit-902-Linux64-arm-dyn" - outdir="${scriptdir}/runtime/linux-arm"; mkdir -p $outdir - output="${outdir}/tclkit-902-Linux64-arm-dyn" - runtime_available=1 - fi - if [[ "$runtime_available" -eq 1 ]]; then - echo "Please ensure libxFt.so.2 is available" - echo "e.g on Ubuntu: sudo apt-get install libxft2" - fi - os="linux" -elif [[ "$OSTYPE" == "darwin"* ]]; then - os="macosx" - #assumed to be Mach-O 'universal binaries' for both x86-64 and arm? - REVIEW - url="${url_kitbase}/macosx/tclkit-902-Darwin64-dyn" - outdir="${scriptdir}/runtime/macosx/"; mkdir -p $outdir - output="${outdir}/tclkit-902-Darwin64-dyn" - runtime_available=1 -elif [[ "$OSTYPE" == "freebsd"* ]]; then - os="freebsd" -elif [[ "$OSTYPE" == "dragonflybsd"* ]]; then - os="dragonflybsd" -elif [[ "$OSTYPE" == "netbsd"* ]]; then - os="netbsd" -elif [[ "$OSTYPE" == "win32" ]]; then - os="win32" - url="${url_kitbase}/win32-x86_64/tclsh902z.exe" - outdir="${scriptdir}/runtime/win32-x86_64/"; mkdir -p $outdir - output="${outdir}/tcsh902z.exe" - runtime_available=1 -elif [[ "$OSTYPE" == "msys" ]]; then - echo MSYS - os="win32" - #use 'command -v' (shell builtin preferred over external which) - interp = `ps -p $$ | awk '$1 != "PID" {print $(NF)}' | tr -d '()' | sed -E 's/^.*\/|^-//'` - shellpath=`command -v $interp` - shellfolder="${shellpath%/*}" #avoid dependency on basename or dirname - #"c:/windows/system32/" is quite likely in the path ahead of msys,git etc. - #This breaks calls to various unix utils such as sed etc (wsl related?) - export PATH="$shellfolder${PATH:+:${PATH}}" - url="${url_kitbase}/win32-x86_64/tclsh902z.exe" - outdir="${scriptdir}/runtime/win32-x86_64/tclsh902z.exe"; mkdir -p $outdir - output="${outdir}/tclsh902z.exe" - runtime_available=1 -else - #os="$OSTYPE" - os="other" -fi - -if [[ "$runtime_available" -eq 1 ]]; then - #test win32 - echo "Attempting to download $url" - #wget $url -O $output - curl -SL --output "$output" "$url" - if [[ $? -eq 0 ]]; then - echo "File downloaded to $output" - chmod +x $output - else - echo "Error: Failed to download to $output" - fi -else - echo "No runtime currently available for $os" -fi - -# - -# -# - -# -- --- --- --- --- --- --- --- -# -#-- 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 -# -# -- --- --- --- --- --- --- --- - -# -# - - -#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 -my $exit_code = 0; -use Cwd qw(abs_path); -my $scriptname = abs_path($0); -#print "perl $scriptname\n"; -my $os = "$^O"; -if ($os eq "MSWin32") { - $os = "win32"; -} elsif ($os eq "darwin") { - $os = "macosx"; -} -print "os $os\n"; -# -- --- --- --- --- --- --- --- --- --- --- --- --- ---begin perl Payload -#use ExtUtils::Installed; -#my $installed = ExtUtils::Installed->new(); -#my @modules = $installed->modules(); -#print "Modules:\n"; -#foreach my $m (@modules) { -# print "$m\n"; -#} -# -- --- --- - - - -my $i =1; -foreach my $a(@ARGV) { - print "Arg # $i: $a\n"; -} - -# -print STDERR "No perl code for this script. Try another program such as tcl or bash"; -# - -# -# - - - -# -- --- --- --- --- --- --- --- -# -#$exit_code=system("tclsh", $scriptname, @ARGV); -#print "perl reporting tcl exitcode: $exit_code"; -# -# -- --- --- --- --- --- --- --- - -# -# - - -# -- --- --- --- --- --- --- --- --- --- --- --- --- ---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 -#"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 -# -- --- --- --- -$startTag = ": <>" -$endTag = ": <>" -$fileContent = Get-Content $scriptname -Raw -$pattern = "(?s)$startTag(.*?)$endTag" -$matches = [regex]::Matches($fileContent,$pattern) -$admininfo = $matches[0].Groups[1].Value -$asadmin = 0 -if ($matches.count) { - $asadmin = $admininfo.Contains("asadmin=1") - if ($asadmin) { - if (-not ([Security.Principal.WindowsPrincipal][Security.Principal.WindowsIdentity]::GetCurrent()).IsInRole([Security.Principal.WindowsBuiltInRole]::Administrator)) { - # If not elevated, relaunch with elevated privileges - # -Wait e.g for starting a service or other operations which remainder of script may depend on - $arguments = @("-NoProfile", "-NoExit", "-ExecutionPolicy", "Bypass") - $arguments += @("-File", $($MyInvocation.MyCommand.Path)) - $arguments += $args - if ($PSVersionTable.PSEdition -eq 'Core') { - Start-Process -FilePath "pwsh.exe" -ArgumentList $arguments -Wait -Verb RunAs - } else { - Start-Process -FilePath "powershell.exe" -ArgumentList $arguments -Wait -Verb RunAs - } - Exit # Exit the current non-elevated process - } - } -} -# -- --- --- --- --- --- --- --- --- --- --- --- --- ---begin powershell Payload - -# - -$url = "https://www.gitea1.intx.com.au/jn/punkbin/raw/branch/master/win32-x86_64/tclsh902z.exe" - -$outbase = $PSScriptRoot -$outbase = Resolve-Path -Path $outbase -#expected script location is the bin folder of a punk project -$rtfolder = Join-Path -Path $outbase -ChildPath "runtime" -#$output = "$(join-path $PSScriptRoot "..\src\runtime\tclsh902z.exe")" -$output = "$(join-path $rtfolder "win32-x86_64\tclsh902z.exe")" - -$container = split-path -Path $output -Parent -new-item -Path $container -ItemType Directory -force #create with intermediary folders if not already present - -if (-not(Test-Path -Path $output -PathType Leaf)) { - Write-Host "Downloading from $url ..." - Invoke-WebRequest -Uri $url -OutFile $output - Write-Host "Runtime saved at $output" -} else { - Write-Host "Runtime already found at $output" -} - - - -# - -# -# - - -# -- --- --- --- --- --- --- --- -# -#tclsh $scriptname $args -#"powershell reporting exitcode: {0}" -f $LASTEXITCODE | write-host -# -# -- --- --- --- --- --- --- --- - - -# -# - -# -- --- --- --- --- --- --- --- --- --- --- --- --- ---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 -# - -# -# -- unreachable by tcl directly if ctrl-z character is in the 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) -#> - - - diff --git a/bin/fetchruntime_old.cmd b/bin/fetchruntime_old.cmd deleted file mode 100644 index 558c0341..00000000 --- a/bin/fetchruntime_old.cmd +++ /dev/null @@ -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 -outputfolder -@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" -: -@SET "nextshell=10" -: -@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). -: -@SET "asadmin=0" -: -@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 -@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" -# -- --- --- --- --- --- --- --- --- --- --- --- - - -# -# - -# -# - - -# -# - - -# -- --- --- --- --- --- --- --- --- --- --- --- -# -- 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" - -# -# - -# -- --- --- --- --- --- --- --- -# -#-- 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 -# -# -- --- --- --- --- --- --- --- - -# -# - - -#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"; -} - -# -# - - - -# -- --- --- --- --- --- --- --- -# -$exit_code=system("tclsh", $scriptname, @ARGV); -#print "perl reporting tcl exitcode: $exit_code"; -# -# -- --- --- --- --- --- --- --- - -# -# - - -# -- --- --- --- --- --- --- --- --- --- --- --- --- ---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 -# -- --- --- --- - -# -$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" -} -# - - -# -- --- --- --- --- --- --- --- -# -tclsh $scriptname $args -#"powershell reporting exitcode: {0}" -f $LASTEXITCODE | write-host -# -# -- --- --- --- --- --- --- --- - - -# -# - -# -- --- --- --- --- --- --- --- --- --- --- --- --- ---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 -# - -# -# -- unreachable by tcl directly if ctrl-z character is in the 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) -#> - - diff --git a/bin/runtime.cmd b/bin/runtime.cmd index 167b4f1e..ac5676f9 100755 --- a/bin/runtime.cmd +++ b/bin/runtime.cmd @@ -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 = ": <>" $endTag = ": <>" $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 } } diff --git a/bin/sdx.bat b/bin/sdx.bat deleted file mode 100644 index f101ac61..00000000 --- a/bin/sdx.bat +++ /dev/null @@ -1,4 +0,0 @@ -::lindex tcl;#\ -@call "%~dp0..\src\runtime\tclkit86bi.exe" "%~dp0sdx.kit" %* & goto :eof -# --- --- --- --- --- --- --- --- --- --- --- --- ---begin comments only -# \ No newline at end of file diff --git a/bin/sdx.kit b/bin/sdx.kit index 4c70d7e7..f018a39e 100644 Binary files a/bin/sdx.kit and b/bin/sdx.kit differ diff --git a/scriptlib/stdout_per_second.tcl b/scriptlib/stdout_per_second.tcl index 51e72163..e55947c0 100644 --- a/scriptlib/stdout_per_second.tcl +++ b/scriptlib/stdout_per_second.tcl @@ -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] } - tailcall after $::ms ::schedule + 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} + diff --git a/scriptlib/utils/pwsh/consolemode.ps1 b/scriptlib/utils/pwsh/consolemode.ps1 new file mode 100644 index 00000000..3782421b --- /dev/null +++ b/scriptlib/utils/pwsh/consolemode.ps1 @@ -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 + + + diff --git a/scriptlib/utils/pwsh/consolemode_enableraw.ps1 b/scriptlib/utils/pwsh/consolemode_enableraw.ps1 new file mode 100644 index 00000000..c779ac5c --- /dev/null +++ b/scriptlib/utils/pwsh/consolemode_enableraw.ps1 @@ -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'; + diff --git a/scriptlib/utils/pwsh/consolemode_server.ps1 b/scriptlib/utils/pwsh/consolemode_server.ps1 new file mode 100644 index 00000000..69451158 --- /dev/null +++ b/scriptlib/utils/pwsh/consolemode_server.ps1 @@ -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= "" +}; +$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(); +}; + + diff --git a/scriptlib/utils/pwsh/consolemode_server_async.2ps1 b/scriptlib/utils/pwsh/consolemode_server_async.2ps1 new file mode 100644 index 00000000..6369058f --- /dev/null +++ b/scriptlib/utils/pwsh/consolemode_server_async.2ps1 @@ -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= "" +}; +$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(); + + diff --git a/scriptlib/utils/pwsh/consolemode_server_async.ps1 b/scriptlib/utils/pwsh/consolemode_server_async.ps1 new file mode 100644 index 00000000..1d188f6b --- /dev/null +++ b/scriptlib/utils/pwsh/consolemode_server_async.ps1 @@ -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= "" +}; +$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; + + + diff --git a/scriptlib/utils/pwsh/consolemode_server_async1.ps1 b/scriptlib/utils/pwsh/consolemode_server_async1.ps1 new file mode 100644 index 00000000..2b9cbe01 --- /dev/null +++ b/scriptlib/utils/pwsh/consolemode_server_async1.ps1 @@ -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= "" +}; +$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(); +#}; + + diff --git a/scriptlib/utils/pwsh/echotest.ps1 b/scriptlib/utils/pwsh/echotest.ps1 new file mode 100644 index 00000000..41c74841 --- /dev/null +++ b/scriptlib/utils/pwsh/echotest.ps1 @@ -0,0 +1 @@ +write-host "test" diff --git a/src/bootsupport/modules/punk/args-0.2.tm b/src/bootsupport/modules/punk/args-0.2.tm index a6224c0d..7b6ee228 100644 --- a/src/bootsupport/modules/punk/args-0.2.tm +++ b/src/bootsupport/modules/punk/args-0.2.tm @@ -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]" diff --git a/src/bootsupport/modules/punk/args/tclcore-0.1.0.tm b/src/bootsupport/modules/punk/args/tclcore-0.1.0.tm index d016c70a..6a4cc626 100644 --- a/src/bootsupport/modules/punk/args/tclcore-0.1.0.tm +++ b/src/bootsupport/modules/punk/args/tclcore-0.1.0.tm @@ -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\ diff --git a/src/bootsupport/modules/punk/console-0.1.1.tm b/src/bootsupport/modules/punk/console-0.1.1.tm index ea8d3f77..4d4518d3 100644 --- a/src/bootsupport/modules/punk/console-0.1.1.tm +++ b/src/bootsupport/modules/punk/console-0.1.1.tm @@ -129,57 +129,362 @@ namespace eval punk::console { #e.g external utils system API's. namespace export * } - + 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}]}] + + if {$has_twapi} { + #this is really enableAnsi *processing* + 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 + if {[catch {twapi::get_console_handle stdout} h_out]} { + puts stderr "enableAnsi failed: twapi cannot get console handle for stdout" + return + } - 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 + 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? + + twapi::SetConsoleMode $h_out $newmode_out + + #what does window_input have to do with it?? + #input handle modes + #ENABLE_PROCESSED_INPUT 0x0001 ;#set to zero will allow ctrl-c to be reported as keyboard input rather than as a signal + #ENABLE_LINE_INPUT 0x0002 + #ENABLE_ECHO_INPUT 0x0004 + #ENABLE_WINDOW_INPUT 0x0008 (default off when a terminal created) + #ENABLE_MOUSE_INPUT 0x0010 + #ENABLE_INSERT_MODE 0X0020 + #ENABLE_QUICK_EDIT_MODE 0x0040 + #ENABLE_VIRTUAL_TERMINAL_INPUT 0x0200 (default off when a terminal created) (512) + set h_in [twapi::get_console_handle stdin] + set oldmode_in [twapi::GetConsoleMode $h_in] + set newmode_in [expr {$oldmode_in | 8}] + #set newmode_in [expr {$oldmode_in | 0x208}] + + twapi::SetConsoleMode $h_in $newmode_in + + return [list stdout [list from $oldmode_out to $newmode_out] stdin [list from $oldmode_in to $newmode_in]] + } + proc disableAnsi {} { + set h_out [twapi::get_console_handle stdout] + set oldmode_out [twapi::GetConsoleMode $h_out] + set newmode_out [expr {$oldmode_out & ~4}] + twapi::SetConsoleMode $h_out $newmode_out + + #??? review + set h_in [twapi::get_console_handle stdin] + set oldmode_in [twapi::GetConsoleMode $h_in] + set newmode_in [expr {$oldmode_in & ~8}] + twapi::SetConsoleMode $h_in $newmode_in + + + return [list stdout [list from $oldmode_out to $newmode_out] stdin [list from $oldmode_in to $newmode_in]] + } + proc enableVirtualTerminal {{channels {input output}}} { + set ins [list in input stdin] + set outs [list out output stdout stderr] + set known [concat $ins $outs both] + set directions [list] + foreach v $channels { + if {$v in $ins} { + lappend directions input + } elseif {$v in $outs} { + lappend directions output + } elseif {$v eq "both"} { + lappend directions input output + } + if {$v ni $known} { + error "enableVirtualTerminal expected channel values to be one of '$known'. (all values mapped to input and/or output)" + } + } + set channels $directions ;#don't worry about dups. + if {"both" in $channels} { + lappend channels input output + } + set result [dict create] + if {"output" in $channels} { + #note setting stdout makes stderr have the same settings - ie there is really only one output to configure + set h_out [twapi::get_console_handle stdout] + set oldmode [twapi::GetConsoleMode $h_out] + set newmode [expr {$oldmode | 4}] + twapi::SetConsoleMode $h_out $newmode + dict set result output [list from $oldmode to $newmode] + } + + if {"input" in $channels} { + set h_in [twapi::get_console_handle stdin] + set oldmode_in [twapi::GetConsoleMode $h_in] + set newmode_in [expr {$oldmode_in | 0x200}] + twapi::SetConsoleMode $h_in $newmode_in + dict set result input [list from $oldmode_in to $newmode_in] + } + + return $result + } + + proc disableVirtualTerminal {{channels {input output}}} { + set ins [list in input stdin] + set outs [list out output stdout stderr] + set known [concat $ins $outs both] + set directions [list] + foreach v $channels { + if {$v in $ins} { + lappend directions input + } elseif {$v in $outs} { + lappend directions output + } elseif {$v eq "both"} { + lappend directions input output + } + if {$v ni $known} { + error "disableVirtualTerminal expected channel values to be one of '$known'. (all values mapped to input and/or output)" + } + } + set channels $directions ;#don't worry about dups. + if {"both" in $channels} { + lappend channels input output + } + set result [dict create] + if {"output" in $channels} { + #as above - configuring stdout does stderr too + set h_out [twapi::get_console_handle stdout] + set oldmode [twapi::GetConsoleMode $h_out] + set newmode [expr {$oldmode & ~4}] + twapi::SetConsoleMode $h_out $newmode + dict set result output [list from $oldmode to $newmode] + } + if {"input" in $channels} { + set h_in [twapi::get_console_handle stdin] + set oldmode_in [twapi::GetConsoleMode $h_in] + set newmode_in [expr {$oldmode_in & ~0x200}] + twapi::SetConsoleMode $h_in $newmode_in + dict set result input [list from $oldmode_in to $newmode_in] + } + + #return [list stdout [list from $oldmode_out to $newmode_out] stdin [list from $oldmode_in to $newmode_in]] + return $result + } + 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 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]] + } + + #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 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 { - #error vs noop? - puts stderr "Unable to set implementation for %f% - check twapi?" + 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 ;# ??? + } + 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]] } - }] + } + + } 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 "" $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 + } + } + + } + + + #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 {[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 + 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] + } + + exec {*}$sttycmd raw -echo <@$channel + tsv::set console is_raw 1 + #review - inconsistent return dict + return [dict create stdin [list from [set previous_stty_state_$channel] to "" note "fixme - to state not shown"]] + } else { + error "punk::console::enableRaw Unable to use twapi or stty to set raw mode - aborting" + } + } + + + proc disableRaw {{channel stdin}} { + 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 { + #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] + set previous_stty_state_$channel "" + return restored + } + exec {*}$sttycmd -raw echo <@$channel + tsv::set console is_raw 0 + #do we really want to exec stty yet again to show final 'to' state? + #probably not. We should work out how to read the stty result flags and set a result.. or just limit from,to to showing echo and lineedit states. + return [list stdin [list from "[set previous_stty_state_$channel]" to "" note "fixme - to state not shown"]] + } else { + 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? } @@ -190,6 +495,13 @@ namespace eval punk::console { #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}} { @@ -221,12 +533,6 @@ namespace eval punk::console { 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? @@ -257,7 +563,6 @@ namespace eval punk::console { #puts -nonewline stdout \x1b\[?25l ;#hide cursor puts -nonewline stdout \x1b\[?1003h\n enable_bracketed_paste - } #todo stop_application_mode {} {} @@ -313,266 +618,10 @@ namespace eval punk::console { } } 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.. - - #this is really enableAnsi *processing* - proc [namespace parent]::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] - 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? - - twapi::SetConsoleMode $h_out $newmode_out - - #what does window_input have to do with it?? - #input handle modes - #ENABLE_PROCESSED_INPUT 0x0001 ;#set to zero will allow ctrl-c to be reported as keyboard input rather than as a signal - #ENABLE_LINE_INPUT 0x0002 - #ENABLE_ECHO_INPUT 0x0004 - #ENABLE_WINDOW_INPUT 0x0008 (default off when a terminal created) - #ENABLE_MOUSE_INPUT 0x0010 - #ENABLE_INSERT_MODE 0X0020 - #ENABLE_QUICK_EDIT_MODE 0x0040 - #ENABLE_VIRTUAL_TERMINAL_INPUT 0x0200 (default off when a terminal created) (512) - set h_in [twapi::get_console_handle stdin] - set oldmode_in [twapi::GetConsoleMode $h_in] - set newmode_in [expr {$oldmode_in | 8}] - #set newmode_in [expr {$oldmode_in | 0x208}] - - twapi::SetConsoleMode $h_in $newmode_in - - return [list stdout [list from $oldmode_out to $newmode_out] stdin [list from $oldmode_in to $newmode_in]] - } - proc [namespace parent]::disableAnsi {} { - set h_out [twapi::get_console_handle stdout] - set oldmode_out [twapi::GetConsoleMode $h_out] - set newmode_out [expr {$oldmode_out & ~4}] - twapi::SetConsoleMode $h_out $newmode_out - #??? review - set h_in [twapi::get_console_handle stdin] - set oldmode_in [twapi::GetConsoleMode $h_in] - set newmode_in [expr {$oldmode_in & ~8}] - twapi::SetConsoleMode $h_in $newmode_in - - - 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}}} { - set ins [list in input stdin] - set outs [list out output stdout stderr] - set known [concat $ins $outs both] - set directions [list] - foreach v $channels { - if {$v in $ins} { - lappend directions input - } elseif {$v in $outs} { - lappend directions output - } elseif {$v eq "both"} { - lappend directions input output - } - if {$v ni $known} { - error "enableVirtualTerminal expected channel values to be one of '$known'. (all values mapped to input and/or output)" - } - } - set channels $directions ;#don't worry about dups. - if {"both" in $channels} { - lappend channels input output - } - set result [dict create] - if {"output" in $channels} { - #note setting stdout makes stderr have the same settings - ie there is really only one output to configure - set h_out [twapi::get_console_handle stdout] - set oldmode [twapi::GetConsoleMode $h_out] - set newmode [expr {$oldmode | 4}] - twapi::SetConsoleMode $h_out $newmode - dict set result output [list from $oldmode to $newmode] - } - - if {"input" in $channels} { - set h_in [twapi::get_console_handle stdin] - set oldmode_in [twapi::GetConsoleMode $h_in] - set newmode_in [expr {$oldmode_in | 0x200}] - twapi::SetConsoleMode $h_in $newmode_in - dict set result input [list from $oldmode_in to $newmode_in] - } - - return $result - } - proc [namespace parent]::disableVirtualTerminal {{channels {input output}}} { - set ins [list in input stdin] - set outs [list out output stdout stderr] - set known [concat $ins $outs both] - set directions [list] - foreach v $channels { - if {$v in $ins} { - lappend directions input - } elseif {$v in $outs} { - lappend directions output - } elseif {$v eq "both"} { - lappend directions input output - } - if {$v ni $known} { - error "disableVirtualTerminal expected channel values to be one of '$known'. (all values mapped to input and/or output)" - } - } - set channels $directions ;#don't worry about dups. - if {"both" in $channels} { - lappend channels input output - } - set result [dict create] - if {"output" in $channels} { - #as above - configuring stdout does stderr too - set h_out [twapi::get_console_handle stdout] - set oldmode [twapi::GetConsoleMode $h_out] - set newmode [expr {$oldmode & ~4}] - twapi::SetConsoleMode $h_out $newmode - dict set result output [list from $oldmode to $newmode] - } - if {"input" in $channels} { - set h_in [twapi::get_console_handle stdin] - set oldmode_in [twapi::GetConsoleMode $h_in] - set newmode_in [expr {$oldmode_in & ~0x200}] - twapi::SetConsoleMode $h_in $newmode_in - dict set result input [list from $oldmode_in to $newmode_in] - } - - #return [list stdout [list from $oldmode_out to $newmode_out] stdin [list from $oldmode_in to $newmode_in]] - return $result - } - - proc [namespace parent]::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 {} { - 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]] - } - } else { - - 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 [namespace parent]::enableVirtualTerminal {{channels {input output}}} { - } - proc [namespace parent]::disableVirtualTerminal {{channels {input output}}} { - } - proc [namespace parent]::enableProcessedInput {args} { - - } - proc [namespace parent]::disableProcessedInput {args} { - - } - - } - - proc [namespace parent]::enableRaw {{channel stdin}} { - #variable is_raw - variable previous_stty_state_$channel - - 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] - - 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]] - } elseif {[set sttycmd [auto_execok stty]] ne ""} { - if {[set previous_stty_state_$channel] eq ""} { - set previous_stty_state_$channel [exec {*}$sttycmd -g <@$channel] - } - - exec {*}$sttycmd raw -echo <@$channel - tsv::set console is_raw 1 - #review - inconsistent return dict - return [dict create stdin [list from [set previous_stty_state_$channel] to "" note "fixme - to state not shown"]] - } else { - error "punk::console::enableRaw Unable to use twapi or stty to set raw mode - aborting" - } - } - - #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 - 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] - 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? - - set sttycmd [auto_execok stty] - if {[set previous_stty_state_$channel] ne ""} { - exec {*}$sttycmd [set previous_stty_state_$channel] - set previous_stty_state_$channel "" - return restored - } - exec {*}$sttycmd -raw echo <@$channel - tsv::set console is_raw 0 - #do we really want to exec stty yet again to show final 'to' state? - #probably not. We should work out how to read the stty result flags and set a result.. or just limit from,to to showing echo and lineedit states. - return [list stdin [list from "[set previous_stty_state_$channel]" to "" note "fixme - to state not shown"]] - } else { - error "punk::console::disableRaw Unable to use twapi or stty to unset raw mode - aborting" - } - } - - } lappend PUNKARGS [list { @@ -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 diff --git a/src/bootsupport/modules/punk/libunknown-0.1.tm b/src/bootsupport/modules/punk/libunknown-0.1.tm index 3b5d35b0..f9dfaf56 100644 --- a/src/bootsupport/modules/punk/libunknown-0.1.tm +++ b/src/bootsupport/modules/punk/libunknown-0.1.tm @@ -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 diff --git a/src/bootsupport/modules/punk/repl-0.1.2.tm b/src/bootsupport/modules/punk/repl-0.1.2.tm index 9d199997..11cd9706 100644 --- a/src/bootsupport/modules/punk/repl-0.1.2.tm +++ b/src/bootsupport/modules/punk/repl-0.1.2.tm @@ -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" } } diff --git a/src/bootsupport/modules_tcl8/Thread-2.8.9.tm b/src/bootsupport/modules_tcl8/Thread-2.8.9.tm deleted file mode 100644 index 45c8b5c6..00000000 Binary files a/src/bootsupport/modules_tcl8/Thread-2.8.9.tm and /dev/null differ diff --git a/src/bootsupport/modules_tcl8/include_modules.config b/src/bootsupport/modules_tcl8/include_modules.config index c65f2a8a..090a7cf6 100644 --- a/src/bootsupport/modules_tcl8/include_modules.config +++ b/src/bootsupport/modules_tcl8/include_modules.config @@ -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 *\ diff --git a/src/bootsupport/modules_tcl8/thread/platform/win32_x86_64_tcl8-2.8.9.tm b/src/bootsupport/modules_tcl8/thread/platform/win32_x86_64_tcl8-2.8.9.tm deleted file mode 100644 index d50bcf4a..00000000 Binary files a/src/bootsupport/modules_tcl8/thread/platform/win32_x86_64_tcl8-2.8.9.tm and /dev/null differ diff --git a/src/bootsupport/modules_tcl8/win32_x86_64_tcl8-2.8.9.tm b/src/bootsupport/modules_tcl8/win32_x86_64_tcl8-2.8.9.tm deleted file mode 100644 index d50bcf4a..00000000 Binary files a/src/bootsupport/modules_tcl8/win32_x86_64_tcl8-2.8.9.tm and /dev/null differ diff --git a/src/lib/app-punk/repl.tcl b/src/lib/app-punk/repl.tcl index 3474eff0..c9fb0ed5 100644 --- a/src/lib/app-punk/repl.tcl +++ b/src/lib/app-punk/repl.tcl @@ -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" - flush stdout + if {$replresult ne ""} { + #puts stdout "repl.tcl result $replresult" + puts stdout $replresult + flush stdout + } exit 0 } #puts "- repl app done -" diff --git a/src/lib/app-punkshell/punkshell.tcl b/src/lib/app-punkshell/punkshell.tcl index 1559f0ec..828d6da8 100644 --- a/src/lib/app-punkshell/punkshell.tcl +++ b/src/lib/app-punkshell/punkshell.tcl @@ -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 diff --git a/src/make.tcl b/src/make.tcl index 1736d3d9..c1d3f906 100644 --- a/src/make.tcl +++ b/src/make.tcl @@ -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 diff --git a/src/modules/punk/args-999999.0a1.0.tm b/src/modules/punk/args-999999.0a1.0.tm index 8e55fdd5..fa8b6564 100644 --- a/src/modules/punk/args-999999.0a1.0.tm +++ b/src/modules/punk/args-999999.0a1.0.tm @@ -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]" diff --git a/src/modules/punk/args/tclcore-999999.0a1.0.tm b/src/modules/punk/args/tclcore-999999.0a1.0.tm index b5ff24ab..13141580 100644 --- a/src/modules/punk/args/tclcore-999999.0a1.0.tm +++ b/src/modules/punk/args/tclcore-999999.0a1.0.tm @@ -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\ diff --git a/src/modules/punk/console-999999.0a1.0.tm b/src/modules/punk/console-999999.0a1.0.tm index 3e973dcc..f9f9bcef 100644 --- a/src/modules/punk/console-999999.0a1.0.tm +++ b/src/modules/punk/console-999999.0a1.0.tm @@ -129,57 +129,362 @@ namespace eval punk::console { #e.g external utils system API's. namespace export * } - + 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}]}] + + if {$has_twapi} { + #this is really enableAnsi *processing* + 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 + if {[catch {twapi::get_console_handle stdout} h_out]} { + puts stderr "enableAnsi failed: twapi cannot get console handle for stdout" + return + } - 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 + 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? + + twapi::SetConsoleMode $h_out $newmode_out + + #what does window_input have to do with it?? + #input handle modes + #ENABLE_PROCESSED_INPUT 0x0001 ;#set to zero will allow ctrl-c to be reported as keyboard input rather than as a signal + #ENABLE_LINE_INPUT 0x0002 + #ENABLE_ECHO_INPUT 0x0004 + #ENABLE_WINDOW_INPUT 0x0008 (default off when a terminal created) + #ENABLE_MOUSE_INPUT 0x0010 + #ENABLE_INSERT_MODE 0X0020 + #ENABLE_QUICK_EDIT_MODE 0x0040 + #ENABLE_VIRTUAL_TERMINAL_INPUT 0x0200 (default off when a terminal created) (512) + set h_in [twapi::get_console_handle stdin] + set oldmode_in [twapi::GetConsoleMode $h_in] + set newmode_in [expr {$oldmode_in | 8}] + #set newmode_in [expr {$oldmode_in | 0x208}] + + twapi::SetConsoleMode $h_in $newmode_in + + return [list stdout [list from $oldmode_out to $newmode_out] stdin [list from $oldmode_in to $newmode_in]] + } + proc disableAnsi {} { + set h_out [twapi::get_console_handle stdout] + set oldmode_out [twapi::GetConsoleMode $h_out] + set newmode_out [expr {$oldmode_out & ~4}] + twapi::SetConsoleMode $h_out $newmode_out + + #??? review + set h_in [twapi::get_console_handle stdin] + set oldmode_in [twapi::GetConsoleMode $h_in] + set newmode_in [expr {$oldmode_in & ~8}] + twapi::SetConsoleMode $h_in $newmode_in + + + return [list stdout [list from $oldmode_out to $newmode_out] stdin [list from $oldmode_in to $newmode_in]] + } + proc enableVirtualTerminal {{channels {input output}}} { + set ins [list in input stdin] + set outs [list out output stdout stderr] + set known [concat $ins $outs both] + set directions [list] + foreach v $channels { + if {$v in $ins} { + lappend directions input + } elseif {$v in $outs} { + lappend directions output + } elseif {$v eq "both"} { + lappend directions input output + } + if {$v ni $known} { + error "enableVirtualTerminal expected channel values to be one of '$known'. (all values mapped to input and/or output)" + } + } + set channels $directions ;#don't worry about dups. + if {"both" in $channels} { + lappend channels input output + } + set result [dict create] + if {"output" in $channels} { + #note setting stdout makes stderr have the same settings - ie there is really only one output to configure + set h_out [twapi::get_console_handle stdout] + set oldmode [twapi::GetConsoleMode $h_out] + set newmode [expr {$oldmode | 4}] + twapi::SetConsoleMode $h_out $newmode + dict set result output [list from $oldmode to $newmode] + } + + if {"input" in $channels} { + set h_in [twapi::get_console_handle stdin] + set oldmode_in [twapi::GetConsoleMode $h_in] + set newmode_in [expr {$oldmode_in | 0x200}] + twapi::SetConsoleMode $h_in $newmode_in + dict set result input [list from $oldmode_in to $newmode_in] + } + + return $result + } + + proc disableVirtualTerminal {{channels {input output}}} { + set ins [list in input stdin] + set outs [list out output stdout stderr] + set known [concat $ins $outs both] + set directions [list] + foreach v $channels { + if {$v in $ins} { + lappend directions input + } elseif {$v in $outs} { + lappend directions output + } elseif {$v eq "both"} { + lappend directions input output + } + if {$v ni $known} { + error "disableVirtualTerminal expected channel values to be one of '$known'. (all values mapped to input and/or output)" + } + } + set channels $directions ;#don't worry about dups. + if {"both" in $channels} { + lappend channels input output + } + set result [dict create] + if {"output" in $channels} { + #as above - configuring stdout does stderr too + set h_out [twapi::get_console_handle stdout] + set oldmode [twapi::GetConsoleMode $h_out] + set newmode [expr {$oldmode & ~4}] + twapi::SetConsoleMode $h_out $newmode + dict set result output [list from $oldmode to $newmode] + } + if {"input" in $channels} { + set h_in [twapi::get_console_handle stdin] + set oldmode_in [twapi::GetConsoleMode $h_in] + set newmode_in [expr {$oldmode_in & ~0x200}] + twapi::SetConsoleMode $h_in $newmode_in + dict set result input [list from $oldmode_in to $newmode_in] + } + + #return [list stdout [list from $oldmode_out to $newmode_out] stdin [list from $oldmode_in to $newmode_in]] + return $result + } + 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 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]] + } + + #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 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 { - #error vs noop? - puts stderr "Unable to set implementation for %f% - check twapi?" + 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 ;# ??? + } + 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]] } - }] + } + + } 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 "" $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 + } + } + + } + + + #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 {[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 + #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] + } + + exec {*}$sttycmd raw -echo <@$channel + tsv::set console is_raw 1 + #review - inconsistent return dict + return [dict create stdin [list from [set previous_stty_state_$channel] to "" note "fixme - to state not shown"]] + } else { + error "punk::console::enableRaw Unable to use twapi or stty to set raw mode - aborting" + } + } + + + proc disableRaw {{channel stdin}} { + 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 { + #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] + set previous_stty_state_$channel "" + return restored + } + exec {*}$sttycmd -raw echo <@$channel + tsv::set console is_raw 0 + #do we really want to exec stty yet again to show final 'to' state? + #probably not. We should work out how to read the stty result flags and set a result.. or just limit from,to to showing echo and lineedit states. + return [list stdin [list from "[set previous_stty_state_$channel]" to "" note "fixme - to state not shown"]] + } else { + 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? } @@ -190,6 +495,13 @@ namespace eval punk::console { #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}} { @@ -221,12 +533,6 @@ namespace eval punk::console { 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? @@ -257,7 +563,6 @@ namespace eval punk::console { #puts -nonewline stdout \x1b\[?25l ;#hide cursor puts -nonewline stdout \x1b\[?1003h\n enable_bracketed_paste - } #todo stop_application_mode {} {} @@ -313,266 +618,10 @@ namespace eval punk::console { } } 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.. - - #this is really enableAnsi *processing* - proc [namespace parent]::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] - 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? - - twapi::SetConsoleMode $h_out $newmode_out - - #what does window_input have to do with it?? - #input handle modes - #ENABLE_PROCESSED_INPUT 0x0001 ;#set to zero will allow ctrl-c to be reported as keyboard input rather than as a signal - #ENABLE_LINE_INPUT 0x0002 - #ENABLE_ECHO_INPUT 0x0004 - #ENABLE_WINDOW_INPUT 0x0008 (default off when a terminal created) - #ENABLE_MOUSE_INPUT 0x0010 - #ENABLE_INSERT_MODE 0X0020 - #ENABLE_QUICK_EDIT_MODE 0x0040 - #ENABLE_VIRTUAL_TERMINAL_INPUT 0x0200 (default off when a terminal created) (512) - set h_in [twapi::get_console_handle stdin] - set oldmode_in [twapi::GetConsoleMode $h_in] - set newmode_in [expr {$oldmode_in | 8}] - #set newmode_in [expr {$oldmode_in | 0x208}] - - twapi::SetConsoleMode $h_in $newmode_in - - return [list stdout [list from $oldmode_out to $newmode_out] stdin [list from $oldmode_in to $newmode_in]] - } - proc [namespace parent]::disableAnsi {} { - set h_out [twapi::get_console_handle stdout] - set oldmode_out [twapi::GetConsoleMode $h_out] - set newmode_out [expr {$oldmode_out & ~4}] - twapi::SetConsoleMode $h_out $newmode_out - #??? review - set h_in [twapi::get_console_handle stdin] - set oldmode_in [twapi::GetConsoleMode $h_in] - set newmode_in [expr {$oldmode_in & ~8}] - twapi::SetConsoleMode $h_in $newmode_in - - - 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}}} { - set ins [list in input stdin] - set outs [list out output stdout stderr] - set known [concat $ins $outs both] - set directions [list] - foreach v $channels { - if {$v in $ins} { - lappend directions input - } elseif {$v in $outs} { - lappend directions output - } elseif {$v eq "both"} { - lappend directions input output - } - if {$v ni $known} { - error "enableVirtualTerminal expected channel values to be one of '$known'. (all values mapped to input and/or output)" - } - } - set channels $directions ;#don't worry about dups. - if {"both" in $channels} { - lappend channels input output - } - set result [dict create] - if {"output" in $channels} { - #note setting stdout makes stderr have the same settings - ie there is really only one output to configure - set h_out [twapi::get_console_handle stdout] - set oldmode [twapi::GetConsoleMode $h_out] - set newmode [expr {$oldmode | 4}] - twapi::SetConsoleMode $h_out $newmode - dict set result output [list from $oldmode to $newmode] - } - - if {"input" in $channels} { - set h_in [twapi::get_console_handle stdin] - set oldmode_in [twapi::GetConsoleMode $h_in] - set newmode_in [expr {$oldmode_in | 0x200}] - twapi::SetConsoleMode $h_in $newmode_in - dict set result input [list from $oldmode_in to $newmode_in] - } - - return $result - } - proc [namespace parent]::disableVirtualTerminal {{channels {input output}}} { - set ins [list in input stdin] - set outs [list out output stdout stderr] - set known [concat $ins $outs both] - set directions [list] - foreach v $channels { - if {$v in $ins} { - lappend directions input - } elseif {$v in $outs} { - lappend directions output - } elseif {$v eq "both"} { - lappend directions input output - } - if {$v ni $known} { - error "disableVirtualTerminal expected channel values to be one of '$known'. (all values mapped to input and/or output)" - } - } - set channels $directions ;#don't worry about dups. - if {"both" in $channels} { - lappend channels input output - } - set result [dict create] - if {"output" in $channels} { - #as above - configuring stdout does stderr too - set h_out [twapi::get_console_handle stdout] - set oldmode [twapi::GetConsoleMode $h_out] - set newmode [expr {$oldmode & ~4}] - twapi::SetConsoleMode $h_out $newmode - dict set result output [list from $oldmode to $newmode] - } - if {"input" in $channels} { - set h_in [twapi::get_console_handle stdin] - set oldmode_in [twapi::GetConsoleMode $h_in] - set newmode_in [expr {$oldmode_in & ~0x200}] - twapi::SetConsoleMode $h_in $newmode_in - dict set result input [list from $oldmode_in to $newmode_in] - } - - #return [list stdout [list from $oldmode_out to $newmode_out] stdin [list from $oldmode_in to $newmode_in]] - return $result - } - - proc [namespace parent]::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 {} { - 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]] - } - } else { - - 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 [namespace parent]::enableVirtualTerminal {{channels {input output}}} { - } - proc [namespace parent]::disableVirtualTerminal {{channels {input output}}} { - } - proc [namespace parent]::enableProcessedInput {args} { - - } - proc [namespace parent]::disableProcessedInput {args} { - - } - - } - - proc [namespace parent]::enableRaw {{channel stdin}} { - #variable is_raw - variable previous_stty_state_$channel - - 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] - - 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]] - } elseif {[set sttycmd [auto_execok stty]] ne ""} { - if {[set previous_stty_state_$channel] eq ""} { - set previous_stty_state_$channel [exec {*}$sttycmd -g <@$channel] - } - - exec {*}$sttycmd raw -echo <@$channel - tsv::set console is_raw 1 - #review - inconsistent return dict - return [dict create stdin [list from [set previous_stty_state_$channel] to "" note "fixme - to state not shown"]] - } else { - error "punk::console::enableRaw Unable to use twapi or stty to set raw mode - aborting" - } - } - - #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 - 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] - 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? - - set sttycmd [auto_execok stty] - if {[set previous_stty_state_$channel] ne ""} { - exec {*}$sttycmd [set previous_stty_state_$channel] - set previous_stty_state_$channel "" - return restored - } - exec {*}$sttycmd -raw echo <@$channel - tsv::set console is_raw 0 - #do we really want to exec stty yet again to show final 'to' state? - #probably not. We should work out how to read the stty result flags and set a result.. or just limit from,to to showing echo and lineedit states. - return [list stdin [list from "[set previous_stty_state_$channel]" to "" note "fixme - to state not shown"]] - } else { - error "punk::console::disableRaw Unable to use twapi or stty to unset raw mode - aborting" - } - } - - } lappend PUNKARGS [list { @@ -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 diff --git a/src/modules/punk/libunknown-0.1.tm b/src/modules/punk/libunknown-0.1.tm index 3b5d35b0..f9dfaf56 100644 --- a/src/modules/punk/libunknown-0.1.tm +++ b/src/modules/punk/libunknown-0.1.tm @@ -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 diff --git a/src/modules/punk/mix/templates/utility/scriptappwrappers/multishell.cmd b/src/modules/punk/mix/templates/utility/scriptappwrappers/multishell.cmd index 23e2b8db..3bf8e0b1 100644 --- a/src/modules/punk/mix/templates/utility/scriptappwrappers/multishell.cmd +++ b/src/modules/punk/mix/templates/utility/scriptappwrappers/multishell.cmd @@ -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 = ": <>" $endTag = ": <>" $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 } } diff --git a/src/modules/punk/repl-999999.0a1.0.tm b/src/modules/punk/repl-999999.0a1.0.tm index a8a5afe8..2ccca79d 100644 --- a/src/modules/punk/repl-999999.0a1.0.tm +++ b/src/modules/punk/repl-999999.0a1.0.tm @@ -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" } } diff --git a/src/project_layouts/custom/_project/punk.basic/src/make.tcl b/src/project_layouts/custom/_project/punk.basic/src/make.tcl index 1736d3d9..c1d3f906 100644 --- a/src/project_layouts/custom/_project/punk.basic/src/make.tcl +++ b/src/project_layouts/custom/_project/punk.basic/src/make.tcl @@ -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 diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args-0.2.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args-0.2.tm index a6224c0d..7b6ee228 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args-0.2.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args-0.2.tm @@ -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]" diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args/tclcore-0.1.0.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args/tclcore-0.1.0.tm index d016c70a..6a4cc626 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args/tclcore-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args/tclcore-0.1.0.tm @@ -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\ diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/console-0.1.1.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/console-0.1.1.tm index ea8d3f77..4d4518d3 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/console-0.1.1.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/console-0.1.1.tm @@ -129,57 +129,362 @@ namespace eval punk::console { #e.g external utils system API's. namespace export * } - + 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}]}] + + if {$has_twapi} { + #this is really enableAnsi *processing* + 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 + if {[catch {twapi::get_console_handle stdout} h_out]} { + puts stderr "enableAnsi failed: twapi cannot get console handle for stdout" + return + } - 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 + 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? + + twapi::SetConsoleMode $h_out $newmode_out + + #what does window_input have to do with it?? + #input handle modes + #ENABLE_PROCESSED_INPUT 0x0001 ;#set to zero will allow ctrl-c to be reported as keyboard input rather than as a signal + #ENABLE_LINE_INPUT 0x0002 + #ENABLE_ECHO_INPUT 0x0004 + #ENABLE_WINDOW_INPUT 0x0008 (default off when a terminal created) + #ENABLE_MOUSE_INPUT 0x0010 + #ENABLE_INSERT_MODE 0X0020 + #ENABLE_QUICK_EDIT_MODE 0x0040 + #ENABLE_VIRTUAL_TERMINAL_INPUT 0x0200 (default off when a terminal created) (512) + set h_in [twapi::get_console_handle stdin] + set oldmode_in [twapi::GetConsoleMode $h_in] + set newmode_in [expr {$oldmode_in | 8}] + #set newmode_in [expr {$oldmode_in | 0x208}] + + twapi::SetConsoleMode $h_in $newmode_in + + return [list stdout [list from $oldmode_out to $newmode_out] stdin [list from $oldmode_in to $newmode_in]] + } + proc disableAnsi {} { + set h_out [twapi::get_console_handle stdout] + set oldmode_out [twapi::GetConsoleMode $h_out] + set newmode_out [expr {$oldmode_out & ~4}] + twapi::SetConsoleMode $h_out $newmode_out + + #??? review + set h_in [twapi::get_console_handle stdin] + set oldmode_in [twapi::GetConsoleMode $h_in] + set newmode_in [expr {$oldmode_in & ~8}] + twapi::SetConsoleMode $h_in $newmode_in + + + return [list stdout [list from $oldmode_out to $newmode_out] stdin [list from $oldmode_in to $newmode_in]] + } + proc enableVirtualTerminal {{channels {input output}}} { + set ins [list in input stdin] + set outs [list out output stdout stderr] + set known [concat $ins $outs both] + set directions [list] + foreach v $channels { + if {$v in $ins} { + lappend directions input + } elseif {$v in $outs} { + lappend directions output + } elseif {$v eq "both"} { + lappend directions input output + } + if {$v ni $known} { + error "enableVirtualTerminal expected channel values to be one of '$known'. (all values mapped to input and/or output)" + } + } + set channels $directions ;#don't worry about dups. + if {"both" in $channels} { + lappend channels input output + } + set result [dict create] + if {"output" in $channels} { + #note setting stdout makes stderr have the same settings - ie there is really only one output to configure + set h_out [twapi::get_console_handle stdout] + set oldmode [twapi::GetConsoleMode $h_out] + set newmode [expr {$oldmode | 4}] + twapi::SetConsoleMode $h_out $newmode + dict set result output [list from $oldmode to $newmode] + } + + if {"input" in $channels} { + set h_in [twapi::get_console_handle stdin] + set oldmode_in [twapi::GetConsoleMode $h_in] + set newmode_in [expr {$oldmode_in | 0x200}] + twapi::SetConsoleMode $h_in $newmode_in + dict set result input [list from $oldmode_in to $newmode_in] + } + + return $result + } + + proc disableVirtualTerminal {{channels {input output}}} { + set ins [list in input stdin] + set outs [list out output stdout stderr] + set known [concat $ins $outs both] + set directions [list] + foreach v $channels { + if {$v in $ins} { + lappend directions input + } elseif {$v in $outs} { + lappend directions output + } elseif {$v eq "both"} { + lappend directions input output + } + if {$v ni $known} { + error "disableVirtualTerminal expected channel values to be one of '$known'. (all values mapped to input and/or output)" + } + } + set channels $directions ;#don't worry about dups. + if {"both" in $channels} { + lappend channels input output + } + set result [dict create] + if {"output" in $channels} { + #as above - configuring stdout does stderr too + set h_out [twapi::get_console_handle stdout] + set oldmode [twapi::GetConsoleMode $h_out] + set newmode [expr {$oldmode & ~4}] + twapi::SetConsoleMode $h_out $newmode + dict set result output [list from $oldmode to $newmode] + } + if {"input" in $channels} { + set h_in [twapi::get_console_handle stdin] + set oldmode_in [twapi::GetConsoleMode $h_in] + set newmode_in [expr {$oldmode_in & ~0x200}] + twapi::SetConsoleMode $h_in $newmode_in + dict set result input [list from $oldmode_in to $newmode_in] + } + + #return [list stdout [list from $oldmode_out to $newmode_out] stdin [list from $oldmode_in to $newmode_in]] + return $result + } + 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 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]] + } + + #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 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 { - #error vs noop? - puts stderr "Unable to set implementation for %f% - check twapi?" + 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 ;# ??? + } + 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]] } - }] + } + + } 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 "" $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 + } + } + + } + + + #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 {[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 + 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] + } + + exec {*}$sttycmd raw -echo <@$channel + tsv::set console is_raw 1 + #review - inconsistent return dict + return [dict create stdin [list from [set previous_stty_state_$channel] to "" note "fixme - to state not shown"]] + } else { + error "punk::console::enableRaw Unable to use twapi or stty to set raw mode - aborting" + } + } + + + proc disableRaw {{channel stdin}} { + 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 { + #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] + set previous_stty_state_$channel "" + return restored + } + exec {*}$sttycmd -raw echo <@$channel + tsv::set console is_raw 0 + #do we really want to exec stty yet again to show final 'to' state? + #probably not. We should work out how to read the stty result flags and set a result.. or just limit from,to to showing echo and lineedit states. + return [list stdin [list from "[set previous_stty_state_$channel]" to "" note "fixme - to state not shown"]] + } else { + 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? } @@ -190,6 +495,13 @@ namespace eval punk::console { #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}} { @@ -221,12 +533,6 @@ namespace eval punk::console { 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? @@ -257,7 +563,6 @@ namespace eval punk::console { #puts -nonewline stdout \x1b\[?25l ;#hide cursor puts -nonewline stdout \x1b\[?1003h\n enable_bracketed_paste - } #todo stop_application_mode {} {} @@ -313,266 +618,10 @@ namespace eval punk::console { } } 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.. - - #this is really enableAnsi *processing* - proc [namespace parent]::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] - 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? - - twapi::SetConsoleMode $h_out $newmode_out - - #what does window_input have to do with it?? - #input handle modes - #ENABLE_PROCESSED_INPUT 0x0001 ;#set to zero will allow ctrl-c to be reported as keyboard input rather than as a signal - #ENABLE_LINE_INPUT 0x0002 - #ENABLE_ECHO_INPUT 0x0004 - #ENABLE_WINDOW_INPUT 0x0008 (default off when a terminal created) - #ENABLE_MOUSE_INPUT 0x0010 - #ENABLE_INSERT_MODE 0X0020 - #ENABLE_QUICK_EDIT_MODE 0x0040 - #ENABLE_VIRTUAL_TERMINAL_INPUT 0x0200 (default off when a terminal created) (512) - set h_in [twapi::get_console_handle stdin] - set oldmode_in [twapi::GetConsoleMode $h_in] - set newmode_in [expr {$oldmode_in | 8}] - #set newmode_in [expr {$oldmode_in | 0x208}] - - twapi::SetConsoleMode $h_in $newmode_in - - return [list stdout [list from $oldmode_out to $newmode_out] stdin [list from $oldmode_in to $newmode_in]] - } - proc [namespace parent]::disableAnsi {} { - set h_out [twapi::get_console_handle stdout] - set oldmode_out [twapi::GetConsoleMode $h_out] - set newmode_out [expr {$oldmode_out & ~4}] - twapi::SetConsoleMode $h_out $newmode_out - #??? review - set h_in [twapi::get_console_handle stdin] - set oldmode_in [twapi::GetConsoleMode $h_in] - set newmode_in [expr {$oldmode_in & ~8}] - twapi::SetConsoleMode $h_in $newmode_in - - - 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}}} { - set ins [list in input stdin] - set outs [list out output stdout stderr] - set known [concat $ins $outs both] - set directions [list] - foreach v $channels { - if {$v in $ins} { - lappend directions input - } elseif {$v in $outs} { - lappend directions output - } elseif {$v eq "both"} { - lappend directions input output - } - if {$v ni $known} { - error "enableVirtualTerminal expected channel values to be one of '$known'. (all values mapped to input and/or output)" - } - } - set channels $directions ;#don't worry about dups. - if {"both" in $channels} { - lappend channels input output - } - set result [dict create] - if {"output" in $channels} { - #note setting stdout makes stderr have the same settings - ie there is really only one output to configure - set h_out [twapi::get_console_handle stdout] - set oldmode [twapi::GetConsoleMode $h_out] - set newmode [expr {$oldmode | 4}] - twapi::SetConsoleMode $h_out $newmode - dict set result output [list from $oldmode to $newmode] - } - - if {"input" in $channels} { - set h_in [twapi::get_console_handle stdin] - set oldmode_in [twapi::GetConsoleMode $h_in] - set newmode_in [expr {$oldmode_in | 0x200}] - twapi::SetConsoleMode $h_in $newmode_in - dict set result input [list from $oldmode_in to $newmode_in] - } - - return $result - } - proc [namespace parent]::disableVirtualTerminal {{channels {input output}}} { - set ins [list in input stdin] - set outs [list out output stdout stderr] - set known [concat $ins $outs both] - set directions [list] - foreach v $channels { - if {$v in $ins} { - lappend directions input - } elseif {$v in $outs} { - lappend directions output - } elseif {$v eq "both"} { - lappend directions input output - } - if {$v ni $known} { - error "disableVirtualTerminal expected channel values to be one of '$known'. (all values mapped to input and/or output)" - } - } - set channels $directions ;#don't worry about dups. - if {"both" in $channels} { - lappend channels input output - } - set result [dict create] - if {"output" in $channels} { - #as above - configuring stdout does stderr too - set h_out [twapi::get_console_handle stdout] - set oldmode [twapi::GetConsoleMode $h_out] - set newmode [expr {$oldmode & ~4}] - twapi::SetConsoleMode $h_out $newmode - dict set result output [list from $oldmode to $newmode] - } - if {"input" in $channels} { - set h_in [twapi::get_console_handle stdin] - set oldmode_in [twapi::GetConsoleMode $h_in] - set newmode_in [expr {$oldmode_in & ~0x200}] - twapi::SetConsoleMode $h_in $newmode_in - dict set result input [list from $oldmode_in to $newmode_in] - } - - #return [list stdout [list from $oldmode_out to $newmode_out] stdin [list from $oldmode_in to $newmode_in]] - return $result - } - - proc [namespace parent]::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 {} { - 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]] - } - } else { - - 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 [namespace parent]::enableVirtualTerminal {{channels {input output}}} { - } - proc [namespace parent]::disableVirtualTerminal {{channels {input output}}} { - } - proc [namespace parent]::enableProcessedInput {args} { - - } - proc [namespace parent]::disableProcessedInput {args} { - - } - - } - - proc [namespace parent]::enableRaw {{channel stdin}} { - #variable is_raw - variable previous_stty_state_$channel - - 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] - - 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]] - } elseif {[set sttycmd [auto_execok stty]] ne ""} { - if {[set previous_stty_state_$channel] eq ""} { - set previous_stty_state_$channel [exec {*}$sttycmd -g <@$channel] - } - - exec {*}$sttycmd raw -echo <@$channel - tsv::set console is_raw 1 - #review - inconsistent return dict - return [dict create stdin [list from [set previous_stty_state_$channel] to "" note "fixme - to state not shown"]] - } else { - error "punk::console::enableRaw Unable to use twapi or stty to set raw mode - aborting" - } - } - - #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 - 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] - 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? - - set sttycmd [auto_execok stty] - if {[set previous_stty_state_$channel] ne ""} { - exec {*}$sttycmd [set previous_stty_state_$channel] - set previous_stty_state_$channel "" - return restored - } - exec {*}$sttycmd -raw echo <@$channel - tsv::set console is_raw 0 - #do we really want to exec stty yet again to show final 'to' state? - #probably not. We should work out how to read the stty result flags and set a result.. or just limit from,to to showing echo and lineedit states. - return [list stdin [list from "[set previous_stty_state_$channel]" to "" note "fixme - to state not shown"]] - } else { - error "punk::console::disableRaw Unable to use twapi or stty to unset raw mode - aborting" - } - } - - } lappend PUNKARGS [list { @@ -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 diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/libunknown-0.1.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/libunknown-0.1.tm index 3b5d35b0..f9dfaf56 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/libunknown-0.1.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/libunknown-0.1.tm @@ -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 diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/repl-0.1.2.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/repl-0.1.2.tm index 9d199997..11cd9706 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/repl-0.1.2.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/repl-0.1.2.tm @@ -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" } } diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/make.tcl b/src/project_layouts/custom/_project/punk.project-0.1/src/make.tcl index 1736d3d9..c1d3f906 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/make.tcl +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/make.tcl @@ -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 diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/args-0.2.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/args-0.2.tm index a6224c0d..7b6ee228 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/args-0.2.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/args-0.2.tm @@ -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]" diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/args/tclcore-0.1.0.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/args/tclcore-0.1.0.tm index d016c70a..6a4cc626 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/args/tclcore-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/args/tclcore-0.1.0.tm @@ -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\ diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/console-0.1.1.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/console-0.1.1.tm index ea8d3f77..4d4518d3 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/console-0.1.1.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/console-0.1.1.tm @@ -129,57 +129,362 @@ namespace eval punk::console { #e.g external utils system API's. namespace export * } - + 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}]}] + + if {$has_twapi} { + #this is really enableAnsi *processing* + 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 + if {[catch {twapi::get_console_handle stdout} h_out]} { + puts stderr "enableAnsi failed: twapi cannot get console handle for stdout" + return + } - 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 + 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? + + twapi::SetConsoleMode $h_out $newmode_out + + #what does window_input have to do with it?? + #input handle modes + #ENABLE_PROCESSED_INPUT 0x0001 ;#set to zero will allow ctrl-c to be reported as keyboard input rather than as a signal + #ENABLE_LINE_INPUT 0x0002 + #ENABLE_ECHO_INPUT 0x0004 + #ENABLE_WINDOW_INPUT 0x0008 (default off when a terminal created) + #ENABLE_MOUSE_INPUT 0x0010 + #ENABLE_INSERT_MODE 0X0020 + #ENABLE_QUICK_EDIT_MODE 0x0040 + #ENABLE_VIRTUAL_TERMINAL_INPUT 0x0200 (default off when a terminal created) (512) + set h_in [twapi::get_console_handle stdin] + set oldmode_in [twapi::GetConsoleMode $h_in] + set newmode_in [expr {$oldmode_in | 8}] + #set newmode_in [expr {$oldmode_in | 0x208}] + + twapi::SetConsoleMode $h_in $newmode_in + + return [list stdout [list from $oldmode_out to $newmode_out] stdin [list from $oldmode_in to $newmode_in]] + } + proc disableAnsi {} { + set h_out [twapi::get_console_handle stdout] + set oldmode_out [twapi::GetConsoleMode $h_out] + set newmode_out [expr {$oldmode_out & ~4}] + twapi::SetConsoleMode $h_out $newmode_out + + #??? review + set h_in [twapi::get_console_handle stdin] + set oldmode_in [twapi::GetConsoleMode $h_in] + set newmode_in [expr {$oldmode_in & ~8}] + twapi::SetConsoleMode $h_in $newmode_in + + + return [list stdout [list from $oldmode_out to $newmode_out] stdin [list from $oldmode_in to $newmode_in]] + } + proc enableVirtualTerminal {{channels {input output}}} { + set ins [list in input stdin] + set outs [list out output stdout stderr] + set known [concat $ins $outs both] + set directions [list] + foreach v $channels { + if {$v in $ins} { + lappend directions input + } elseif {$v in $outs} { + lappend directions output + } elseif {$v eq "both"} { + lappend directions input output + } + if {$v ni $known} { + error "enableVirtualTerminal expected channel values to be one of '$known'. (all values mapped to input and/or output)" + } + } + set channels $directions ;#don't worry about dups. + if {"both" in $channels} { + lappend channels input output + } + set result [dict create] + if {"output" in $channels} { + #note setting stdout makes stderr have the same settings - ie there is really only one output to configure + set h_out [twapi::get_console_handle stdout] + set oldmode [twapi::GetConsoleMode $h_out] + set newmode [expr {$oldmode | 4}] + twapi::SetConsoleMode $h_out $newmode + dict set result output [list from $oldmode to $newmode] + } + + if {"input" in $channels} { + set h_in [twapi::get_console_handle stdin] + set oldmode_in [twapi::GetConsoleMode $h_in] + set newmode_in [expr {$oldmode_in | 0x200}] + twapi::SetConsoleMode $h_in $newmode_in + dict set result input [list from $oldmode_in to $newmode_in] + } + + return $result + } + + proc disableVirtualTerminal {{channels {input output}}} { + set ins [list in input stdin] + set outs [list out output stdout stderr] + set known [concat $ins $outs both] + set directions [list] + foreach v $channels { + if {$v in $ins} { + lappend directions input + } elseif {$v in $outs} { + lappend directions output + } elseif {$v eq "both"} { + lappend directions input output + } + if {$v ni $known} { + error "disableVirtualTerminal expected channel values to be one of '$known'. (all values mapped to input and/or output)" + } + } + set channels $directions ;#don't worry about dups. + if {"both" in $channels} { + lappend channels input output + } + set result [dict create] + if {"output" in $channels} { + #as above - configuring stdout does stderr too + set h_out [twapi::get_console_handle stdout] + set oldmode [twapi::GetConsoleMode $h_out] + set newmode [expr {$oldmode & ~4}] + twapi::SetConsoleMode $h_out $newmode + dict set result output [list from $oldmode to $newmode] + } + if {"input" in $channels} { + set h_in [twapi::get_console_handle stdin] + set oldmode_in [twapi::GetConsoleMode $h_in] + set newmode_in [expr {$oldmode_in & ~0x200}] + twapi::SetConsoleMode $h_in $newmode_in + dict set result input [list from $oldmode_in to $newmode_in] + } + + #return [list stdout [list from $oldmode_out to $newmode_out] stdin [list from $oldmode_in to $newmode_in]] + return $result + } + 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 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]] + } + + #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 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 { - #error vs noop? - puts stderr "Unable to set implementation for %f% - check twapi?" + 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 ;# ??? + } + 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]] } - }] + } + + } 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 "" $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 + } + } + + } + + + #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 {[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 + 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] + } + + exec {*}$sttycmd raw -echo <@$channel + tsv::set console is_raw 1 + #review - inconsistent return dict + return [dict create stdin [list from [set previous_stty_state_$channel] to "" note "fixme - to state not shown"]] + } else { + error "punk::console::enableRaw Unable to use twapi or stty to set raw mode - aborting" + } + } + + + proc disableRaw {{channel stdin}} { + 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 { + #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] + set previous_stty_state_$channel "" + return restored + } + exec {*}$sttycmd -raw echo <@$channel + tsv::set console is_raw 0 + #do we really want to exec stty yet again to show final 'to' state? + #probably not. We should work out how to read the stty result flags and set a result.. or just limit from,to to showing echo and lineedit states. + return [list stdin [list from "[set previous_stty_state_$channel]" to "" note "fixme - to state not shown"]] + } else { + 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? } @@ -190,6 +495,13 @@ namespace eval punk::console { #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}} { @@ -221,12 +533,6 @@ namespace eval punk::console { 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? @@ -257,7 +563,6 @@ namespace eval punk::console { #puts -nonewline stdout \x1b\[?25l ;#hide cursor puts -nonewline stdout \x1b\[?1003h\n enable_bracketed_paste - } #todo stop_application_mode {} {} @@ -313,266 +618,10 @@ namespace eval punk::console { } } 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.. - - #this is really enableAnsi *processing* - proc [namespace parent]::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] - 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? - - twapi::SetConsoleMode $h_out $newmode_out - - #what does window_input have to do with it?? - #input handle modes - #ENABLE_PROCESSED_INPUT 0x0001 ;#set to zero will allow ctrl-c to be reported as keyboard input rather than as a signal - #ENABLE_LINE_INPUT 0x0002 - #ENABLE_ECHO_INPUT 0x0004 - #ENABLE_WINDOW_INPUT 0x0008 (default off when a terminal created) - #ENABLE_MOUSE_INPUT 0x0010 - #ENABLE_INSERT_MODE 0X0020 - #ENABLE_QUICK_EDIT_MODE 0x0040 - #ENABLE_VIRTUAL_TERMINAL_INPUT 0x0200 (default off when a terminal created) (512) - set h_in [twapi::get_console_handle stdin] - set oldmode_in [twapi::GetConsoleMode $h_in] - set newmode_in [expr {$oldmode_in | 8}] - #set newmode_in [expr {$oldmode_in | 0x208}] - - twapi::SetConsoleMode $h_in $newmode_in - - return [list stdout [list from $oldmode_out to $newmode_out] stdin [list from $oldmode_in to $newmode_in]] - } - proc [namespace parent]::disableAnsi {} { - set h_out [twapi::get_console_handle stdout] - set oldmode_out [twapi::GetConsoleMode $h_out] - set newmode_out [expr {$oldmode_out & ~4}] - twapi::SetConsoleMode $h_out $newmode_out - #??? review - set h_in [twapi::get_console_handle stdin] - set oldmode_in [twapi::GetConsoleMode $h_in] - set newmode_in [expr {$oldmode_in & ~8}] - twapi::SetConsoleMode $h_in $newmode_in - - - 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}}} { - set ins [list in input stdin] - set outs [list out output stdout stderr] - set known [concat $ins $outs both] - set directions [list] - foreach v $channels { - if {$v in $ins} { - lappend directions input - } elseif {$v in $outs} { - lappend directions output - } elseif {$v eq "both"} { - lappend directions input output - } - if {$v ni $known} { - error "enableVirtualTerminal expected channel values to be one of '$known'. (all values mapped to input and/or output)" - } - } - set channels $directions ;#don't worry about dups. - if {"both" in $channels} { - lappend channels input output - } - set result [dict create] - if {"output" in $channels} { - #note setting stdout makes stderr have the same settings - ie there is really only one output to configure - set h_out [twapi::get_console_handle stdout] - set oldmode [twapi::GetConsoleMode $h_out] - set newmode [expr {$oldmode | 4}] - twapi::SetConsoleMode $h_out $newmode - dict set result output [list from $oldmode to $newmode] - } - - if {"input" in $channels} { - set h_in [twapi::get_console_handle stdin] - set oldmode_in [twapi::GetConsoleMode $h_in] - set newmode_in [expr {$oldmode_in | 0x200}] - twapi::SetConsoleMode $h_in $newmode_in - dict set result input [list from $oldmode_in to $newmode_in] - } - - return $result - } - proc [namespace parent]::disableVirtualTerminal {{channels {input output}}} { - set ins [list in input stdin] - set outs [list out output stdout stderr] - set known [concat $ins $outs both] - set directions [list] - foreach v $channels { - if {$v in $ins} { - lappend directions input - } elseif {$v in $outs} { - lappend directions output - } elseif {$v eq "both"} { - lappend directions input output - } - if {$v ni $known} { - error "disableVirtualTerminal expected channel values to be one of '$known'. (all values mapped to input and/or output)" - } - } - set channels $directions ;#don't worry about dups. - if {"both" in $channels} { - lappend channels input output - } - set result [dict create] - if {"output" in $channels} { - #as above - configuring stdout does stderr too - set h_out [twapi::get_console_handle stdout] - set oldmode [twapi::GetConsoleMode $h_out] - set newmode [expr {$oldmode & ~4}] - twapi::SetConsoleMode $h_out $newmode - dict set result output [list from $oldmode to $newmode] - } - if {"input" in $channels} { - set h_in [twapi::get_console_handle stdin] - set oldmode_in [twapi::GetConsoleMode $h_in] - set newmode_in [expr {$oldmode_in & ~0x200}] - twapi::SetConsoleMode $h_in $newmode_in - dict set result input [list from $oldmode_in to $newmode_in] - } - - #return [list stdout [list from $oldmode_out to $newmode_out] stdin [list from $oldmode_in to $newmode_in]] - return $result - } - - proc [namespace parent]::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 {} { - 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]] - } - } else { - - 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 [namespace parent]::enableVirtualTerminal {{channels {input output}}} { - } - proc [namespace parent]::disableVirtualTerminal {{channels {input output}}} { - } - proc [namespace parent]::enableProcessedInput {args} { - - } - proc [namespace parent]::disableProcessedInput {args} { - - } - - } - - proc [namespace parent]::enableRaw {{channel stdin}} { - #variable is_raw - variable previous_stty_state_$channel - - 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] - - 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]] - } elseif {[set sttycmd [auto_execok stty]] ne ""} { - if {[set previous_stty_state_$channel] eq ""} { - set previous_stty_state_$channel [exec {*}$sttycmd -g <@$channel] - } - - exec {*}$sttycmd raw -echo <@$channel - tsv::set console is_raw 1 - #review - inconsistent return dict - return [dict create stdin [list from [set previous_stty_state_$channel] to "" note "fixme - to state not shown"]] - } else { - error "punk::console::enableRaw Unable to use twapi or stty to set raw mode - aborting" - } - } - - #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 - 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] - 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? - - set sttycmd [auto_execok stty] - if {[set previous_stty_state_$channel] ne ""} { - exec {*}$sttycmd [set previous_stty_state_$channel] - set previous_stty_state_$channel "" - return restored - } - exec {*}$sttycmd -raw echo <@$channel - tsv::set console is_raw 0 - #do we really want to exec stty yet again to show final 'to' state? - #probably not. We should work out how to read the stty result flags and set a result.. or just limit from,to to showing echo and lineedit states. - return [list stdin [list from "[set previous_stty_state_$channel]" to "" note "fixme - to state not shown"]] - } else { - error "punk::console::disableRaw Unable to use twapi or stty to unset raw mode - aborting" - } - } - - } lappend PUNKARGS [list { @@ -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 diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/libunknown-0.1.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/libunknown-0.1.tm index 3b5d35b0..f9dfaf56 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/libunknown-0.1.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/libunknown-0.1.tm @@ -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 diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/repl-0.1.2.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/repl-0.1.2.tm index 9d199997..11cd9706 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/repl-0.1.2.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/repl-0.1.2.tm @@ -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" } } diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/make.tcl b/src/project_layouts/custom/_project/punk.shell-0.1/src/make.tcl index 1736d3d9..c1d3f906 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/make.tcl +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/make.tcl @@ -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 diff --git a/src/runtime/mapvfs.config b/src/runtime/mapvfs.config index 0a6c55d1..1545b1b3 100644 --- a/src/runtime/mapvfs.config +++ b/src/runtime/mapvfs.config @@ -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} diff --git a/src/scriptapps/bin/readme.txt b/src/scriptapps/bin/readme.txt new file mode 100644 index 00000000..f8c0d3ab --- /dev/null +++ b/src/scriptapps/bin/readme.txt @@ -0,0 +1 @@ +scriptapps targeting the project's bin directory go here. \ No newline at end of file diff --git a/src/scriptapps/example_out.bat b/src/scriptapps/example_out.bat deleted file mode 100644 index c45adc6c..00000000 --- a/src/scriptapps/example_out.bat +++ /dev/null @@ -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 -outputfolder -@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 -: -@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_____________" -: -@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). -: -@SET "asadmin=0" -: -@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 -@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" -# -- --- --- --- --- --- --- --- --- --- --- --- - - -# -# - -# -# - - -# -# - - -# -- --- --- --- --- --- --- --- --- --- --- --- -# -- 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" - -# -echo "output from example.sh wrapped in polyglot script" -# - -# -- --- --- --- --- --- --- --- -# -#-- 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 -# -# -- --- --- --- --- --- --- --- - -# -# - - -#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"; -} - -# -# - - - -# -- --- --- --- --- --- --- --- -# -$exit_code=system("tclsh", $scriptname, @ARGV); -#print "perl reporting tcl exitcode: $exit_code"; -# -# -- --- --- --- --- --- --- --- - -# -# - - -# -- --- --- --- --- --- --- --- --- --- --- --- --- ---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 -# -- --- --- --- - -# -# - - -# -- --- --- --- --- --- --- --- -# -tclsh $scriptname $args -#"powershell reporting exitcode: {0}" -f $LASTEXITCODE | write-host -# -# -- --- --- --- --- --- --- --- - - -# -# - -# -- --- --- --- --- --- --- --- --- --- --- --- --- ---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 -# - -# -# -- unreachable by tcl directly if ctrl-z character is in the 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) -#> - - diff --git a/src/scriptapps/example_wrap.toml b/src/scriptapps/example_wrap.toml index 5476485e..313beda3 100644 --- a/src/scriptapps/example_wrap.toml +++ b/src/scriptapps/example_wrap.toml @@ -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"