diff --git a/.fossil-settings/ignore-glob b/.fossil-settings/ignore-glob index 9fa82c6c..2c3ee2d2 100644 --- a/.fossil-settings/ignore-glob +++ b/.fossil-settings/ignore-glob @@ -26,8 +26,9 @@ doc test* #Built tclkits (if any) -punk*.exe -tcl*.exe +#punk*.exe +#tcl*.exe +*.exe #miscellaneous editor files etc *.swp diff --git a/.gitignore b/.gitignore index 1c3be549..bb48c0c9 100644 --- a/.gitignore +++ b/.gitignore @@ -1,5 +1,7 @@ -/bin/ +#/bin/ +/bin/* +!/bin/*.cmd /lib/ #The directories for compiled/built Tcl modules and libraries /modules/ @@ -12,6 +14,7 @@ #Temporary files e.g from tests /tmp/ +**/_old.* /logs/ **/_aside/ scratch* @@ -38,8 +41,9 @@ scratch* !/src/runtime/mapvfs.config #Built tclkits (if any) -punk*.exe -tcl*.exe +#punk*.exe +#tcl*.exe +*.exe #ignore fossil database files (but keep .fossil-settings and .fossil-custom in repository even if fossil not being used at your site) _FOSSIL_ diff --git a/bin/getzig.cmd b/bin/getzig.cmd index 74d36ed1..1108691d 100644 --- a/bin/getzig.cmd +++ b/bin/getzig.cmd @@ -1,4 +1,4 @@ -: "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^ +: "punk MULTISHELL - shebangless polyglot for Tcl Perl sh bash cmd pwsh powershell" + "[rename set S;proc Hide shell_not_supported {proc $shell_not_supported 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 + \ @@ -16,6 +16,70 @@ set -- "$@" "a=[Hide <#;Hide set;S 1 list]"; set -- : "$@";$1 = @' @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 ------------------------------------------------------------------------------------------------------------------------------- +@rem return from endlocal macro - courtesy of jeb +@rem This allows return of values containing special characters from subroutines +@rem https://stackoverflow.com/questions/3262287/make-an-environment-variable-survive-endlocal/8257951#8257951 +@rem ------------------------------------------------------------------------------------------------------------------------------- +@setlocal DisableDelayedExpansion +@echo off +%= 2 blank lines after next are required =% +set LF=^ + + +set ^"\n=^^^%LF%%LF%^%LF%%LF%^^" +%= I use EDE for EnableDelayeExpansion and DDE for DisableDelayedExpansion =% +set ^"endlocal=for %%# in (1 2) do if %%#==2 (%\n% + setlocal EnableDelayedExpansion%\n% + %= Take all variable names into the varName array =%%\n% + set varName_count=0%\n% + for %%C in (!args!) do set "varName[!varName_count!]=%%~C" ^& set /a varName_count+=1%\n% + %= Build one variable with a list of set statements for each variable delimited by newlines =%%\n% + %= The lists looks like --> set result1=myContent\n"set result1=myContent1"\nset result2=content2\nset result2=content2\n =%%\n% + %= Each result exists two times, the first for the case returning to DDE, the second for EDE =%%\n% + %= The correct line will be detected by the (missing) enclosing quotes =%%\n% + set "retContent=1!LF!"%\n% + for /L %%n in (0 1 !varName_count!) do (%\n% + for /F "delims=" %%C in ("!varName[%%n]!") DO (%\n% + set "content=!%%C!"%\n% + set "retContent=!retContent!"set !varName[%%n]!=!content!"!LF!"%\n% + if defined content (%\n% + %= This complex block is only for replacing '!' with '^!' =%%\n% + %= First replacing '"'->'""q' '^'->'^^' =%%\n% + set ^"content_EDE=!content:"=""q!"%\n% + set "content_EDE=!content_EDE:^=^^!"%\n% + %= Now it's poosible to use CALL SET and replace '!'->'""e!' =%%\n% + call set "content_EDE=%%content_EDE:^!=""e^!%%"%\n% + %= Now it's possible to replace '""e' to '^', this is effectivly '!' -> '^!' =%%\n% + set "content_EDE=!content_EDE:""e=^!"%\n% + %= Now restore the quotes =%%\n% + set ^"content_EDE=!content_EDE:""q="!"%\n% + ) ELSE set "content_EDE="%\n% + set "retContent=!retContent!set "!varName[%%n]!=!content_EDE!"!LF!"%\n% + )%\n% + )%\n% + %= Now return all variables from retContent over the barrier =%%\n% + for /F "delims=" %%V in ("!retContent!") DO (%\n% + %= Only the first line can contain a single 1 =%%\n% + if "%%V"=="1" (%\n% + %= We need to call endlocal twice, as there is one more setlocal in the macro itself =%%\n% + endlocal%\n% + endlocal%\n% + ) ELSE (%\n% + %= This is true in EDE =%%\n% + if "!"=="" (%\n% + if %%V==%%~V (%\n% + %%V !%\n% + )%\n% + ) ELSE IF not %%V==%%~V (%\n% + %%~V%\n% + )%\n% + )%\n% + )%\n% + ) else set args=" + +@rem ------------------------------------------------------------------------------------------------------------------------------- +@SETLOCAL EnableExtensions EnableDelayedExpansion @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 @@ -24,7 +88,6 @@ set -- "$@" "a=[Hide <#;Hide set;S 1 list]"; set -- : "$@";$1 = @' @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 @@ -32,7 +95,7 @@ set -- "$@" "a=[Hide <#;Hide set;S 1 list]"; set -- : "$@";$1 = @' @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___________]=pwsh____________________________________________________________" +@SET "nextshellpath[win32___________]=pwsh -nop -nol -ExecutionPolicy bypass -c_______________________" @SET "nextshelltype[win32___________]=pwsh____________" @SET "nextshellpath[dragonflybsd____]=/usr/bin/env bash_______________________________________________" @SET "nextshelltype[dragonflybsd____]=bash____________" @@ -51,8 +114,6 @@ set -- "$@" "a=[Hide <#;Hide set;S 1 list]"; set -- : "$@";$1 = @' : <> @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 @@ -73,7 +134,7 @@ set -- "$@" "a=[Hide <#;Hide set;S 1 list]"; set -- : "$@";$1 = @' @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 -- deck scriptwrap.checkfile filepath @REM -- to check your templates or final wrapped scripts for byte boundary issues @REM -- It will report any labels that are on boundaries @REM -- This is why the nextshell value above is a 2 digit key instead of a string - so that editing the value doesn't change the byte offsets. @@ -83,12 +144,13 @@ set -- "$@" "a=[Hide <#;Hide set;S 1 list]"; set -- : "$@";$1 = @' @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 -- 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 "winpath=%~dp0" %= e.g c:\punkshell\bin\ %= @SET "fname=%~nx0" +@SET "scriptrootname=%~dp0%~n0" %= e.g c:\punkshell\bin\runtime (full path without extension) unavailable after shift, so store it =% @REM @ECHO fname %fname% @REM @ECHO winpath %winpath% @REM @ECHO commandlineascalled %0 @@ -123,17 +185,6 @@ set -- "$@" "a=[Hide <#;Hide set;S 1 list]"; set -- : "$@";$1 = @' @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 ) @@ -178,25 +229,101 @@ set -- "$@" "a=[Hide <#;Hide set;S 1 list]"; set -- : "$@";$1 = @' @IF "!selected_shelltype_trimmed!"=="none" ( SET selected_shelltype_trimmed=pwsh ) + + + + +@set argCount=30 +@rem This is the max number of args we are willing to handle. also bounded by approx 8k char limit of cmd.exe +@rem We do not loop over %* to count args as it is brittle for some inputs e.g will always skip cmd.exe separators e.g comma and semicolon +@rem Set argCount higher if desired, but there is a small amount of additional looping overhead. + +@set tmpfile_base=%TEMP%\punkbatch_params +@call :getUniqueFile %tmpfile_base% ".txt" paramfile +@echo %paramfile% + +%= NOTE when we loop like this using the percent-n args, we lose unquoted separators such as comma and semicolon %= +@rem https://stackoverflow.com/questions/26551/how-can-i-pass-arguments-to-a-batch-file/5493124#5493124 +@rem outer loop required to redirect all rem lines at once to file +@for %%x in (1) do @( + @for /L %%f in (1,1,%argCount%) do @( + @set "argnum=%%~nf" + @set "a1=%%1" + @rem @set "argname=%%!argnum!" + @rem @echo argname: !argname! + @call :rem_output !argnum! !a1! + @shift + ) +) > %paramfile% +@echo off + +@set "newcommandline= " + +@(set target=cmd_pwsh) +@if "%target%"=="cmd_pwsh" ( + @for /F "delims=" %%L in (%paramfile%) do @( + SETLOCAL DisableDelayedExpansion + set "param=%%L" + @REM @echo ######### %%L + @rem call :buildcmdline newcommandline param "{" "}" + @rem call :buildcmdline newcommandline param ' ' %= cmd.exe /c powershell ... -c %= + call :buildcmdline newcommandline param %= cmd.exe /c powershell ... -f %= + @rem @echo . + ) +) ELSE ( + @for /F "delims=" %%L in (%paramfile%) do @( + SETLOCAL DisableDelayedExpansion + set "param=%%L" + call :buildcmdline newcommandline param + ) +) +@REM padding +SETLOCAL EnableDelayedExpansion + +@echo off +@IF EXIST %paramfile% ( + @DEL /F /Q %paramfile% +) +@IF EXIST %paramfile% ( + echo failed to delete %paramfile% + cat %paramfile% +) + + + +@REM @SET "squoted_args=" +@REM @for %%a in (%*) do @( +@REM set "v=%%a" +@REM set "v=!v:'=''!" +@REM SET "squoted_args=!squoted_args!'!v!' " +@REM ) +@REM @SET "squoted_args=%squoted_args:~0,-1%" +@REM @ECHO %squoted_args% + + @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 + REM when run without cmd.exe - pwsh will receive the semicolon (for cmd.exe unquoted semicolon and comma are separators that aren't seen in positional arguments) 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% + @rem pwsh -nop -nol -c set-executionpolicy -Scope Process Unrestricted; "%scriptrootname%.ps1" %arglist% + @rem pwsh -nop -nol -c set-executionpolicy -Scope Process Unrestricted + cmd /c pwsh -nop -nol -ExecutionPolicy bypass -f "%scriptrootname%.ps1" !newcommandline! 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% + @rem powershell -nop -nol -ExecutionPolicy Bypass -c "%scriptrootname%.ps1" %arglist% + cmd /c powershell -nop -nol -ExecutionPolicy Bypass -f "%scriptrootname%.ps1" !newcommandline! SET task_exitcode=!errorlevel! ) ) ELSE ( IF "!selected_shelltype_trimmed!"=="powershell" ( - powershell -nop -nol -ExecutionPolicy Bypass -c "%~dp0%~n0.ps1" %arglist% + @rem powershell -nop -nol -ExecutionPolicy Bypass -c "%scriptrootname%.ps1" %arglist% + cmd /c powershell -nop -nol -ExecutionPolicy Bypass -f "%scriptrootname%.ps1" !newcommandline! SET task_exitcode=!errorlevel! ) ELSE ( IF "!selected_shelltype_trimmed!"=="wslbash" ( @@ -211,7 +338,7 @@ set -- "$@" "a=[Hide <#;Hide set;S 1 list]"; set -- : "$@";$1 = @' 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; + %selected_shellpath_trimmed% "%winpath%%fname%" %arglist% & SET task_exitcode=!errorlevel! & Call; ) ELSE ( ECHO %fname% has invalid nextshelltype value %selected_shelltype% valid options are %validshelltypes% SET task_exitcode=66 @@ -222,9 +349,145 @@ set -- "$@" "a=[Hide <#;Hide set;S 1 list]"; set -- : "$@";$1 = @' ) ) @REM batch file library functions -@REM boundary padding + @GOTO :endlib +@REM padding +@REM padding +@REM padding + +%= ---------------------------------------------------------------------- =% +@rem courtesy of dbenham +:: Example usage +@rem call :getUniqueFile "d:\test\myFile" ".txt" myFile +@rem echo myFile="%myFile%" + +:getUniqueFile baseName extension rtnVar +setlocal +:getUniqueFileLoop +for /f "skip=1" %%A in ('wmic os get localDateTime') do for %%B in (%%A) do set "rtn=%~1_%%B%~2" +if exist "%rtn%" ( + goto :getUniqueFileLoop +) else ( + 2>nul >nul (9>"%rtn%" timeout /nobreak 1) || goto :getUniqueFileLoop +) +endlocal & set "%~3=%rtn%" +exit /b +%= ---------------------------------------------------------------------- =% + +@REM padding +:buildcmdline cmdlinevar paramvar wrapA wrapB + %= quoting for cmd.exe /c pwsh -nop !args! =% + @SETLOCAL EnableDelayedExpansion + + @REM @echo ===================== + set "pval=!%~2:*#=!" + set "pval=!pval:~0,-2!" + @REM set "pval=!pval:~0,-1!" + set "wrapa=%~3" + set "wrapb=%~4" + + @call :strlen pval slen + @rem @echo strlen: !slen! + if "!slen!"=="0" ( + goto :eof + ) + @set /A n = !slen! - 1 + @(set str=) + @set "dq="" + @set "bang=^!" + @(set carat=^^) + @for /l %%i in (0,1,!n!) do @( + (set c=!pval:~%%i,1!) + if "!c!"=="|" ( + set "ch=^^!pval:~%%i,1!" + ) ELSE IF "!c!"=="(" ( + set "ch=^(" + ) ELSE if "!c!"==")" ( + set "ch=^)" + ) ELSE if "!c!"=="&" ( + set "ch=^^&" + ) ELSE if "!c!"=="!dq!" ( + set "ch=^"" + ) ELSE if "!c!"=="!bang!" ( + @rem - double caret - first for initial parsing, second to ensure remains escaped during delayed expansion phase + @rem - REVIEW + set "ch=^^!bang!" + ) ELSE if "!c!"=="^carat" ( + set "ch=^^^^" + ) ELSE if "!c!"=="'" ( + set "ch=''" + ) ELSE ( + set "ch=!c!" + ) + @rem @echo - !ch! + set "str=!str!!ch!" + ) + echo +++++ %~1 = !%1! !str! + + set "%~1=!%1! !wrapa!!str!!wrapb!" + + @rem old method of return - failes to preserve exclamation marks + @rem for /f "delims=" %%A in (""!str!"") do endlocal & set "%~1=!%1! '%%~A'" + @rem macro method of endlocal return - preserving !val! + @echo off + %endlocal% %~1 + + @exit /b + +:rem_output + @rem --------------------------------------------- + @rem rem_output is called for each n in the number of args we process - as we don't have a non-destructive way to count args whilst accepting special chars + @rem we therefore need a way to stop processing on the last received arg so we don't write argCount entries to param.txt if less are received + @rem see 'disappearing quotes' technique + @rem https://stackoverflow.com/questions/4643376/how-to-split-double-quoted-line-into-multiple-lines-in-windows-batch-file/4645113#4645113 + @rem and + @rem https://groups.google.com/g/alt.msdos.batch.nt/c/J71F17Bve9Y (sponge belly) + @echo off + setlocal enableextensions disabledelayedexpansion + set "param1=%~2" + rem do must not be indented + for %%^" in ("") ^ +do if not defined param1 set %%~"param1=%2%%~" + if not defined param1 goto :eof + endlocal + @rem --------------------------------------------- + + @PROMPT @ + @echo on + rem %1 #%2# +@exit /b + +@REM courtesy of: https://stackoverflow.com/users/463115/jeb +:strlen stringVar returnVar +@( + setlocal EnableDelayedExpansion + @SET "rtrn=%~2" + (set^ tmp=!%~1!) + @rem @echo jjjjj !tmp! + @if defined tmp ( + set "len=1" + @for %%P in (4096 2048 1024 512 256 128 64 32 16 8 4 2 1) do @( + @if "!tmp:~%%P,1!" NEQ "" ( + set /a "len+=%%P" + set "tmp=!tmp:~%%P!" + ) + ) + ) ELSE ( + set len=0 + ) +) +@( + endlocal + @IF "%~2" neq "" ( + @SET "%rtrn%=%len%" + ) ELSE ( + @ECHO :strlen result: %len% + ) + exit /b +) + + :getWslPath @SETLOCAL @SET "_path=%~p1" @@ -280,7 +543,7 @@ set -- "$@" "a=[Hide <#;Hide set;S 1 list]"; set -- : "$@";$1 = @' ) ) @EXIT /B -@REM boundary padding +@REM boundary padding @REM boundary padding :getNormalizedScriptTail @SETLOCAL @@ -295,13 +558,12 @@ set -- "$@" "a=[Hide <#;Hide set;S 1 list]"; set -- : "$@";$1 = @' ) @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 +: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' @SETLOCAL @CALL :stringContains %~1 "\" hasBackSlash @CALL :stringContains %~1 "/" hasForwardSlash @@ -327,6 +589,10 @@ set -- "$@" "a=[Hide <#;Hide set;S 1 list]"; set -- : "$@";$1 = @' ) @EXIT /B +@REM boundary padding +@REM boundary padding +@REM boundary padding + :stringContains @REM usage: @CALL:stringContains string needle returnvarname @SETLOCAL @@ -348,7 +614,7 @@ set -- "$@" "a=[Hide <#;Hide set;S 1 list]"; set -- : "$@";$1 = @' @EXIT /B @REM boundary padding @REM boundary padding -:stringToUpper +:stringToUpper strvar returnvar @SETLOCAL @SET "rtrn=%~2" @SET "string=%~1" @@ -384,6 +650,11 @@ set -- "$@" "a=[Hide <#;Hide set;S 1 list]"; set -- : "$@";$1 = @' @EXIT /B @REM boundary padding @REM boundary padding +@REM boundary padding +@REM boundary padding +@REM boundary padding +@REM boundary padding +@REM boundary padding :stringTrimTrailingUnderscores @SETLOCAL @SET "rtrn=%~2" @@ -442,12 +713,104 @@ set -- "$@" "a=[Hide <#;Hide set;S 1 list]"; set -- : "$@";$1 = @' # -- 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 +# -- e.g ./scriptname.cmd in sh or zsh or bash +# -- e.g tclsh scriptname.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 '@ +#--------------------------------------------------------------------- +#divert to configured nextshell +package require platform +set plat_full [platform::generic] +set plat [lindex [split $plat_full -] 0] +#may be old tcl - not assuming readFile available +set fd [open [info script] r] +set scriptdata [read $fd] +close $fd +set scriptdata [string map [list \r\n \n] $scriptdata] +set in_data 0 +set nextshellpath "" +set nextshelltype "" +puts stderr "PLAT: $plat" +foreach ln [split $scriptdata \n] { + if {[string trim $ln] eq ""} {continue} + if {!$in_data} { + if {[string match ": <>*" $ln]} { + set in_data 1 + } + } else { + if {[string match "*@SET*nextshellpath?${plat}_*" $ln]} { + set lineparts [split $ln =] + set tail [lindex $lineparts 1] + set nextshellpath [string trimright $tail {_"}] + if {$nextshellpath ne "" && $nextshelltype ne ""} { + break + } + } elseif {[string match "*@SET*nextshelltype?${plat}_*" $ln]} { + set lineparts [split $ln =] + set tail [lindex $lineparts 1] + set nextshelltype [string trimright $tail {_"}] + if {$nextshellpath ne "" && $nextshelltype ne ""} { + break + } + } elseif {[string match ": <>*" $ln]} { + break + } + } +} +if {$nextshelltype ne "tcl" && $nextshelltype ne "none"} { + if {$nextshelltype in "pwsh powershell"} { + set scrname [file rootname [info script]].ps1 + set arglist [list] + foreach a $::argv { + set a "'$a'" + lappend arglist $a + } + } else { + set scrname [info script] + set arglist $::argv + } + puts stdout "tclsh launching subshell of type: $nextshelltype shellpath: $nextshellpath on script $scrname with args: $arglist" + #todo - handle /usr/bin/env + #todo - exitcode + if {[llength $nextshellpath] == 1 && [string index $nextshellpath 0] eq {"} && [string index $nextshellpath end] eq {"}} { + set nextshell_words [list $nextshellpath] + } else { + set nextshell_words $nextshellpath + } + set ns_firstword [lindex $nextshellpath 0] + if {[string index $ns_firstword 0] eq {"} && [string index $ns_firstword end] eq {"}} { + set ns_firstword [string range $ns_firstword 1 end-1] + } + + if {[string match {/*/env} $ns_firstword] && $::tcl_platform(platform) ne "windows"} { + set exec_part $nextshellpath + } else { + set epath [auto_execok $ns_firstword] + if {$epath eq ""} { + error "unable to find executable path for first word '$ns_firstword' of nextshellpath '$nextshellpath'" + } else { + set exec_part [list {*}$epath {*}[lrange $nextshellpath 1 end]] + } + } + catch {exec {*}$exec_part $scrname {*}$arglist <@stdin >@stdout 2>@stderr} emsg eopts + + if {[dict exists $eopts -errorcode]} { + set ecode [dict get $eopts -errorcode] + if {[lindex $ecode 0] eq "CHILDSTATUS"} { + exit [lindex $ecode 2] + } else { + puts stderr "error calling next shell $nextshelltype :" + puts stderr $emsg + exit 1 + } + } else { + exit 0 + } +} +#--------------------------------------------------------------------- + namespace eval ::punk::multishell { set last_script_root [file dirname [file normalize ${::argv0}/__]] set last_script [file dirname [file normalize [info script]/__]] @@ -481,7 +844,7 @@ namespace eval ::punk::multishell { # -- --- --- --- --- --- --- --- --- --- --- --- # -puts stderr "No tcl code for this script. Try another program such as perl or bash" +puts stderr "No tcl code for this script. Try another program such as zsh or bash or perl" # # @@ -512,21 +875,26 @@ if {[::punk::multishell::is_main]} { # -- --- --- --- --- --- --- --- --- --- --- --- --- ---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}" - +# Be wary of any non-trivial sed/awk etc - can be brittle to maintain across linux,freebsd,macosx due to differing implementations \ +echo "var0: $0 @: $@" +# echo "script: `echo $0 | sed 's/^-//'`" +# use oldschool backticks and sed - lowest common denominator \ +# echo "shell: " `ps -p $$ | awk '$1 != "PID" {print $(NF)}' | tr -d '()' | sed -E 's/^.*\/|^-//'` +# zsh diversion \ +# if [[ "$argv[*]" != "[*]" ]]; then /usr/bin/env bash "$0" "${argv[@]:2:$((${#argv[@]}-2))}"; exit $?; fi +# \ +ps_shellname=`ps -p $$ | awk '$1 != "PID" {print $(NF)}' | tr -d '()' | sed -E 's/^.*\/|^-//'` +# \ +echo "shell from ps: $ps_shellname argc: ${#@} inner: ${@:2:$((${#@}-2))}" +# non-bash-like diversion \ +if [[ "$ps_shellname" != "bash" && "$ps_shellname" != "zsh" ]]; then /usr/bin/env bash "$0" "${@:2:$((${#@}-2))}"; exit $?; fi +# sh/bash (or zsh?) \ +shift && set -- "${@:1:$((${#@}-1))}" +# \ #echo "shell:" `ps -o args= $$ | sed -E 's/^.*\/|^-//' | awk '{print $1}'` -#------------------------------------------------------ +# \ +echo "args: $@" +# ------------------------------------------------------ # -- This if block only needed if Tcl didn't exit or return above. if false==false # else { then @@ -541,20 +909,30 @@ if false==false # else { # -- # ## ### ### ### ### ### ### ### ### ### ### ### ### ### -if [[ "$OSTYPE" == "linux"* ]]; then +plat=$(uname -s) #platform/system +if [[ "$plat" = "Linux"* ]]; then os="linux" -elif [[ "$OSTYPE" == "darwin"* ]]; then +elif [[ "$plat" == "Darwin"* ]]; then os="macosx" -elif [[ "$OSTYPE" == "freebsd"* ]]; then +elif [[ "$plat" == "FreeBSD"* ]]; then os="freebsd" -elif [[ "$OSTYPE" == "dragonflybsd"* ]]; then +elif [[ "$plat" == "DragonFly"* ]]; then os="dragonflybsd" -elif [[ "$OSTYPE" == "netbsd"* ]]; then +elif [[ "$plat" == "NetBSD"* ]]; then os="netbsd" -elif [[ "$OSTYPE" == "win32" ]]; then +elif [[ "$plat" == "OpenBSD"* ]]; then + os="openbsd" +elif [[ "$plat" = "MINGW32"* ]]; then + os="win32" +elif [[ "$plat" = "MINGW64"* ]]; then os="win32" -elif [[ "$OSTYPE" == "msys" ]]; then +elif [[ "$plat" = "CYGWIN_NT"* ]]; then + os="win32" +elif [[ "$plat" == "MSYS_NT"* ]]; then + #review.. echo MSYS + #win32 binaries - but e.g tclsh installed in msys reports ::tcl_platform(platform) as 'unix' + #bash reports $OSTYPE msys os="win32" #review - need ps/sed/awk to determine shell? interp = `ps -p $$ | awk '$1 != "PID" {print $(NF)}' | tr -d '()' | sed -E 's/^.*\/|^-//'` @@ -564,37 +942,50 @@ elif [[ "$OSTYPE" == "msys" ]]; then #"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}}" +elif [[ "$OSTYPE" == "win32" ]]; then + os="win32" 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" +## This is the sort of sed that will not work across implementations +## shellconfiglines=$( sed -n "/: <>/{:a;n;/: <>/q;p;ba}" "$0" | grep $os) +#awk tested on linux & freebsd +shellconfiglines=$( awk '/^:.*<>.*$/,/^:.*<>.*$/' "$0" | grep $os) +# echo $shellconfiglines; +# readarray requires bash 4.0 +if [[ "$ps_shellname" == "bash" ]]; then + readarray -t arr_oslines <<<"$shellconfiglines" +elif [[ "$ps_shellname" == "zsh" ]]; then + arr_oslines=("${(f)shellconfiglines}") else - echo "unable to find config for os $os" - echo "shellconfigline: $shellconfigline" - nextshellpath="" - nextshelltype="" + #fallback - doesn't seem to work in zsh - untested in early bash + IFS=$'\n' arr_oslines=($shellconfiglines) fi +nextshellpath="" +nextshelltype="" +for ln in "${arr_oslines[@]}"; do + # echo "---- $ln" + if [[ "$ln" == *"nextshellpath"* ]]; then + splitln="${ln#*=}" #remove everything through the first '=' + pathraw="${splitln%%\"*}" #take everything before the quote - use %% to get longest match + #remove trailing underscores (% means must match at end) + nextshellpath="${pathraw/%_*/}" + echo "nextshellpath: $nextshellpath" + elif [[ "$ln" == *"nextshelltype"* ]]; then + splitln="${ln#*=}" + typeraw="${splitln%%\"*}" + nextshelltype="${typeraw/%_*/}" + echo "nextshelltype: $nextshelltype" + fi +done + 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" "$@" + echo bash launching subshell of type: $nextshelltype shellpath: $nextshellpath on "$0" with args "$@" + #e.g /usr/bin/env tclsh "$0" "$@" ${nextshellpath} "$0" "$@" exitcode=$? @@ -767,12 +1158,14 @@ function GetDynamicParamDictionary { return $DynParamDictionary } } +# Example usage: # 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 +# [Parameter(Mandatory)][string] $myargument, +# [Parameter(ValueFromRemainingArguments)] $opts # ) #} #function psmain { @@ -783,10 +1176,15 @@ function GetDynamicParamDictionary { # #called once with $PSBoundParameters dictionary # #can be used to validate arguments, or set a simpler variable name for access # switch ($PSBoundParameters.keys) { -# 'myargumentname' { +# 'myargument' { # Set-Variable -Name $_ -Value $PSBoundParameters."$_" # } -# #... +# 'opts' { +# write-warning "Unused parameters: $($PSBoundParameters.$_)" +# } +# Default { +# write-warning "Unhandled parameter -> [$($_)]" +# } # } # foreach ($boundparam in $PSBoundParameters.GetEnumerator()) { # #... @@ -794,24 +1192,24 @@ function GetDynamicParamDictionary { # } # end { # #Main function logic -# Write-Host "myargumentname value is: $myargumentname" +# Write-Host "myargument value is: $myargument" # #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 +"Script Name : {0}" -f $scriptname | write-host +"Powershell Version: {0}" -f $PSVersionTable.PSVersion.Major | write-host +"powershell args : {0}" -f ($args -join ", ") | write-host # -- --- --- --- +$thisfileContent = Get-Content $scriptname -Raw $startTag = ": <>" $endTag = ": <>" -$fileContent = Get-Content $scriptname -Raw -$pattern = "(?s)$startTag(.*?)$endTag" -$matches = [regex]::Matches($fileContent,$pattern) -$admininfo = $matches[0].Groups[1].Value +$pattern = "(?s)`n$startTag[^`n]*`n(.*?)`n$endTag" +$match = [regex]::Match($thisfileContent,$pattern) $asadmin = 0 -if ($matches.count) { +if ($match.Success) { + $admininfo = $match.Groups[1].Value $asadmin = $admininfo.Contains("asadmin=1") if ($asadmin) { if (-not ([Security.Principal.WindowsPrincipal][Security.Principal.WindowsIdentity]::GetCurrent()).IsInRole([Security.Principal.WindowsBuiltInRole]::Administrator)) { @@ -829,6 +1227,67 @@ if ($matches.count) { } } } +# +$startTag = ": <>" +$endTag = ": <>" +$pattern = "(?s)`n$startTag[^`n]*`n(.*?)`n$endTag" +$match = [regex]::Match($thisfileContent,$pattern) +if ($match.Success) { + $plat = [System.Environment]::OSVersion.Platform + if ($plat -eq "Unix") { + $runtime_ident = [System.Runtime.InteropServices.RuntimeInformation]::RuntimeIdentifier + switch ($runtime_ident.split("-")[0]) { + "freebsd" { + # untested + $os = "freebsd" + } + "linux" { + $os = "linux" + } + "osx" { + # osx-x64 or osx-arm64 ? + $os = "macosx" + } + default { + #openbsd, netbsd ? + $os = "other" + } + } + } else { + $os = "win32" + } + + $matchedlines = $match.Groups[1].Value + $nextshell_type = "" + $nextshell_path = "" + ForEach ($line in $($matchedlines -split "\r?\n")) { + $m = [regex]::Match($line,".*nextshelltype\[${os}[_]+\]=([^_]*)[_]*") + if ($m.Success) { + $nextshell_type = $m.Groups[1].Value + } + $m = [regex]::Match($line,".*nextshellpath\[${os}[_]+\]=([^_]*)[_]*") + if ($m.Success) { + $nextshell_path = $m.Groups[1].Value + } + if ($nextshell_type -ne "" -and $nextshell_path -ne "") { + break + } + } + 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" + + # $arguments = @($($MyInvocation.MyCommand.Path)) + # $arguments += $args + # NOTE - this gives incorrect argument quoting e.g wrong number of arguments received by launched process for arguments: a "b c" + # $process = (Start-Process -FilePath $nextshell_path -ArgumentList $arguments -NoNewWindow -Wait) + # Exit $process.ExitCode + + & $nextshell_path $scriptname $args + exit $LASTEXITCODE + } +} + # -- --- --- --- --- --- --- --- --- --- --- --- --- ---begin powershell Payload # @@ -841,6 +1300,7 @@ if ($matches.count) { #$outbase = Join-Path -Path $PSScriptRoot -ChildPath "../.." $outbase = $PSScriptRoot $outbase = Resolve-Path -Path $outbase +Write-host "Base folder: $outbase" $toolsfolder = Join-Path -Path $outbase -ChildPath "tools" if (-not(Test-Path -Path $toolsfolder -PathType Container)) { #create folder - (can include missing intermediaries) diff --git a/bin/runtime.cmd b/bin/runtime.cmd index 3c226f7e..13874262 100644 --- a/bin/runtime.cmd +++ b/bin/runtime.cmd @@ -1,4 +1,4 @@ -: "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^ +: "punk MULTISHELL - shebangless polyglot for Tcl Perl sh bash cmd pwsh powershell" + "[rename set S;proc Hide shell_not_supported {proc $shell_not_supported 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 + \ @@ -16,6 +16,70 @@ set -- "$@" "a=[Hide <#;Hide set;S 1 list]"; set -- : "$@";$1 = @' @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 ------------------------------------------------------------------------------------------------------------------------------- +@rem return from endlocal macro - courtesy of jeb +@rem This allows return of values containing special characters from subroutines +@rem https://stackoverflow.com/questions/3262287/make-an-environment-variable-survive-endlocal/8257951#8257951 +@rem ------------------------------------------------------------------------------------------------------------------------------- +@setlocal DisableDelayedExpansion +@echo off +%= 2 blank lines after next are required =% +set LF=^ + + +set ^"\n=^^^%LF%%LF%^%LF%%LF%^^" +%= I use EDE for EnableDelayeExpansion and DDE for DisableDelayedExpansion =% +set ^"endlocal=for %%# in (1 2) do if %%#==2 (%\n% + setlocal EnableDelayedExpansion%\n% + %= Take all variable names into the varName array =%%\n% + set varName_count=0%\n% + for %%C in (!args!) do set "varName[!varName_count!]=%%~C" ^& set /a varName_count+=1%\n% + %= Build one variable with a list of set statements for each variable delimited by newlines =%%\n% + %= The lists looks like --> set result1=myContent\n"set result1=myContent1"\nset result2=content2\nset result2=content2\n =%%\n% + %= Each result exists two times, the first for the case returning to DDE, the second for EDE =%%\n% + %= The correct line will be detected by the (missing) enclosing quotes =%%\n% + set "retContent=1!LF!"%\n% + for /L %%n in (0 1 !varName_count!) do (%\n% + for /F "delims=" %%C in ("!varName[%%n]!") DO (%\n% + set "content=!%%C!"%\n% + set "retContent=!retContent!"set !varName[%%n]!=!content!"!LF!"%\n% + if defined content (%\n% + %= This complex block is only for replacing '!' with '^!' =%%\n% + %= First replacing '"'->'""q' '^'->'^^' =%%\n% + set ^"content_EDE=!content:"=""q!"%\n% + set "content_EDE=!content_EDE:^=^^!"%\n% + %= Now it's poosible to use CALL SET and replace '!'->'""e!' =%%\n% + call set "content_EDE=%%content_EDE:^!=""e^!%%"%\n% + %= Now it's possible to replace '""e' to '^', this is effectivly '!' -> '^!' =%%\n% + set "content_EDE=!content_EDE:""e=^!"%\n% + %= Now restore the quotes =%%\n% + set ^"content_EDE=!content_EDE:""q="!"%\n% + ) ELSE set "content_EDE="%\n% + set "retContent=!retContent!set "!varName[%%n]!=!content_EDE!"!LF!"%\n% + )%\n% + )%\n% + %= Now return all variables from retContent over the barrier =%%\n% + for /F "delims=" %%V in ("!retContent!") DO (%\n% + %= Only the first line can contain a single 1 =%%\n% + if "%%V"=="1" (%\n% + %= We need to call endlocal twice, as there is one more setlocal in the macro itself =%%\n% + endlocal%\n% + endlocal%\n% + ) ELSE (%\n% + %= This is true in EDE =%%\n% + if "!"=="" (%\n% + if %%V==%%~V (%\n% + %%V !%\n% + )%\n% + ) ELSE IF not %%V==%%~V (%\n% + %%~V%\n% + )%\n% + )%\n% + )%\n% + ) else set args=" + +@rem ------------------------------------------------------------------------------------------------------------------------------- +@SETLOCAL EnableExtensions EnableDelayedExpansion @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 @@ -24,7 +88,6 @@ set -- "$@" "a=[Hide <#;Hide set;S 1 list]"; set -- : "$@";$1 = @' @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 @@ -32,7 +95,7 @@ set -- "$@" "a=[Hide <#;Hide set;S 1 list]"; set -- : "$@";$1 = @' @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 "nextshellpath[win32___________]=powershell -nop -nol -ExecutionPolicy bypass -File______________" @SET "nextshelltype[win32___________]=powershell______" @SET "nextshellpath[dragonflybsd____]=/usr/bin/env bash_______________________________________________" @SET "nextshelltype[dragonflybsd____]=bash____________" @@ -51,8 +114,6 @@ set -- "$@" "a=[Hide <#;Hide set;S 1 list]"; set -- : "$@";$1 = @' : <> @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 @@ -73,7 +134,7 @@ set -- "$@" "a=[Hide <#;Hide set;S 1 list]"; set -- : "$@";$1 = @' @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 -- deck scriptwrap.checkfile filepath @REM -- to check your templates or final wrapped scripts for byte boundary issues @REM -- It will report any labels that are on boundaries @REM -- This is why the nextshell value above is a 2 digit key instead of a string - so that editing the value doesn't change the byte offsets. @@ -83,12 +144,13 @@ set -- "$@" "a=[Hide <#;Hide set;S 1 list]"; set -- : "$@";$1 = @' @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 -- 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 "winpath=%~dp0" %= e.g c:\punkshell\bin\ %= @SET "fname=%~nx0" +@SET "scriptrootname=%~dp0%~n0" %= e.g c:\punkshell\bin\runtime (full path without extension) unavailable after shift, so store it =% @REM @ECHO fname %fname% @REM @ECHO winpath %winpath% @REM @ECHO commandlineascalled %0 @@ -123,17 +185,6 @@ set -- "$@" "a=[Hide <#;Hide set;S 1 list]"; set -- : "$@";$1 = @' @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 ) @@ -178,25 +229,101 @@ set -- "$@" "a=[Hide <#;Hide set;S 1 list]"; set -- : "$@";$1 = @' @IF "!selected_shelltype_trimmed!"=="none" ( SET selected_shelltype_trimmed=pwsh ) + + + + +@set argCount=30 +@rem This is the max number of args we are willing to handle. also bounded by approx 8k char limit of cmd.exe +@rem We do not loop over %* to count args as it is brittle for some inputs e.g will always skip cmd.exe separators e.g comma and semicolon +@rem Set argCount higher if desired, but there is a small amount of additional looping overhead. + +@set tmpfile_base=%TEMP%\punkbatch_params +@call :getUniqueFile %tmpfile_base% ".txt" paramfile +@echo %paramfile% + +%= NOTE when we loop like this using the percent-n args, we lose unquoted separators such as comma and semicolon %= +@rem https://stackoverflow.com/questions/26551/how-can-i-pass-arguments-to-a-batch-file/5493124#5493124 +@rem outer loop required to redirect all rem lines at once to file +@for %%x in (1) do @( + @for /L %%f in (1,1,%argCount%) do @( + @set "argnum=%%~nf" + @set "a1=%%1" + @rem @set "argname=%%!argnum!" + @rem @echo argname: !argname! + @call :rem_output !argnum! !a1! + @shift + ) +) > %paramfile% +@echo off + +@set "newcommandline= " + +@(set target=cmd_pwsh) +@if "%target%"=="cmd_pwsh" ( + @for /F "delims=" %%L in (%paramfile%) do @( + SETLOCAL DisableDelayedExpansion + set "param=%%L" + @REM @echo ######### %%L + @rem call :buildcmdline newcommandline param "{" "}" + @rem call :buildcmdline newcommandline param ' ' %= cmd.exe /c powershell ... -c %= + call :buildcmdline newcommandline param %= cmd.exe /c powershell ... -f %= + @rem @echo . + ) +) ELSE ( + @for /F "delims=" %%L in (%paramfile%) do @( + SETLOCAL DisableDelayedExpansion + set "param=%%L" + call :buildcmdline newcommandline param + ) +) +@REM padding +SETLOCAL EnableDelayedExpansion + +@echo off +@IF EXIST %paramfile% ( + @DEL /F /Q %paramfile% +) +@IF EXIST %paramfile% ( + echo failed to delete %paramfile% + cat %paramfile% +) + + + +@REM @SET "squoted_args=" +@REM @for %%a in (%*) do @( +@REM set "v=%%a" +@REM set "v=!v:'=''!" +@REM SET "squoted_args=!squoted_args!'!v!' " +@REM ) +@REM @SET "squoted_args=%squoted_args:~0,-1%" +@REM @ECHO %squoted_args% + + @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 + REM when run without cmd.exe - pwsh will receive the semicolon (for cmd.exe unquoted semicolon and comma are separators that aren't seen in positional arguments) 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% + @rem pwsh -nop -nol -c set-executionpolicy -Scope Process Unrestricted; "%scriptrootname%.ps1" %arglist% + @rem pwsh -nop -nol -c set-executionpolicy -Scope Process Unrestricted + cmd /c pwsh -nop -nol -ExecutionPolicy bypass -f "%scriptrootname%.ps1" !newcommandline! 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% + @rem powershell -nop -nol -ExecutionPolicy Bypass -c "%scriptrootname%.ps1" %arglist% + cmd /c powershell -nop -nol -ExecutionPolicy Bypass -f "%scriptrootname%.ps1" !newcommandline! SET task_exitcode=!errorlevel! ) ) ELSE ( IF "!selected_shelltype_trimmed!"=="powershell" ( - powershell -nop -nol -ExecutionPolicy Bypass -c "%~dp0%~n0.ps1" %arglist% + @rem powershell -nop -nol -ExecutionPolicy Bypass -c "%scriptrootname%.ps1" %arglist% + cmd /c powershell -nop -nol -ExecutionPolicy Bypass -f "%scriptrootname%.ps1" !newcommandline! SET task_exitcode=!errorlevel! ) ELSE ( IF "!selected_shelltype_trimmed!"=="wslbash" ( @@ -211,7 +338,7 @@ set -- "$@" "a=[Hide <#;Hide set;S 1 list]"; set -- : "$@";$1 = @' 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; + %selected_shellpath_trimmed% "%winpath%%fname%" %arglist% & SET task_exitcode=!errorlevel! & Call; ) ELSE ( ECHO %fname% has invalid nextshelltype value %selected_shelltype% valid options are %validshelltypes% SET task_exitcode=66 @@ -222,9 +349,145 @@ set -- "$@" "a=[Hide <#;Hide set;S 1 list]"; set -- : "$@";$1 = @' ) ) @REM batch file library functions -@REM boundary padding + @GOTO :endlib +@REM padding +@REM padding +@REM padding + +%= ---------------------------------------------------------------------- =% +@rem courtesy of dbenham +:: Example usage +@rem call :getUniqueFile "d:\test\myFile" ".txt" myFile +@rem echo myFile="%myFile%" + +:getUniqueFile baseName extension rtnVar +setlocal +:getUniqueFileLoop +for /f "skip=1" %%A in ('wmic os get localDateTime') do for %%B in (%%A) do set "rtn=%~1_%%B%~2" +if exist "%rtn%" ( + goto :getUniqueFileLoop +) else ( + 2>nul >nul (9>"%rtn%" timeout /nobreak 1) || goto :getUniqueFileLoop +) +endlocal & set "%~3=%rtn%" +exit /b +%= ---------------------------------------------------------------------- =% + +@REM padding +:buildcmdline cmdlinevar paramvar wrapA wrapB + %= quoting for cmd.exe /c pwsh -nop !args! =% + @SETLOCAL EnableDelayedExpansion + + @REM @echo ===================== + set "pval=!%~2:*#=!" + set "pval=!pval:~0,-2!" + @REM set "pval=!pval:~0,-1!" + set "wrapa=%~3" + set "wrapb=%~4" + + @call :strlen pval slen + @rem @echo strlen: !slen! + if "!slen!"=="0" ( + goto :eof + ) + @set /A n = !slen! - 1 + @(set str=) + @set "dq="" + @set "bang=^!" + @(set carat=^^) + @for /l %%i in (0,1,!n!) do @( + (set c=!pval:~%%i,1!) + if "!c!"=="|" ( + set "ch=^^!pval:~%%i,1!" + ) ELSE IF "!c!"=="(" ( + set "ch=^(" + ) ELSE if "!c!"==")" ( + set "ch=^)" + ) ELSE if "!c!"=="&" ( + set "ch=^^&" + ) ELSE if "!c!"=="!dq!" ( + set "ch=^"" + ) ELSE if "!c!"=="!bang!" ( + @rem - double caret - first for initial parsing, second to ensure remains escaped during delayed expansion phase + @rem - REVIEW + set "ch=^^!bang!" + ) ELSE if "!c!"=="^carat" ( + set "ch=^^^^" + ) ELSE if "!c!"=="'" ( + set "ch=''" + ) ELSE ( + set "ch=!c!" + ) + @rem @echo - !ch! + set "str=!str!!ch!" + ) + echo +++++ %~1 = !%1! !str! + + set "%~1=!%1! !wrapa!!str!!wrapb!" + + @rem old method of return - failes to preserve exclamation marks + @rem for /f "delims=" %%A in (""!str!"") do endlocal & set "%~1=!%1! '%%~A'" + @rem macro method of endlocal return - preserving !val! + @echo off + %endlocal% %~1 + + @exit /b + +:rem_output + @rem --------------------------------------------- + @rem rem_output is called for each n in the number of args we process - as we don't have a non-destructive way to count args whilst accepting special chars + @rem we therefore need a way to stop processing on the last received arg so we don't write argCount entries to param.txt if less are received + @rem see 'disappearing quotes' technique + @rem https://stackoverflow.com/questions/4643376/how-to-split-double-quoted-line-into-multiple-lines-in-windows-batch-file/4645113#4645113 + @rem and + @rem https://groups.google.com/g/alt.msdos.batch.nt/c/J71F17Bve9Y (sponge belly) + @echo off + setlocal enableextensions disabledelayedexpansion + set "param1=%~2" + rem do must not be indented + for %%^" in ("") ^ +do if not defined param1 set %%~"param1=%2%%~" + if not defined param1 goto :eof + endlocal + @rem --------------------------------------------- + + @PROMPT @ + @echo on + rem %1 #%2# +@exit /b + +@REM courtesy of: https://stackoverflow.com/users/463115/jeb +:strlen stringVar returnVar +@( + setlocal EnableDelayedExpansion + @SET "rtrn=%~2" + (set^ tmp=!%~1!) + @rem @echo jjjjj !tmp! + @if defined tmp ( + set "len=1" + @for %%P in (4096 2048 1024 512 256 128 64 32 16 8 4 2 1) do @( + @if "!tmp:~%%P,1!" NEQ "" ( + set /a "len+=%%P" + set "tmp=!tmp:~%%P!" + ) + ) + ) ELSE ( + set len=0 + ) +) +@( + endlocal + @IF "%~2" neq "" ( + @SET "%rtrn%=%len%" + ) ELSE ( + @ECHO :strlen result: %len% + ) + exit /b +) + + :getWslPath @SETLOCAL @SET "_path=%~p1" @@ -280,7 +543,7 @@ set -- "$@" "a=[Hide <#;Hide set;S 1 list]"; set -- : "$@";$1 = @' ) ) @EXIT /B -@REM boundary padding +@REM boundary padding @REM boundary padding :getNormalizedScriptTail @SETLOCAL @@ -295,13 +558,12 @@ set -- "$@" "a=[Hide <#;Hide set;S 1 list]"; set -- : "$@";$1 = @' ) @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 +: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' @SETLOCAL @CALL :stringContains %~1 "\" hasBackSlash @CALL :stringContains %~1 "/" hasForwardSlash @@ -327,6 +589,10 @@ set -- "$@" "a=[Hide <#;Hide set;S 1 list]"; set -- : "$@";$1 = @' ) @EXIT /B +@REM boundary padding +@REM boundary padding +@REM boundary padding + :stringContains @REM usage: @CALL:stringContains string needle returnvarname @SETLOCAL @@ -348,7 +614,7 @@ set -- "$@" "a=[Hide <#;Hide set;S 1 list]"; set -- : "$@";$1 = @' @EXIT /B @REM boundary padding @REM boundary padding -:stringToUpper +:stringToUpper strvar returnvar @SETLOCAL @SET "rtrn=%~2" @SET "string=%~1" @@ -384,6 +650,11 @@ set -- "$@" "a=[Hide <#;Hide set;S 1 list]"; set -- : "$@";$1 = @' @EXIT /B @REM boundary padding @REM boundary padding +@REM boundary padding +@REM boundary padding +@REM boundary padding +@REM boundary padding +@REM boundary padding :stringTrimTrailingUnderscores @SETLOCAL @SET "rtrn=%~2" @@ -442,12 +713,104 @@ set -- "$@" "a=[Hide <#;Hide set;S 1 list]"; set -- : "$@";$1 = @' # -- 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 +# -- e.g ./scriptname.cmd in sh or zsh or bash +# -- e.g tclsh scriptname.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 '@ +#--------------------------------------------------------------------- +#divert to configured nextshell +package require platform +set plat_full [platform::generic] +set plat [lindex [split $plat_full -] 0] +#may be old tcl - not assuming readFile available +set fd [open [info script] r] +set scriptdata [read $fd] +close $fd +set scriptdata [string map [list \r\n \n] $scriptdata] +set in_data 0 +set nextshellpath "" +set nextshelltype "" +puts stderr "PLAT: $plat" +foreach ln [split $scriptdata \n] { + if {[string trim $ln] eq ""} {continue} + if {!$in_data} { + if {[string match ": <>*" $ln]} { + set in_data 1 + } + } else { + if {[string match "*@SET*nextshellpath?${plat}_*" $ln]} { + set lineparts [split $ln =] + set tail [lindex $lineparts 1] + set nextshellpath [string trimright $tail {_"}] + if {$nextshellpath ne "" && $nextshelltype ne ""} { + break + } + } elseif {[string match "*@SET*nextshelltype?${plat}_*" $ln]} { + set lineparts [split $ln =] + set tail [lindex $lineparts 1] + set nextshelltype [string trimright $tail {_"}] + if {$nextshellpath ne "" && $nextshelltype ne ""} { + break + } + } elseif {[string match ": <>*" $ln]} { + break + } + } +} +if {$nextshelltype ne "tcl" && $nextshelltype ne "none"} { + if {$nextshelltype in "pwsh powershell"} { + set scrname [file rootname [info script]].ps1 + set arglist [list] + foreach a $::argv { + set a "'$a'" + lappend arglist $a + } + } else { + set scrname [info script] + set arglist $::argv + } + puts stdout "tclsh launching subshell of type: $nextshelltype shellpath: $nextshellpath on script $scrname with args: $arglist" + #todo - handle /usr/bin/env + #todo - exitcode + if {[llength $nextshellpath] == 1 && [string index $nextshellpath 0] eq {"} && [string index $nextshellpath end] eq {"}} { + set nextshell_words [list $nextshellpath] + } else { + set nextshell_words $nextshellpath + } + set ns_firstword [lindex $nextshellpath 0] + if {[string index $ns_firstword 0] eq {"} && [string index $ns_firstword end] eq {"}} { + set ns_firstword [string range $ns_firstword 1 end-1] + } + + if {[string match {/*/env} $ns_firstword] && $::tcl_platform(platform) ne "windows"} { + set exec_part $nextshellpath + } else { + set epath [auto_execok $ns_firstword] + if {$epath eq ""} { + error "unable to find executable path for first word '$ns_firstword' of nextshellpath '$nextshellpath'" + } else { + set exec_part [list {*}$epath {*}[lrange $nextshellpath 1 end]] + } + } + catch {exec {*}$exec_part $scrname {*}$arglist <@stdin >@stdout 2>@stderr} emsg eopts + + if {[dict exists $eopts -errorcode]} { + set ecode [dict get $eopts -errorcode] + if {[lindex $ecode 0] eq "CHILDSTATUS"} { + exit [lindex $ecode 2] + } else { + puts stderr "error calling next shell $nextshelltype :" + puts stderr $emsg + exit 1 + } + } else { + exit 0 + } +} +#--------------------------------------------------------------------- + namespace eval ::punk::multishell { set last_script_root [file dirname [file normalize ${::argv0}/__]] set last_script [file dirname [file normalize [info script]/__]] @@ -481,7 +844,7 @@ namespace eval ::punk::multishell { # -- --- --- --- --- --- --- --- --- --- --- --- # -puts stderr "No tcl code for this script. Try another program such as perl or bash" +puts stderr "No tcl code for this script. Try another program such as zsh or bash or perl" # # @@ -512,21 +875,26 @@ if {[::punk::multishell::is_main]} { # -- --- --- --- --- --- --- --- --- --- --- --- --- ---end Tcl Payload # end hide from unix shells \ HEREDOC1B_HIDE_FROM_BASH_AND_SH -#Be wary of any non-trivial sed/awk etc - can be brittle to maintain across linux,freebsd,macosx due to differing implementations -#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}'` -#------------------------------------------------------ +# Be wary of any non-trivial sed/awk etc - can be brittle to maintain across linux,freebsd,macosx due to differing implementations \ +echo "var0: $0 @: $@" +# echo "script: `echo $0 | sed 's/^-//'`" +# use oldschool backticks and sed - lowest common denominator \ +# echo "shell: " `ps -p $$ | awk '$1 != "PID" {print $(NF)}' | tr -d '()' | sed -E 's/^.*\/|^-//'` +# zsh diversion \ +# if [[ "$argv[*]" != "[*]" ]]; then /usr/bin/env bash "$0" "${argv[@]:2:$((${#argv[@]}-2))}"; exit $?; fi +# \ +ps_shellname=`ps -p $$ | awk '$1 != "PID" {print $(NF)}' | tr -d '()' | sed -E 's/^.*\/|^-//'` +# \ +echo "shell from ps: $ps_shellname argc: ${#@} inner: ${@:2:$((${#@}-2))}" +# non-bash-like diversion \ +if [[ "$ps_shellname" != "bash" && "$ps_shellname" != "zsh" ]]; then /usr/bin/env bash "$0" "${@:2:$((${#@}-2))}"; exit $?; fi +# sh/bash (or zsh?) \ +shift && set -- "${@:1:$((${#@}-1))}" +# \ +#echo "shell:" `ps -o args= $$ | sed -E 's/^.*\/|^-//' | awk '{print $1}'` +# \ +echo "args: $@" +# ------------------------------------------------------ # -- This if block only needed if Tcl didn't exit or return above. if false==false # else { then @@ -541,20 +909,30 @@ if false==false # else { # -- # ## ### ### ### ### ### ### ### ### ### ### ### ### ### -if [[ "$OSTYPE" == "linux"* ]]; then +plat=$(uname -s) #platform/system +if [[ "$plat" = "Linux"* ]]; then os="linux" -elif [[ "$OSTYPE" == "darwin"* ]]; then +elif [[ "$plat" == "Darwin"* ]]; then os="macosx" -elif [[ "$OSTYPE" == "freebsd"* ]]; then +elif [[ "$plat" == "FreeBSD"* ]]; then os="freebsd" -elif [[ "$OSTYPE" == "dragonflybsd"* ]]; then +elif [[ "$plat" == "DragonFly"* ]]; then os="dragonflybsd" -elif [[ "$OSTYPE" == "netbsd"* ]]; then +elif [[ "$plat" == "NetBSD"* ]]; then os="netbsd" -elif [[ "$OSTYPE" == "win32" ]]; then +elif [[ "$plat" == "OpenBSD"* ]]; then + os="openbsd" +elif [[ "$plat" = "MINGW32"* ]]; then os="win32" -elif [[ "$OSTYPE" == "msys" ]]; then +elif [[ "$plat" = "MINGW64"* ]]; then + os="win32" +elif [[ "$plat" = "CYGWIN_NT"* ]]; then + os="win32" +elif [[ "$plat" == "MSYS_NT"* ]]; then + #review.. echo MSYS + #win32 binaries - but e.g tclsh installed in msys reports ::tcl_platform(platform) as 'unix' + #bash reports $OSTYPE msys os="win32" #review - need ps/sed/awk to determine shell? interp = `ps -p $$ | awk '$1 != "PID" {print $(NF)}' | tr -d '()' | sed -E 's/^.*\/|^-//'` @@ -564,20 +942,31 @@ elif [[ "$OSTYPE" == "msys" ]]; then #"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}}" +elif [[ "$OSTYPE" == "win32" ]]; then + os="win32" else #os="$OSTYPE" os="other" fi -#echo ostype: $OSTYPE +echo ostype: $OSTYPE ## This is the sort of sed that will not work across implementations ## shellconfiglines=$( sed -n "/: <>/{:a;n;/: <>/q;p;ba}" "$0" | grep $os) #awk tested on linux & freebsd shellconfiglines=$( awk '/^:.*<>.*$/,/^:.*<>.*$/' "$0" | grep $os) -#echo $shellconfiglines; -readarray -t arr_oslines <<<"$shellconfiglines" +# echo $shellconfiglines; +# readarray requires bash 4.0 +if [[ "$ps_shellname" == "bash" ]]; then + readarray -t arr_oslines <<<"$shellconfiglines" +elif [[ "$ps_shellname" == "zsh" ]]; then + arr_oslines=("${(f)shellconfiglines}") +else + #fallback - doesn't seem to work in zsh - untested in early bash + IFS=$'\n' arr_oslines=($shellconfiglines) +fi nextshellpath="" nextshelltype="" for ln in "${arr_oslines[@]}"; do + # echo "---- $ln" if [[ "$ln" == *"nextshellpath"* ]]; then splitln="${ln#*=}" #remove everything through the first '=' pathraw="${splitln%%\"*}" #take everything before the quote - use %% to get longest match @@ -588,34 +977,15 @@ for ln in "${arr_oslines[@]}"; do splitln="${ln#*=}" typeraw="${splitln%%\"*}" nextshelltype="${typeraw/%_*/}" + echo "nextshelltype: $nextshelltype" fi done -#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" "$@" + echo bash launching subshell of type: $nextshelltype shellpath: $nextshellpath on "$0" with args "$@" + #e.g /usr/bin/env tclsh "$0" "$@" ${nextshellpath} "$0" "$@" exitcode=$? @@ -646,44 +1016,67 @@ scriptroot="${basename%.*}" #e.g "fetchruntime" url_kitbase="https://www.gitea1.intx.com.au/jn/punkbin/raw/branch/master" runtime_available=0 -if [[ "$OSTYPE" == "linux"* ]]; then - arch=$(uname -i) - if [[ "$arch" == "x86_64"* ]]; then +#$OSTYPE varies in capitalization across for example zsh and bash +#uname probably a more consistent bet +arch=$(uname -m) #machine/architecture +plat=$(uname -s) #platform/system +#even though most of the platform prongs are very similar, +#we keep the code separate so it can be tweaked easily for unexpected differences +if [[ "$plat" = "Linux"* ]]; then + if [[ "$arch" = "x86_64"* ]]; then url="${url_kitbase}/linux-x86_64/tclkit-902-Linux64-intel-dyn" archdir="${scriptdir}/runtime/linux-x86_64" output="${archdir}/tclkit-902-Linux64-intel-dyn" runtime_available=1 - elif [[ "$arch" == "arm"* ]]; then + elif [[ "$arch" = "arm"* ]]; then url="${url_kitbase}/linux-arm/tclkit-902-Linux64-arm-dyn" archdir="${scriptdir}/runtime/linux-arm" output="${archdir}/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" + else + archdir="${scriptdir}/runtime/linux-$arch" fi os="linux" -elif [[ "$OSTYPE" == "darwin"* ]]; then +elif [[ "$plat" = "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" archdir="${scriptdir}/runtime/macosx/" output="${archdir}/tclkit-902-Darwin64-dyn" runtime_available=1 -elif [[ "$OSTYPE" == "freebsd"* ]]; then +elif [[ "$plat" = "FreeBSD"* ]]; then + archdir="${scriptdir}/runtime/freebsd-amd64" os="freebsd" -elif [[ "$OSTYPE" == "dragonflybsd"* ]]; then +elif [[ "$plat" == "DragonFly"* ]]; then + archdir="${scriptdir}/runtime/dragonflybsd-$arch" os="dragonflybsd" -elif [[ "$OSTYPE" == "netbsd"* ]]; then +elif [[ "$plat" == "NetBSD"* ]]; then + archdir="${scriptdir}/runtime/netbsd-$arch" os="netbsd" -elif [[ "$OSTYPE" == "win32" ]]; then +elif [[ "$plat" == "OpenBSD"* ]]; then + archdir="${scriptdir}/runtime/openbsd-amd64" + os="openbsd" +elif [[ "$plat" == "MINGW32"* ]]; then + #REVIEW + os="win32" + url="${url_kitbase}/win32-x86_64/tclsh902z.exe" + archdir="${scriptdir}/runtime/win32-x86_64/" + output="${archdir}/tclsh902z.exe" + runtime_available=1 +elif [[ "$plat" == "MINGW64"* ]]; then + #REVIEW os="win32" url="${url_kitbase}/win32-x86_64/tclsh902z.exe" archdir="${scriptdir}/runtime/win32-x86_64/" - output="${archdir}/tcsh902z.exe" + output="${archdir}/tclsh902z.exe" + runtime_available=1 +elif [[ "$plat" == "CYGWIN_NT"* ]]; then + os="win32" + url="${url_kitbase}/win32-x86_64/tclsh902z.exe" + archdir="${scriptdir}/runtime/win32-x86_64/" + output="${archdir}/tclsh902z.exe" runtime_available=1 -elif [[ "$OSTYPE" == "msys" ]]; then +elif [[ "$plat" == "MSYS_NT"* ]]; then echo MSYS os="win32" #use 'command -v' (shell builtin preferred over external which) @@ -698,7 +1091,7 @@ elif [[ "$OSTYPE" == "msys" ]]; then output="${archdir}/tclsh902z.exe" runtime_available=1 else - #os="$OSTYPE" + archdir="${scriptdir}/runtime/other" os="other" fi @@ -714,6 +1107,10 @@ case "$1" in if [[ $? -eq 0 ]]; then echo "File downloaded to $output" chmod +x $output + if [[ "$plat" == "Linux" ]]; then + echo "Please ensure libxFt.so.2 is available" + echo "e.g on Ubuntu: sudo apt-get install libxft2" + fi else echo "Error: Failed to download to $output" fi @@ -722,24 +1119,25 @@ case "$1" in fi ;; "list") - if [ -d $archdir ]; then + if [[ -d "$archdir" ]]; then echo "$(ls $archdir -1 | wc -l) files in $archdir" echo $(ls $archdir -1) else - echo "No runtimes available in $archdir\n Use '$0 fetch' to install." + echo -e "No runtimes available in $archdir\n Use '$0 fetch' to install." fi ;; "run") #todo - lookup active runtime for os-arch from .toml file activeruntime=$(ls $archdir -1 | tail -n 1) activeruntime_fullpath="$archdir/$activeruntime" - echo "using $activeruntime_fullpath" + #echo "using $activeruntime_fullpath" shift - echo "args: $@" + #echo "args: $@" $activeruntime_fullpath "$@" ;; *) echo "Usage: $0 {fetch|list|run}" + echo "received $@" exit 1 ;; esac @@ -924,18 +1322,18 @@ 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 -#"Powershell Version: {0}" -f $PSVersionTable.PSVersion.Major | write-host -#"powershell args : {0}" -f ($args -join ", ") | 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 # -- --- --- --- +$thisfileContent = Get-Content $scriptname -Raw $startTag = ": <>" $endTag = ": <>" -$fileContent = Get-Content $scriptname -Raw -$pattern = "(?s)$startTag(.*?)$endTag" -$matches = [regex]::Matches($fileContent,$pattern) -$admininfo = $matches[0].Groups[1].Value +$pattern = "(?s)`n$startTag[^`n]*`n(.*?)`n$endTag" +$match = [regex]::Match($thisfileContent,$pattern) $asadmin = 0 -if ($matches.count) { +if ($match.Success) { + $admininfo = $match.Groups[1].Value $asadmin = $admininfo.Contains("asadmin=1") if ($asadmin) { if (-not ([Security.Principal.WindowsPrincipal][Security.Principal.WindowsIdentity]::GetCurrent()).IsInRole([Security.Principal.WindowsBuiltInRole]::Administrator)) { @@ -953,6 +1351,67 @@ if ($matches.count) { } } } +# +$startTag = ": <>" +$endTag = ": <>" +$pattern = "(?s)`n$startTag[^`n]*`n(.*?)`n$endTag" +$match = [regex]::Match($thisfileContent,$pattern) +if ($match.Success) { + $plat = [System.Environment]::OSVersion.Platform + if ($plat -eq "Unix") { + $runtime_ident = [System.Runtime.InteropServices.RuntimeInformation]::RuntimeIdentifier + switch ($runtime_ident.split("-")[0]) { + "freebsd" { + # untested + $os = "freebsd" + } + "linux" { + $os = "linux" + } + "osx" { + # osx-x64 or osx-arm64 ? + $os = "macosx" + } + default { + #openbsd, netbsd ? + $os = "other" + } + } + } else { + $os = "win32" + } + + $matchedlines = $match.Groups[1].Value + $nextshell_type = "" + $nextshell_path = "" + ForEach ($line in $($matchedlines -split "\r?\n")) { + $m = [regex]::Match($line,".*nextshelltype\[${os}[_]+\]=([^_]*)[_]*") + if ($m.Success) { + $nextshell_type = $m.Groups[1].Value + } + $m = [regex]::Match($line,".*nextshellpath\[${os}[_]+\]=([^_]*)[_]*") + if ($m.Success) { + $nextshell_path = $m.Groups[1].Value + } + if ($nextshell_type -ne "" -and $nextshell_path -ne "") { + break + } + } + 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" + + # $arguments = @($($MyInvocation.MyCommand.Path)) + # $arguments += $args + # NOTE - this gives incorrect argument quoting e.g wrong number of arguments received by launched process for arguments: a "b c" + # $process = (Start-Process -FilePath $nextshell_path -ArgumentList $arguments -NoNewWindow -Wait) + # Exit $process.ExitCode + + & $nextshell_path $scriptname $args + exit $LASTEXITCODE + } +} + # -- --- --- --- --- --- --- --- --- --- --- --- --- ---begin powershell Payload # @@ -994,7 +1453,7 @@ function GetDynamicParamDictionary { } function ParameterDefinitions { param( - [Parameter(ValueFromRemainingArguments=$true)] $opts + [Parameter(ValueFromRemainingArguments=$true,Position = 1)][string[]] $opts ) } @@ -1002,15 +1461,28 @@ function psmain { [CmdletBinding()] #Empty param block (extra params can be added) param( - [Parameter(Mandatory=$false)][string] $action + [Parameter(Mandatory=$false, Position = 0)][string] $action = "" ) dynamicparam { if ($action -eq 'list') { + $parameterAttribute = [System.Management.Automation.ParameterAttribute]@{ + ParameterSetName = "listruntime" + Mandatory = $false + } + $attributeCollection = [System.Collections.ObjectModel.Collection[System.Attribute]]::new() + $attributeCollection.Add($parameterAttribute) + $dynParam1 = [System.Management.Automation.RuntimeDefinedParameter]::new( + 'remote', [switch], $attributeCollection + ) + $paramDictionary = [System.Management.Automation.RuntimeDefinedParameterDictionary]::new() + $paramDictionary.Add('remote', $dynParam1) + return $paramDictionary } elseif ($action -eq 'fetch') { #GetDynamicParamDictionary ParameterDefinitions $parameterAttribute = [System.Management.Automation.ParameterAttribute]@{ ParameterSetName = "fetchruntime" Mandatory = $false + Position = 1 } $attributeCollection = [System.Collections.ObjectModel.Collection[System.Attribute]]::new() $attributeCollection.Add($parameterAttribute) @@ -1023,8 +1495,39 @@ function psmain { $paramDictionary.Add('runtime', $dynParam1) return $paramDictionary } elseif ($action -eq 'run') { - GetDynamicParamDictionary ParameterDefinitions + #GetDynamicParamDictionary ParameterDefinitions + $parameterAttribute = [System.Management.Automation.ParameterAttribute]@{ + ParameterSetName = "runargs" + Mandatory = $false + ValueFromRemainingArguments = $true + } + $attributeCollection = [System.Collections.ObjectModel.Collection[System.Attribute]]::new() + $attributeCollection.Add($parameterAttribute) + + $dynParam1 = [System.Management.Automation.RuntimeDefinedParameter]::new( + 'opts', [string[]], $attributeCollection + ) + + $paramDictionary = [System.Management.Automation.RuntimeDefinedParameterDictionary]::new() + $paramDictionary.Add('opts', $dynParam1) + return $paramDictionary } else { + #accept all args when action is unrecognised - so we can go to help anyway + $parameterAttribute = [System.Management.Automation.ParameterAttribute]@{ + ParameterSetName = "invalidaction" + Mandatory = $false + ValueFromRemainingArguments = $true + } + $attributeCollection = [System.Collections.ObjectModel.Collection[System.Attribute]]::new() + $attributeCollection.Add($parameterAttribute) + + $dynParam1 = [System.Management.Automation.RuntimeDefinedParameter]::new( + 'opts', [string[]], $attributeCollection + ) + + $paramDictionary = [System.Management.Automation.RuntimeDefinedParameterDictionary]::new() + $paramDictionary.Add('opts', $dynParam1) + return $paramDictionary } } process { @@ -1032,7 +1535,7 @@ function psmain { #write-host "Bound Parameters:$($PSBoundParameters.Keys)" switch ($PSBoundParameters.keys) { 'action' { - #write-host "got action " $PSBoundParameters.action + write-host "got action " $PSBoundParameters.action Set-Variable -Name $_ -Value $PSBoundParameters."$_" $known_actions = @("fetch", "list", "run") if (-not($known_actions -contains $action)) { @@ -1041,10 +1544,10 @@ function psmain { } } 'opts' { - #write-warning "Unused parameters: $($PSBoundParameters.$_)" + # write-warning "Unused parameters: $($PSBoundParameters.$_)" } Default { - #write-warning "Unhandled parameter -> [$($_)]" + # write-warning "Unhandled parameter -> [$($_)]" } } #foreach ($boundparam in $PSBoundParameters.Keys) { @@ -1058,11 +1561,15 @@ function psmain { $outbase = Resolve-Path -Path $outbase #expected script location is the bin folder of a punk project $rtfolder = Join-Path -Path $outbase -ChildPath "runtime" - $archfolder = Join-Path -Path $rtfolder -ChildPath "win32-x86_64" + #Binary artifact server url. (git is not ideal for this - but will do for now - todo - use artifact system within gitea?) + $artifacturl = "https://www.gitea1.intx.com.au/jn/punkbin/raw/branch/master" switch ($action) { 'fetch' { + $arch = "win32-x86_64" + $archfolder = Join-Path -Path $rtfolder -ChildPath "$arch" + $archurl = "$artifacturl/$arch" + $sha1url = "$archurl/sha1sums.txt" $runtime = "tclsh902z.exe" - $archurl = "https://www.gitea1.intx.com.au/jn/punkbin/raw/branch/master/win32-x86_64" foreach ($boundparam in $PSBoundParameters.Keys) { write-host "fetchopt: $boundparam $($PSBoundParameters[$boundparam])" } @@ -1070,44 +1577,138 @@ function psmain { $runtime = $PSBoundParameters["runtime"] } $fileurl = "$archurl/$runtime" - $output = join-path $archfolder $runtime + + $output = join-path -Path $archfolder -ChildPath $runtime + $sha1local = join-path -Path $archfolder -ChildPath "sha1sums.txt" $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 $fileurl ..." - try { - $response = Invoke-WebRequest -Uri $fileurl -OutFile $output -ErrorAction Stop - Write-Host "Runtime saved at $output" + try { + Write-Host "Fetching $sha1url" + Invoke-WebRequest -Uri $sha1url -OutFile $sha1local -ErrorAction Stop + Write-Host "sha1 saved at $sha1local" + } catch { + Write-Host "An error occurred while downloading ${sha1url}: $($_.Exception.Message)" + if ($_.Exception.Response) { + Write-Host "HTTP Status code: $($_.Exception.Response.StatusCode)" } - catch { - Write-Host "An error occurred: $($_.Exception.Message)" - if ($_.Exception.Response) { - Write-Host "HTTP Status code: $($_.Exception.Response.StatusCode)" + } + if (Test-Path -Path $sha1local -PathType Leaf) { + $sha1Content = Get-Content -Path $sha1local + $stored_sha1 = "" + foreach ($line in $sha1Content) { + #all sha1sums have * (binary indicator) - review + $match = [regex]::Match($line,"(.*) [*]${runtime}$") + if ($match.Success) { + $stored_sha1 = $match.Groups[1].Value + Write-host "stored hash from sha1sums.txt: $storedhash" + break } } + if ($stored_sha1 -eq "") { + Write-Host "Unable to locate hash for $runtime in $sha1local - Aborting" + Write-Host "Please download and verify manually" + return + } + + $need_download = $false + if (Test-Path -Path $output -PathType Leaf) { + Write-Host "Runtime already found at $output" + Write-Host "Checking sha1 checksum of local file versus sha1 of server file" + $file_sha1 = Get-FileHash -Path "$output" -Algorithm SHA1 + if (${file_sha1}.Hash -ne $stored_sha1) { + Write-Host "$runtime on server has different sha1 hash - Download required" + $need_download = $true + } + } else { + Write-Host "$runtime not found locally - Download required" + $need_download = $true + } + + if ($need_download) { + Write-Host "Downloading from $fileurl ..." + try { + Invoke-WebRequest -Uri $fileurl -OutFile "${output}.tmp" -ErrorAction Stop + Write-Host "Runtime saved at $output.tmp" + } + catch { + Write-Host "An error occurred while downloading $fileurl $($_.Exception.Message)" + if ($_.Exception.Response) { + Write-Host "HTTP Status code: $($_.Exception.Response.StatusCode)" + } + return + } + Write-Host "comparing sha1 checksum of downloaded file with data in sha1sums.txt" + Start-Sleep -Seconds 1 #REVIEW - give at least some time for windows to do its thing? (av filters?) + $newfile_sha1 = Get-FileHash -Path "${output}.tmp" -Algorithm SHA1 + if (${newfile_sha1}.Hash -eq $stored_sha1) { + Write-Host "sha1 checksum ok" + Move-Item -Path "${output}.tmp" -Destination "${output}" -Force + Write-Host "Runtime is available at ${output}" + } else { + Write-Host "WARNING! sha1 of downloaded file at $output.tmp does not match stored sha1 from sha1sums.txt" + return + } + } else { + Write-Host "Local copy of runtime at $output seems to match sha1 checksum of file on server." + Write-Host "No download required" + } } else { - Write-Host "Runtime already found at $output" + Write-Host "Unable to consult local copy of sha1sums.txt at $sha1local" + if (Test-Path -Path $output -PathType Leaf) { + Write-Host "A runtime is available at $output - but we failed to retrieve the list of sha1sums from the server" + Write-Host "Unable to check for updated version at this time." + } else { + Write-Host "Please retry - or manually download a runtime from $archurl and verify checksums" + } } } 'run' { #select first (or configured default) runtime and launch, passing arguments + $arch = "win32-x86_64" + $archfolder = Join-Path -Path $rtfolder -ChildPath "$arch" if (-not(Test-Path -Path $archfolder -PathType Container)) { write-host "No runtimes seem to be installed for win32-x86_64`nPlease use 'runtime.cmd fetch' to install" } else { $dircontents = (get-childItem -Path $archfolder -File | Sort-Object Name) if ($dircontents.Count -gt 0) { #write-host "run.." - #write-host "num params: $($PSBoundParameters.opts.count)" - #foreach ($boundparam in $PSBoundParameters.opts) { - # write-host $boundparam - #} + write-host "num params: $($PSBoundParameters.opts.count)" + #todo - use 'active' runtime - need to lookup (PSToml?) #when no 'active' runtime for this os-arch - use last item (sorted in dictionary order) - $active = $dircontents[-1] - #write-host "using: $active" - Start-Process -FilePath $active -ArgumentList $PSBoundParameters.opts -NoNewWindow -Wait + $active = $dircontents[-1].FullName + write-host "using: $active" + if ($PSBoundParameters.opts.Length -gt 0) { + $optsType = $PSBoundParameters.opts.GetType() #method can only be called if .opts is not null + write-host "type of opts: $($optsType.FullName)" + foreach ($boundparam in $PSBoundParameters.opts) { + write-host $boundparam + } + Write-Host "opts: $($PSBoundParameters.opts)" + Write-Host "args: $args" + Write-HOst "argscount: $($args.Count)" + $arglist = @() + foreach ($o in $PSBoundParameters.opts) { + $oquoted = $o -replace '"', "`\`"" + #$oquoted = $oquoted -replace "'", "`'" + if ($oquoted -match "\s") { + $oquoted = "`"$oquoted`"" + } + $arglist += @($oquoted) + } + $arglist = $arglist.TrimEnd(' ') + write-host "arglist: $arglist" + #$arglist = $PSBoundParameters.opts + Start-Process -FilePath $active -ArgumentList $arglist -NoNewWindow -Wait + } else { + #powershell 5.1 and earlier can't accept an empty -ArgumentList value :/ !! + #$arglist = @() + #Start-Process -FilePath $active -ArgumentList $arglist -NoNewWindow -Wait + #Start-Process -FilePath $active -ArgumentList "" -NoNewWindow -Wait + Start-Process -FilePath $active -NoNewWindow -Wait + } } else { write-host "No files found in $archfolder" write-host "No runtimes seem to be installed for win32-x86_64`nPlease use 'runtime.cmd fetch' to install." @@ -1115,19 +1716,104 @@ function psmain { } } 'list' { - if (test-path -Path $archfolder -Type Container) { - $dircontents = (get-childItem -Path $archfolder -File) - write-host "$(${dircontents}.count) files in $archfolder" - foreach ($f in $dircontents) { - write-host $f.Name + #todo - option to list for other os-arch + $arch = 'win32-x86_64' + $archfolder = Join-Path -Path $rtfolder -ChildPath "$arch" + $sha1local = join-path -Path $archfolder -ChildPath "sha1sums.txt" + $archurl = "$artifacturl/$arch" + $sha1url = "$archurl/sha1sums.txt" + if ( $PSBoundParameters.ContainsKey('remote') ) { + write-host "Checking for available remote runtimes for" + Write-Host "Fetching $sha1url" + Invoke-WebRequest -Uri $sha1url -OutFile $sha1local -ErrorAction Stop + Write-Host "sha1 saved at $sha1local" + $sha1Content = Get-Content -Path $sha1local + $remotedict = @{} + foreach ($line in $sha1Content) { + #all sha1sums have * (binary indicator) - review + $match = [regex]::Match($line,"(.*) [*](.*)$") + if ($match.Success) { + $server_sha1 = $match.Groups[1].Value + $server_rt = $match.Groups[2].Value + $remotedict[$server_rt] = $server_sha1 + } } + + $localdict = @{} + if (test-path -Path $archfolder -Type Container) { + $dircontents = (get-childItem -Path $archfolder -File | Where-object {-not ($(".txt",".tm") -contains $_.Extension) }) + foreach ($f in $dircontents) { + $local_sha1 = Get-FileHash -Path $(${f}.FullName) -Algorithm SHA1 + $localdict[$f.Name] = ${local_sha1}.Hash + } + } + + Write-host "-----------------------------------------------------------------------" + Write-host "Runtimes for $arch" + Write-host "Local $archfolder" + Write-host "Remote $$archurl" + Write-host "-----------------------------------------------------------------------" + Write-host "Local Remote" + Write-host "-----------------------------------------------------------------------" + # 12345678910234567892023456789302345 + $G = "`e[32m" #Green + $Y = "`e[33m" #Yellow + $R = "`e[31m" #Red + $RST = "`e[m" + foreach ($key in $localdict.Keys) { + $local_sha1 = $($localdict[$key]) + if ($remotedict.ContainsKey($key)) { + if ($local_sha1 -eq $remotedict[$key]) { + $rhs = "Same version" + $C = $G + } else { + $rhs = "UPDATE AVAILABLE" + $C = $Y + } + } else { + $C = $R + $rhs = "(not listed on server)" + } + #ansi problems from cmd.exe not in windows terminal - review + $C = "" + $RST = "" + $lhs = "$key".PadRight(35, ' ') + write-host -nonewline "${C}${lhs}${RST}" + write-host $rhs + } + $lhs_missing = "-".PadRight(35, ' ') + foreach ($key in $remotedict.Keys) { + if (-not ($localdict.ContainsKey($key))) { + write-host -nonewline $lhs_missing + write-host $key + } + } + Write-host "-----------------------------------------------------------------------" + } else { - write-host "No runtimes seem to be installed for win32-x86_64 in $archfolder`nPlase use 'runtime.cmd fetch' to install." + if (test-path -Path $archfolder -Type Container) { + Write-host "-----------------------------------------------------------------------" + Write-Host "Local runtimes for $arch" + $dircontents = (get-childItem -Path $archfolder -File | Where-object {-not ($(".txt",".tm") -contains $_.Extension) }) + write-host "$(${dircontents}.count) files in $archfolder" + Write-host "-----------------------------------------------------------------------" + foreach ($f in $dircontents) { + write-host $f.Name + } + Write-host "-----------------------------------------------------------------------" + Write-host "Use: 'list -remote' to compare local runtimes with those available on the artifact server" + } else { + write-host "No runtimes seem to be installed for win32-x86_64 in $archfolder`nPlease use 'runtime.cmd fetch' to install." + } } } default { $actions = @("fetch", "list", "run") write-host "Available actions: $actions" + write-host "received" + foreach ($boundparam in $PSBoundParameters.opts) { + write-host $boundparam + } } } @@ -1135,9 +1821,10 @@ function psmain { } } #write-host (psmain @args) -$returnvalue = psmain @args +#$returnvalue = psmain @args #Write-Host "Function Returned $returnvalue" -ForegroundColor Cyan -return $returnvalue +#return $returnvalue +psmain @args | out-null exit 0 diff --git a/bin/tclargs.cmd b/bin/tclargs.cmd new file mode 100644 index 00000000..61bfbf51 --- /dev/null +++ b/bin/tclargs.cmd @@ -0,0 +1,1338 @@ +: "punk MULTISHELL - shebangless polyglot for Tcl Perl sh bash cmd pwsh powershell" + "[rename set S;proc Hide shell_not_supported {proc $shell_not_supported 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 ------------------------------------------------------------------------------------------------------------------------------- +@rem return from endlocal macro - courtesy of jeb +@rem This allows return of values containing special characters from subroutines +@rem https://stackoverflow.com/questions/3262287/make-an-environment-variable-survive-endlocal/8257951#8257951 +@rem ------------------------------------------------------------------------------------------------------------------------------- +@setlocal DisableDelayedExpansion +@echo off +%= 2 blank lines after next are required =% +set LF=^ + + +set ^"\n=^^^%LF%%LF%^%LF%%LF%^^" +%= I use EDE for EnableDelayeExpansion and DDE for DisableDelayedExpansion =% +set ^"endlocal=for %%# in (1 2) do if %%#==2 (%\n% + setlocal EnableDelayedExpansion%\n% + %= Take all variable names into the varName array =%%\n% + set varName_count=0%\n% + for %%C in (!args!) do set "varName[!varName_count!]=%%~C" ^& set /a varName_count+=1%\n% + %= Build one variable with a list of set statements for each variable delimited by newlines =%%\n% + %= The lists looks like --> set result1=myContent\n"set result1=myContent1"\nset result2=content2\nset result2=content2\n =%%\n% + %= Each result exists two times, the first for the case returning to DDE, the second for EDE =%%\n% + %= The correct line will be detected by the (missing) enclosing quotes =%%\n% + set "retContent=1!LF!"%\n% + for /L %%n in (0 1 !varName_count!) do (%\n% + for /F "delims=" %%C in ("!varName[%%n]!") DO (%\n% + set "content=!%%C!"%\n% + set "retContent=!retContent!"set !varName[%%n]!=!content!"!LF!"%\n% + if defined content (%\n% + %= This complex block is only for replacing '!' with '^!' =%%\n% + %= First replacing '"'->'""q' '^'->'^^' =%%\n% + set ^"content_EDE=!content:"=""q!"%\n% + set "content_EDE=!content_EDE:^=^^!"%\n% + %= Now it's poosible to use CALL SET and replace '!'->'""e!' =%%\n% + call set "content_EDE=%%content_EDE:^!=""e^!%%"%\n% + %= Now it's possible to replace '""e' to '^', this is effectivly '!' -> '^!' =%%\n% + set "content_EDE=!content_EDE:""e=^!"%\n% + %= Now restore the quotes =%%\n% + set ^"content_EDE=!content_EDE:""q="!"%\n% + ) ELSE set "content_EDE="%\n% + set "retContent=!retContent!set "!varName[%%n]!=!content_EDE!"!LF!"%\n% + )%\n% + )%\n% + %= Now return all variables from retContent over the barrier =%%\n% + for /F "delims=" %%V in ("!retContent!") DO (%\n% + %= Only the first line can contain a single 1 =%%\n% + if "%%V"=="1" (%\n% + %= We need to call endlocal twice, as there is one more setlocal in the macro itself =%%\n% + endlocal%\n% + endlocal%\n% + ) ELSE (%\n% + %= This is true in EDE =%%\n% + if "!"=="" (%\n% + if %%V==%%~V (%\n% + %%V !%\n% + )%\n% + ) ELSE IF not %%V==%%~V (%\n% + %%~V%\n% + )%\n% + )%\n% + )%\n% + ) else set args=" + +@rem ------------------------------------------------------------------------------------------------------------------------------- +@SETLOCAL EnableExtensions EnableDelayedExpansion +@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 +@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___________]=tclsh___________________________________________________________" +@SET "nextshelltype[win32___________]=tcl_____________" +@SET "nextshellpath[dragonflybsd____]=tclsh___________________________________________________________" +@SET "nextshelltype[dragonflybsd____]=tcl_____________" +@SET "nextshellpath[freebsd_________]=tclsh___________________________________________________________" +@SET "nextshelltype[freebsd_________]=tcl_____________" +@SET "nextshellpath[netbsd__________]=tclsh___________________________________________________________" +@SET "nextshelltype[netbsd__________]=tcl_____________" +@SET "nextshellpath[linux___________]=tclsh___________________________________________________________" +@SET "nextshelltype[linux___________]=tcl_____________" +@SET "nextshellpath[macosx__________]=tclsh___________________________________________________________" +@SET "nextshelltype[macosx__________]=tcl_____________" +@SET "nextshellpath[other___________]=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" +: <> +@SET "selected_shelltype=%nextshelltype[win32___________]%" +@REM @ECHO selected_shelltype %selected_shelltype% +@CALL :stringTrimTrailingUnderscores %selected_shelltype% selected_shelltype_trimmed +@REM @ECHO selected_shelltype_trimmed %selected_shelltype_trimmed% +@SET "selected_shellpath=%nextshellpath[win32___________]%" +@CALL :stringTrimTrailingUnderscores %selected_shellpath% selected_shellpath_trimmed +@CALL SET "keyRemoved=%%validshelltypes:!selected_shelltype!=%%" +@REM @ECHO keyremoved %keyRemoved% +@REM Note that 'powershell' e.g v5 is just a fallback for when pwsh is not available +@REM ## ### ### ### ### ### ### ### ### ### ### ### ### ### +@REM -- cmd/batch file section (ignored on unix but should be left in place) +@REM -- This section intended mainly to launch the next shell (and to escalate privileges if necessary) +@REM -- Avoid customising this if you are not familiar with batch scripting. cmd/batch script can be useful, but is probably the least expressive language and most error prone. +@REM -- For example - as this file needs to use unix-style lf line-endings - the label scanner is susceptible to the 512Byte boundary issue: https://www.dostips.com/forum/viewtopic.php?t=8988#p58888 +@REM -- This label issue can be triggered/abused in files with crlf line endings too - but it is less likely to happen accidentaly. +@REm -- See also: https://stackoverflow.com/questions/4094699/how-does-the-windows-command-interpreter-cmd-exe-parse-scripts/4095133#4095133 +@REM ############################################################################################################################ +@REM -- Due to this issue -seemingly trivial edits of the batch file section can break the script! (for Windows anyway) +@REM -- Even something as simple as adding or removing an @REM +@REM -- From within punkshell - use: +@REM -- deck scriptwrap.checkfile filepath +@REM -- to check your templates or final wrapped scripts for byte boundary issues +@REM -- It will report any labels that are on boundaries +@REM -- This is why the nextshell value above is a 2 digit key instead of a string - so that editing the value doesn't change the byte offsets. +@REM -- Editing your sh,bash,tcl,pwsh payloads is much less likely to cause an issue. There is the possibility of the final batch :exit_multishell label spanning a boundary - so testing using deck scriptwrap.checkfile is still recommended. +@REM -- Alternatively, as you should do anyway - test the final script on windows +@REM -- Aside from adding comments/whitespace to tweak the location of labels - you can try duplicating the label (e.g just add the label on a line above) but this is not guaranteed to work in all situations. +@REM -- '@REM' is a safer comment mechanism than a leading colon - which is used sparingly here. +@REM -- A colon anywhere in the script that happens to land on a 512 Byte boundary (from file start or from a callsite) could be misinterpreted as a label +@REM -- It is unknown what versions of cmd interpreters behave this way - and deck scriptwrap.checkfile doesn't check all such boundaries. +@REM -- For this reason, batch labels should be chosen to be relatively unlikely to collide with other strings in the file, and simple names such as :exit or :end should probably be avoided +@REM ############################################################################################################################ +@REM -- custom windows payloads should be in powershell,tclsh (or sh/bash if available) code sections +@REM ## ### ### ### ### ### ### ### ### ### ### ### ### ### +@SET "winpath=%~dp0" %= e.g c:\punkshell\bin\ %= +@SET "fname=%~nx0" +@SET "scriptrootname=%~dp0%~n0" %= e.g c:\punkshell\bin\runtime (full path without extension) unavailable after shift, so store it =% +@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 +@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 +) + + + + +@set argCount=30 +@rem This is the max number of args we are willing to handle. also bounded by approx 8k char limit of cmd.exe +@rem We do not loop over %* to count args as it is brittle for some inputs e.g will always skip cmd.exe separators e.g comma and semicolon +@rem Set argCount higher if desired, but there is a small amount of additional looping overhead. + +@set tmpfile_base=%TEMP%\punkbatch_params +@call :getUniqueFile %tmpfile_base% ".txt" paramfile +@echo %paramfile% + +%= NOTE when we loop like this using the percent-n args, we lose unquoted separators such as comma and semicolon %= +@rem https://stackoverflow.com/questions/26551/how-can-i-pass-arguments-to-a-batch-file/5493124#5493124 +@rem outer loop required to redirect all rem lines at once to file +@for %%x in (1) do @( + @for /L %%f in (1,1,%argCount%) do @( + @set "argnum=%%~nf" + @set "a1=%%1" + @rem @set "argname=%%!argnum!" + @rem @echo argname: !argname! + @call :rem_output !argnum! !a1! + @shift + ) +) > %paramfile% +@echo off + +@set "newcommandline= " + +@(set target=cmd_pwsh) +@if "%target%"=="cmd_pwsh" ( + @for /F "delims=" %%L in (%paramfile%) do @( + SETLOCAL DisableDelayedExpansion + set "param=%%L" + @REM @echo ######### %%L + @rem call :buildcmdline newcommandline param "{" "}" + call :buildcmdline newcommandline param ' ' %= cmd.exe /c powershell %= + @rem @echo . + ) +) ELSE ( + @for /F "delims=" %%L in (%paramfile%) do @( + SETLOCAL DisableDelayedExpansion + set "param=%%L" + call :buildcmdline newcommandline param + ) +) +@REM padding +SETLOCAL EnableDelayedExpansion + +@echo off +@IF EXIST %paramfile% ( + @DEL /F /Q %paramfile% +) +@IF EXIST %paramfile% ( + echo failed to delete %paramfile% + cat %paramfile% +) + + + +@REM @SET "squoted_args=" +@REM @for %%a in (%*) do @( +@REM set "v=%%a" +@REM set "v=!v:'=''!" +@REM SET "squoted_args=!squoted_args!'!v!' " +@REM ) +@REM @SET "squoted_args=%squoted_args:~0,-1%" +@REM @ECHO %squoted_args% + + +@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 ( + @rem pwsh -nop -nol -c set-executionpolicy -Scope Process Unrestricted; "%scriptrootname%.ps1" %arglist% + @rem pwsh -nop -nol -c set-executionpolicy -Scope Process Unrestricted + cmd /c pwsh -nop -nol -ExecutionPolicy bypass -c "%scriptrootname%.ps1" !newcommandline! + SET task_exitcode=!errorlevel! + ) ELSE ( + REM TODO prompt user with option to call script to install pwsh using winget + @rem powershell -nop -nol -ExecutionPolicy Bypass -c "%scriptrootname%.ps1" %arglist% + cmd /c powershell -nop -nol -ExecutionPolicy Bypass -c "%scriptrootname%.ps1" !newcommandline! + SET task_exitcode=!errorlevel! + ) +) ELSE ( + IF "!selected_shelltype_trimmed!"=="powershell" ( + @rem powershell -nop -nol -ExecutionPolicy Bypass -c "%scriptrootname%.ps1" %arglist% + cmd /c powershell -nop -nol -ExecutionPolicy Bypass -c "%scriptrootname%.ps1" !newcommandline! + 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% "%winpath%%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 + +@GOTO :endlib + +@REM padding +@REM padding +@REM padding + +%= ---------------------------------------------------------------------- =% +@rem courtesy of dbenham +:: Example usage +@rem call :getUniqueFile "d:\test\myFile" ".txt" myFile +@rem echo myFile="%myFile%" + +:getUniqueFile baseName extension rtnVar +setlocal +:getUniqueFileLoop +for /f "skip=1" %%A in ('wmic os get localDateTime') do for %%B in (%%A) do set "rtn=%~1_%%B%~2" +if exist "%rtn%" ( + goto :getUniqueFileLoop +) else ( + 2>nul >nul (9>"%rtn%" timeout /nobreak 1) || goto :getUniqueFileLoop +) +endlocal & set "%~3=%rtn%" +exit /b +%= ---------------------------------------------------------------------- =% + +:buildcmdline cmdlinevar paramvar wrapA wrapB + %= quoting for cmd.exe /c pwsh -nop !args! =% + @SETLOCAL EnableDelayedExpansion + + @REM @echo ===================== + set "pval=!%~2:*#=!" + set "pval=!pval:~0,-2!" + @REM set "pval=!pval:~0,-1!" + set "wrapa=%~3" + set "wrapb=%~4" + + @call :strlen pval slen + @rem @echo strlen: !slen! + if "!slen!"=="0" ( + goto :eof + ) + @set /A n = !slen! - 1 + @(set str=) + @set "dq="" + @set "bang=^!" + @(set carat=^^) + @for /l %%i in (0,1,!n!) do @( + (set c=!pval:~%%i,1!) + if "!c!"=="|" ( + set "ch=^^!pval:~%%i,1!" + ) ELSE IF "!c!"=="(" ( + set "ch=^(" + ) ELSE if "!c!"==")" ( + set "ch=^)" + ) ELSE if "!c!"=="&" ( + set "ch=^^&" + ) ELSE if "!c!"=="!dq!" ( + set "ch=^"" + ) ELSE if "!c!"=="!bang!" ( + @rem - double caret - first for initial parsing, second to ensure remains escaped during delayed expansion phase + @rem - REVIEW + set "ch=^^!bang!" + ) ELSE if "!c!"=="^carat" ( + set "ch=^^^^" + ) ELSE if "!c!"=="'" ( + set "ch=''" + ) ELSE ( + set "ch=!c!" + ) + @rem @echo - !ch! + set "str=!str!!ch!" + ) + echo +++++ %~1 = !%1! !str! + + set "%~1=!%1! !wrapa!!str!!wrapb!" + + @rem old method of return - failes to preserve exclamation marks + @rem for /f "delims=" %%A in (""!str!"") do endlocal & set "%~1=!%1! '%%~A'" + @rem macro method of endlocal return - preserving !val! + @echo off + %endlocal% %~1 + + @exit /b + +:rem_output + @rem --------------------------------------------- + @rem rem_output is called for each n in the number of args we process - as we don't have a non-destructive way to count args whilst accepting special chars + @rem we therefore need a way to stop processing on the last received arg so we don't write argCount entries to param.txt if less are received + @rem see 'disappearing quotes' technique + @rem https://stackoverflow.com/questions/4643376/how-to-split-double-quoted-line-into-multiple-lines-in-windows-batch-file/4645113#4645113 + @rem and + @rem https://groups.google.com/g/alt.msdos.batch.nt/c/J71F17Bve9Y (sponge belly) + @echo off + setlocal enableextensions disabledelayedexpansion + set "param1=%~2" + rem do must not be indented + for %%^" in ("") ^ +do if not defined param1 set %%~"param1=%2%%~" + if not defined param1 goto :eof + endlocal + @rem --------------------------------------------- + + @PROMPT @ + @echo on + rem %1 #%2# +@exit /b + +@REM courtesy of: https://stackoverflow.com/users/463115/jeb +:strlen stringVar returnVar +@( + setlocal EnableDelayedExpansion + @SET "rtrn=%~2" + (set^ tmp=!%~1!) + @rem @echo jjjjj !tmp! + @if defined tmp ( + set "len=1" + @for %%P in (4096 2048 1024 512 256 128 64 32 16 8 4 2 1) do @( + @if "!tmp:~%%P,1!" NEQ "" ( + set /a "len+=%%P" + set "tmp=!tmp:~%%P!" + ) + ) + ) ELSE ( + set len=0 + ) +) +@( + endlocal + @IF "%~2" neq "" ( + @SET "%rtrn%=%len%" + ) ELSE ( + @ECHO :strlen result: %len% + ) + exit /b +) + + +: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 + +@REM boundary padding +@REM boundary padding +@REM boundary padding +: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' +@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 + +@REM boundary padding +@REM boundary padding +@REM boundary padding + +: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 strvar returnvar +@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 +@REM boundary padding +@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 ./scriptname.cmd in sh or zsh or bash +# -- e.g tclsh scriptname.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 '@ +#--------------------------------------------------------------------- +#divert to configured nextshell +package require platform +set plat_full [platform::generic] +set plat [lindex [split $plat_full -] 0] +#may be old tcl - not assuming readFile available +set fd [open [info script] r] +set scriptdata [read $fd] +close $fd +set scriptdata [string map [list \r\n \n] $scriptdata] +set in_data 0 +set nextshellpath "" +set nextshelltype "" +puts stderr "PLAT: $plat" +foreach ln [split $scriptdata \n] { + if {[string trim $ln] eq ""} {continue} + if {!$in_data} { + if {[string match ": <>*" $ln]} { + set in_data 1 + } + } else { + if {[string match "*@SET*nextshellpath?${plat}_*" $ln]} { + set lineparts [split $ln =] + set tail [lindex $lineparts 1] + set nextshellpath [string trimright $tail {_"}] + if {$nextshellpath ne "" && $nextshelltype ne ""} { + break + } + } elseif {[string match "*@SET*nextshelltype?${plat}_*" $ln]} { + set lineparts [split $ln =] + set tail [lindex $lineparts 1] + set nextshelltype [string trimright $tail {_"}] + if {$nextshellpath ne "" && $nextshelltype ne ""} { + break + } + } elseif {[string match ": <>*" $ln]} { + break + } + } +} +if {$nextshelltype ne "tcl" && $nextshelltype ne "none"} { + if {$nextshelltype in "pwsh powershell"} { + set scrname [file rootname [info script]].ps1 + set arglist [list] + foreach a $::argv { + set a "'$a'" + lappend arglist $a + } + } else { + set scrname [info script] + set arglist $::argv + } + puts stdout "tclsh launching subshell of type: $nextshelltype shellpath: $nextshellpath on script $scrname with args: $arglist" + #todo - handle /usr/bin/env + #todo - exitcode + if {[llength $nextshellpath] == 1 && [string index $nextshellpath 0] eq {"} && [string index $nextshellpath end] eq {"}} { + set nextshell_words [list $nextshellpath] + } else { + set nextshell_words $nextshellpath + } + set ns_firstword [lindex $nextshellpath 0] + if {[string index $ns_firstword 0] eq {"} && [string index $ns_firstword end] eq {"}} { + set ns_firstword [string range $ns_firstword 1 end-1] + } + + if {[string match {/*/env} $ns_firstword] && $::tcl_platform(platform) ne "windows"} { + set exec_part $nextshellpath + } else { + set epath [auto_execok $ns_firstword] + if {$epath eq ""} { + error "unable to find executable path for first word '$ns_firstword' of nextshellpath '$nextshellpath'" + } else { + set exec_part [list {*}$epath {*}[lrange $nextshellpath 1 end]] + } + } + catch {exec {*}$exec_part $scrname {*}$arglist <@stdin >@stdout 2>@stderr} emsg eopts + + if {[dict exists $eopts -errorcode]} { + set ecode [dict get $eopts -errorcode] + if {[lindex $ecode 0] eq "CHILDSTATUS"} { + exit [lindex $ecode 2] + } else { + puts stderr "error calling next shell $nextshelltype :" + puts stderr $emsg + exit 1 + } + } else { + exit 0 + } +} +#--------------------------------------------------------------------- + +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" +# -- --- --- --- --- --- --- --- --- --- --- --- + +# +puts stdout "::argc" +puts stdout $::argc +puts stdout "::argv" +puts stdout "$::argv" +puts stdout ----------------------- +foreach a $::argv { + puts stdout $a +} +puts stdout -done- +# + +# +# + +# +# + + +# +# + + +# -- --- --- --- --- --- --- --- --- --- --- --- +# -- 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 +# Be wary of any non-trivial sed/awk etc - can be brittle to maintain across linux,freebsd,macosx due to differing implementations \ +echo "var0: $0 @: $@" +# echo "script: `echo $0 | sed 's/^-//'`" +# use oldschool backticks and sed - lowest common denominator \ +# echo "shell: " `ps -p $$ | awk '$1 != "PID" {print $(NF)}' | tr -d '()' | sed -E 's/^.*\/|^-//'` +# zsh diversion \ +# if [[ "$argv[*]" != "[*]" ]]; then /usr/bin/env bash "$0" "${argv[@]:2:$((${#argv[@]}-2))}"; exit $?; fi +# \ +ps_shellname=`ps -p $$ | awk '$1 != "PID" {print $(NF)}' | tr -d '()' | sed -E 's/^.*\/|^-//'` +# \ +echo "shell from ps: $ps_shellname argc: ${#@} inner: ${@:2:$((${#@}-2))}" +# non-bash-like diversion \ +if [[ "$ps_shellname" != "bash" && "$ps_shellname" != "zsh" ]]; then /usr/bin/env bash "$0" "${@:2:$((${#@}-2))}"; exit $?; fi +# sh/bash (or zsh?) \ +shift && set -- "${@:1:$((${#@}-1))}" +# \ +#echo "shell:" `ps -o args= $$ | sed -E 's/^.*\/|^-//' | awk '{print $1}'` +# \ +echo "args: $@" +# ------------------------------------------------------ +# -- 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. +# -- +# ## ### ### ### ### ### ### ### ### ### ### ### ### ### + +plat=$(uname -s) #platform/system +if [[ "$plat" = "Linux"* ]]; then + os="linux" +elif [[ "$plat" == "Darwin"* ]]; then + os="macosx" +elif [[ "$plat" == "FreeBSD"* ]]; then + os="freebsd" +elif [[ "$plat" == "DragonFly"* ]]; then + os="dragonflybsd" +elif [[ "$plat" == "NetBSD"* ]]; then + os="netbsd" +elif [[ "$plat" == "OpenBSD"* ]]; then + os="openbsd" +elif [[ "$plat" = "MINGW32"* ]]; then + os="win32" +elif [[ "$plat" = "MINGW64"* ]]; then + os="win32" +elif [[ "$plat" = "CYGWIN_NT"* ]]; then + os="win32" +elif [[ "$plat" == "MSYS_NT"* ]]; then + #review.. + echo MSYS + #win32 binaries - but e.g tclsh installed in msys reports ::tcl_platform(platform) as 'unix' + #bash reports $OSTYPE 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}}" +elif [[ "$OSTYPE" == "win32" ]]; then + os="win32" +else + #os="$OSTYPE" + os="other" +fi +echo ostype: $OSTYPE +## This is the sort of sed that will not work across implementations +## shellconfiglines=$( sed -n "/: <>/{:a;n;/: <>/q;p;ba}" "$0" | grep $os) +#awk tested on linux & freebsd +shellconfiglines=$( awk '/^:.*<>.*$/,/^:.*<>.*$/' "$0" | grep $os) +# echo $shellconfiglines; +# readarray requires bash 4.0 +if [[ "$ps_shellname" == "bash" ]]; then + readarray -t arr_oslines <<<"$shellconfiglines" +elif [[ "$ps_shellname" == "zsh" ]]; then + arr_oslines=("${(f)shellconfiglines}") +else + #fallback - doesn't seem to work in zsh - untested in early bash + IFS=$'\n' arr_oslines=($shellconfiglines) +fi +nextshellpath="" +nextshelltype="" +for ln in "${arr_oslines[@]}"; do + # echo "---- $ln" + if [[ "$ln" == *"nextshellpath"* ]]; then + splitln="${ln#*=}" #remove everything through the first '=' + pathraw="${splitln%%\"*}" #take everything before the quote - use %% to get longest match + #remove trailing underscores (% means must match at end) + nextshellpath="${pathraw/%_*/}" + echo "nextshellpath: $nextshellpath" + elif [[ "$ln" == *"nextshelltype"* ]]; then + splitln="${ln#*=}" + typeraw="${splitln%%\"*}" + nextshelltype="${typeraw/%_*/}" + echo "nextshelltype: $nextshelltype" + fi +done + +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 shellpath: $nextshellpath on "$0" with args "$@" + #e.g /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" + +# +echo "No bash code for this script. Try another program such as perl or tcl" >&2 +# + +# +# + +# -- --- --- --- --- --- --- --- +# +#-- 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 + } +} +# Example usage: +# 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, +# [Parameter(ValueFromRemainingArguments)] $opts +# ) +#} +#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) { +# 'myargument' { +# Set-Variable -Name $_ -Value $PSBoundParameters."$_" +# } +# 'opts' { +# write-warning "Unused parameters: $($PSBoundParameters.$_)" +# } +# Default { +# write-warning "Unhandled parameter -> [$($_)]" +# } +# } +# foreach ($boundparam in $PSBoundParameters.GetEnumerator()) { +# #... +# } +# } +# end { +# #Main function logic +# Write-Host "myargument value is: $myargument" +# #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 +# -- --- --- --- +$thisfileContent = Get-Content $scriptname -Raw +$startTag = ": <>" +$endTag = ": <>" +$pattern = "(?s)`n$startTag[^`n]*`n(.*?)`n$endTag" +$match = [regex]::Match($thisfileContent,$pattern) +$asadmin = 0 +if ($match.Success) { + $admininfo = $match.Groups[1].Value + $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 + } + } +} +# +$startTag = ": <>" +$endTag = ": <>" +$pattern = "(?s)`n$startTag[^`n]*`n(.*?)`n$endTag" +$match = [regex]::Matches($thisfileContent,$pattern) +if ($match.Success) { + $plat = [System.Environment]::OSVersion.Platform + if ($plat = "Unix") { + $runtime_ident = [System.Runtime.InteropServices.RuntimeInformation]::RuntimeIdentifier + switch ($runtime_ident.split("-")[0]) { + "freebsd" { + # untested + $os = "freebsd" + } + "linux" { + $os = "linux" + } + "osx" { + # osx-x64 or osx-arm64 ? + $os = "macosx" + } + default { + #openbsd, netbsd ? + $os = "other" + } + } + } else { + $os = "win32" + } + + $matchedlines = $match.Groups[1].Value + $nextshell_type = "" + $nextshell_path = "" + ForEach ($line in $($matchedlines -split "\r?\n")) { + $m = [regex]::Match($line,".*nextshelltype\[${os}[_]+\]=([^_]*)[_]*") + if ($m.Success) { + $nextshell_type = $m.Groups[1].Value + } + $m = [regex]::Match($line,".*nextshellpath\[${os}[_]+\]=([^_]*)[_]*") + if ($m.Success) { + $nextshell_path = $m.Groups[1].Value + } + if ($nextshell_type -ne "" -and $nextshell_path -ne "") { + break + } + } + if (-not (("pwsh", "powershell") -contains $nextshell_type)) { + #nextshell diversion exists for this platform + write-host "pwsh/powershell launching subshell of type: $nextshell_type shellpath: $nextshell_path on script $scriptname" + + # $arguments = @($($MyInvocation.MyCommand.Path)) + # $arguments += $args + # $process = (Start-Process -FilePath $nextshell_path -ArgumentList $arguments -NoNewWindow -Wait) + # Exit $process.ExitCode + + & $nextshell_path $scriptname $args + exit $LASTEXITCODE + } +} + +# -- --- --- --- --- --- --- --- --- --- --- --- --- ---begin powershell Payload + +# +Write-Error "No powershell code for this script. Try another program such as tcl or bash`n" +"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/getpunk.cmd b/getpunk.cmd index 074ab0ea..e1bc3be5 100644 --- a/getpunk.cmd +++ b/getpunk.cmd @@ -1,4 +1,4 @@ -: "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^ +: "punk MULTISHELL - shebangless polyglot for Tcl Perl sh bash cmd pwsh powershell" + "[rename set S;proc Hide shell_not_supported {proc $shell_not_supported 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 + \ @@ -16,6 +16,70 @@ set -- "$@" "a=[Hide <#;Hide set;S 1 list]"; set -- : "$@";$1 = @' @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 ------------------------------------------------------------------------------------------------------------------------------- +@rem return from endlocal macro - courtesy of jeb +@rem This allows return of values containing special characters from subroutines +@rem https://stackoverflow.com/questions/3262287/make-an-environment-variable-survive-endlocal/8257951#8257951 +@rem ------------------------------------------------------------------------------------------------------------------------------- +@setlocal DisableDelayedExpansion +@echo off +%= 2 blank lines after next are required =% +set LF=^ + + +set ^"\n=^^^%LF%%LF%^%LF%%LF%^^" +%= I use EDE for EnableDelayeExpansion and DDE for DisableDelayedExpansion =% +set ^"endlocal=for %%# in (1 2) do if %%#==2 (%\n% + setlocal EnableDelayedExpansion%\n% + %= Take all variable names into the varName array =%%\n% + set varName_count=0%\n% + for %%C in (!args!) do set "varName[!varName_count!]=%%~C" ^& set /a varName_count+=1%\n% + %= Build one variable with a list of set statements for each variable delimited by newlines =%%\n% + %= The lists looks like --> set result1=myContent\n"set result1=myContent1"\nset result2=content2\nset result2=content2\n =%%\n% + %= Each result exists two times, the first for the case returning to DDE, the second for EDE =%%\n% + %= The correct line will be detected by the (missing) enclosing quotes =%%\n% + set "retContent=1!LF!"%\n% + for /L %%n in (0 1 !varName_count!) do (%\n% + for /F "delims=" %%C in ("!varName[%%n]!") DO (%\n% + set "content=!%%C!"%\n% + set "retContent=!retContent!"set !varName[%%n]!=!content!"!LF!"%\n% + if defined content (%\n% + %= This complex block is only for replacing '!' with '^!' =%%\n% + %= First replacing '"'->'""q' '^'->'^^' =%%\n% + set ^"content_EDE=!content:"=""q!"%\n% + set "content_EDE=!content_EDE:^=^^!"%\n% + %= Now it's poosible to use CALL SET and replace '!'->'""e!' =%%\n% + call set "content_EDE=%%content_EDE:^!=""e^!%%"%\n% + %= Now it's possible to replace '""e' to '^', this is effectivly '!' -> '^!' =%%\n% + set "content_EDE=!content_EDE:""e=^!"%\n% + %= Now restore the quotes =%%\n% + set ^"content_EDE=!content_EDE:""q="!"%\n% + ) ELSE set "content_EDE="%\n% + set "retContent=!retContent!set "!varName[%%n]!=!content_EDE!"!LF!"%\n% + )%\n% + )%\n% + %= Now return all variables from retContent over the barrier =%%\n% + for /F "delims=" %%V in ("!retContent!") DO (%\n% + %= Only the first line can contain a single 1 =%%\n% + if "%%V"=="1" (%\n% + %= We need to call endlocal twice, as there is one more setlocal in the macro itself =%%\n% + endlocal%\n% + endlocal%\n% + ) ELSE (%\n% + %= This is true in EDE =%%\n% + if "!"=="" (%\n% + if %%V==%%~V (%\n% + %%V !%\n% + )%\n% + ) ELSE IF not %%V==%%~V (%\n% + %%~V%\n% + )%\n% + )%\n% + )%\n% + ) else set args=" + +@rem ------------------------------------------------------------------------------------------------------------------------------- +@SETLOCAL EnableExtensions EnableDelayedExpansion @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 @@ -24,7 +88,6 @@ set -- "$@" "a=[Hide <#;Hide set;S 1 list]"; set -- : "$@";$1 = @' @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 @@ -32,7 +95,7 @@ set -- "$@" "a=[Hide <#;Hide set;S 1 list]"; set -- : "$@";$1 = @' @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 "nextshellpath[win32___________]=powershell -nop -nol -ExecutionPolicy ByPass -File______________" @SET "nextshelltype[win32___________]=powershell______" @SET "nextshellpath[dragonflybsd____]=/usr/bin/env bash_______________________________________________" @SET "nextshelltype[dragonflybsd____]=bash____________" @@ -51,8 +114,6 @@ set -- "$@" "a=[Hide <#;Hide set;S 1 list]"; set -- : "$@";$1 = @' : <> @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 @@ -73,7 +134,7 @@ set -- "$@" "a=[Hide <#;Hide set;S 1 list]"; set -- : "$@";$1 = @' @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 -- deck scriptwrap.checkfile filepath @REM -- to check your templates or final wrapped scripts for byte boundary issues @REM -- It will report any labels that are on boundaries @REM -- This is why the nextshell value above is a 2 digit key instead of a string - so that editing the value doesn't change the byte offsets. @@ -83,12 +144,13 @@ set -- "$@" "a=[Hide <#;Hide set;S 1 list]"; set -- : "$@";$1 = @' @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 -- 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 "winpath=%~dp0" %= e.g c:\punkshell\bin\ %= @SET "fname=%~nx0" +@SET "scriptrootname=%~dp0%~n0" %= e.g c:\punkshell\bin\runtime (full path without extension) unavailable after shift, so store it =% @REM @ECHO fname %fname% @REM @ECHO winpath %winpath% @REM @ECHO commandlineascalled %0 @@ -123,17 +185,6 @@ set -- "$@" "a=[Hide <#;Hide set;S 1 list]"; set -- : "$@";$1 = @' @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 ) @@ -178,6 +229,77 @@ set -- "$@" "a=[Hide <#;Hide set;S 1 list]"; set -- : "$@";$1 = @' @IF "!selected_shelltype_trimmed!"=="none" ( SET selected_shelltype_trimmed=pwsh ) + + + + +@set argCount=30 +@rem This is the max number of args we are willing to handle. also bounded by approx 8k char limit of cmd.exe +@rem We do not loop over %* to count args as it is brittle for some inputs e.g will always skip cmd.exe separators e.g comma and semicolon +@rem Set argCount higher if desired, but there is a small amount of additional looping overhead. + +@set tmpfile_base=%TEMP%\punkbatch_params +@call :getUniqueFile %tmpfile_base% ".txt" paramfile +@echo %paramfile% + +%= NOTE when we loop like this using the percent-n args, we lose unquoted separators such as comma and semicolon %= +@rem https://stackoverflow.com/questions/26551/how-can-i-pass-arguments-to-a-batch-file/5493124#5493124 +@rem outer loop required to redirect all rem lines at once to file +@for %%x in (1) do @( + @for /L %%f in (1,1,%argCount%) do @( + @set "argnum=%%~nf" + @set "a1=%%1" + @rem @set "argname=%%!argnum!" + @rem @echo argname: !argname! + @call :rem_output !argnum! !a1! + @shift + ) +) > %paramfile% +@echo off + +@set "newcommandline= " + +@(set target=cmd_pwsh) +@if "%target%"=="cmd_pwsh" ( + @for /F "delims=" %%L in (%paramfile%) do @( + SETLOCAL DisableDelayedExpansion + set "param=%%L" + @REM @echo ######### %%L + @rem call :buildcmdline newcommandline param "{" "}" + call :buildcmdline newcommandline param ' ' %= cmd.exe /c powershell %= + @rem @echo . + ) +) ELSE ( + @for /F "delims=" %%L in (%paramfile%) do @( + SETLOCAL DisableDelayedExpansion + set "param=%%L" + call :buildcmdline newcommandline param + ) +) +@REM padding +SETLOCAL EnableDelayedExpansion + +@echo off +@IF EXIST %paramfile% ( + @DEL /F /Q %paramfile% +) +@IF EXIST %paramfile% ( + echo failed to delete %paramfile% + cat %paramfile% +) + + + +@REM @SET "squoted_args=" +@REM @for %%a in (%*) do @( +@REM set "v=%%a" +@REM set "v=!v:'=''!" +@REM SET "squoted_args=!squoted_args!'!v!' " +@REM ) +@REM @SET "squoted_args=%squoted_args:~0,-1%" +@REM @ECHO %squoted_args% + + @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 @@ -186,17 +308,20 @@ set -- "$@" "a=[Hide <#;Hide set;S 1 list]"; set -- : "$@";$1 = @' 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% + @rem pwsh -nop -nol -c set-executionpolicy -Scope Process Unrestricted; "%scriptrootname%.ps1" %arglist% + @rem pwsh -nop -nol -c set-executionpolicy -Scope Process Unrestricted + cmd /c pwsh -nop -nol -ExecutionPolicy bypass -c "%scriptrootname%.ps1" !newcommandline! 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% + @rem powershell -nop -nol -ExecutionPolicy Bypass -c "%scriptrootname%.ps1" %arglist% + cmd /c powershell -nop -nol -ExecutionPolicy Bypass -c "%scriptrootname%.ps1" !newcommandline! SET task_exitcode=!errorlevel! ) ) ELSE ( IF "!selected_shelltype_trimmed!"=="powershell" ( - powershell -nop -nol -ExecutionPolicy Bypass -c "%~dp0%~n0.ps1" %arglist% + @rem powershell -nop -nol -ExecutionPolicy Bypass -c "%scriptrootname%.ps1" %arglist% + cmd /c powershell -nop -nol -ExecutionPolicy Bypass -c "%scriptrootname%.ps1" !newcommandline! SET task_exitcode=!errorlevel! ) ELSE ( IF "!selected_shelltype_trimmed!"=="wslbash" ( @@ -211,7 +336,7 @@ set -- "$@" "a=[Hide <#;Hide set;S 1 list]"; set -- : "$@";$1 = @' 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; + %selected_shellpath_trimmed% "%winpath%%fname%" %arglist% & SET task_exitcode=!errorlevel! & Call; ) ELSE ( ECHO %fname% has invalid nextshelltype value %selected_shelltype% valid options are %validshelltypes% SET task_exitcode=66 @@ -222,9 +347,144 @@ set -- "$@" "a=[Hide <#;Hide set;S 1 list]"; set -- : "$@";$1 = @' ) ) @REM batch file library functions -@REM boundary padding + @GOTO :endlib +@REM padding +@REM padding +@REM padding + +%= ---------------------------------------------------------------------- =% +@rem courtesy of dbenham +:: Example usage +@rem call :getUniqueFile "d:\test\myFile" ".txt" myFile +@rem echo myFile="%myFile%" + +:getUniqueFile baseName extension rtnVar +setlocal +:getUniqueFileLoop +for /f "skip=1" %%A in ('wmic os get localDateTime') do for %%B in (%%A) do set "rtn=%~1_%%B%~2" +if exist "%rtn%" ( + goto :getUniqueFileLoop +) else ( + 2>nul >nul (9>"%rtn%" timeout /nobreak 1) || goto :getUniqueFileLoop +) +endlocal & set "%~3=%rtn%" +exit /b +%= ---------------------------------------------------------------------- =% + +:buildcmdline cmdlinevar paramvar wrapA wrapB + %= quoting for cmd.exe /c pwsh -nop !args! =% + @SETLOCAL EnableDelayedExpansion + + @REM @echo ===================== + set "pval=!%~2:*#=!" + set "pval=!pval:~0,-2!" + @REM set "pval=!pval:~0,-1!" + set "wrapa=%~3" + set "wrapb=%~4" + + @call :strlen pval slen + @rem @echo strlen: !slen! + if "!slen!"=="0" ( + goto :eof + ) + @set /A n = !slen! - 1 + @(set str=) + @set "dq="" + @set "bang=^!" + @(set carat=^^) + @for /l %%i in (0,1,!n!) do @( + (set c=!pval:~%%i,1!) + if "!c!"=="|" ( + set "ch=^^!pval:~%%i,1!" + ) ELSE IF "!c!"=="(" ( + set "ch=^(" + ) ELSE if "!c!"==")" ( + set "ch=^)" + ) ELSE if "!c!"=="&" ( + set "ch=^^&" + ) ELSE if "!c!"=="!dq!" ( + set "ch=^"" + ) ELSE if "!c!"=="!bang!" ( + @rem - double caret - first for initial parsing, second to ensure remains escaped during delayed expansion phase + @rem - REVIEW + set "ch=^^!bang!" + ) ELSE if "!c!"=="^carat" ( + set "ch=^^^^" + ) ELSE if "!c!"=="'" ( + set "ch=''" + ) ELSE ( + set "ch=!c!" + ) + @rem @echo - !ch! + set "str=!str!!ch!" + ) + echo +++++ %~1 = !%1! !str! + + set "%~1=!%1! !wrapa!!str!!wrapb!" + + @rem old method of return - failes to preserve exclamation marks + @rem for /f "delims=" %%A in (""!str!"") do endlocal & set "%~1=!%1! '%%~A'" + @rem macro method of endlocal return - preserving !val! + @echo off + %endlocal% %~1 + + @exit /b + +:rem_output + @rem --------------------------------------------- + @rem rem_output is called for each n in the number of args we process - as we don't have a non-destructive way to count args whilst accepting special chars + @rem we therefore need a way to stop processing on the last received arg so we don't write argCount entries to param.txt if less are received + @rem see 'disappearing quotes' technique + @rem https://stackoverflow.com/questions/4643376/how-to-split-double-quoted-line-into-multiple-lines-in-windows-batch-file/4645113#4645113 + @rem and + @rem https://groups.google.com/g/alt.msdos.batch.nt/c/J71F17Bve9Y (sponge belly) + @echo off + setlocal enableextensions disabledelayedexpansion + set "param1=%~2" + rem do must not be indented + for %%^" in ("") ^ +do if not defined param1 set %%~"param1=%2%%~" + if not defined param1 goto :eof + endlocal + @rem --------------------------------------------- + + @PROMPT @ + @echo on + rem %1 #%2# +@exit /b + +@REM courtesy of: https://stackoverflow.com/users/463115/jeb +:strlen stringVar returnVar +@( + setlocal EnableDelayedExpansion + @SET "rtrn=%~2" + (set^ tmp=!%~1!) + @rem @echo jjjjj !tmp! + @if defined tmp ( + set "len=1" + @for %%P in (4096 2048 1024 512 256 128 64 32 16 8 4 2 1) do @( + @if "!tmp:~%%P,1!" NEQ "" ( + set /a "len+=%%P" + set "tmp=!tmp:~%%P!" + ) + ) + ) ELSE ( + set len=0 + ) +) +@( + endlocal + @IF "%~2" neq "" ( + @SET "%rtrn%=%len%" + ) ELSE ( + @ECHO :strlen result: %len% + ) + exit /b +) + + :getWslPath @SETLOCAL @SET "_path=%~p1" @@ -280,7 +540,7 @@ set -- "$@" "a=[Hide <#;Hide set;S 1 list]"; set -- : "$@";$1 = @' ) ) @EXIT /B -@REM boundary padding +@REM boundary padding @REM boundary padding :getNormalizedScriptTail @SETLOCAL @@ -295,13 +555,12 @@ set -- "$@" "a=[Hide <#;Hide set;S 1 list]"; set -- : "$@";$1 = @' ) @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 +: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' @SETLOCAL @CALL :stringContains %~1 "\" hasBackSlash @CALL :stringContains %~1 "/" hasForwardSlash @@ -327,6 +586,10 @@ set -- "$@" "a=[Hide <#;Hide set;S 1 list]"; set -- : "$@";$1 = @' ) @EXIT /B +@REM boundary padding +@REM boundary padding +@REM boundary padding + :stringContains @REM usage: @CALL:stringContains string needle returnvarname @SETLOCAL @@ -348,7 +611,7 @@ set -- "$@" "a=[Hide <#;Hide set;S 1 list]"; set -- : "$@";$1 = @' @EXIT /B @REM boundary padding @REM boundary padding -:stringToUpper +:stringToUpper strvar returnvar @SETLOCAL @SET "rtrn=%~2" @SET "string=%~1" @@ -384,6 +647,9 @@ set -- "$@" "a=[Hide <#;Hide set;S 1 list]"; set -- : "$@";$1 = @' @EXIT /B @REM boundary padding @REM boundary padding +@REM boundary padding +@REM boundary padding +@REM boundary padding :stringTrimTrailingUnderscores @SETLOCAL @SET "rtrn=%~2" @@ -442,12 +708,104 @@ set -- "$@" "a=[Hide <#;Hide set;S 1 list]"; set -- : "$@";$1 = @' # -- 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 +# -- e.g ./scriptname.cmd in sh or zsh or bash +# -- e.g tclsh scriptname.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 '@ +#--------------------------------------------------------------------- +#divert to configured nextshell +package require platform +set plat_full [platform::generic] +set plat [lindex [split $plat_full -] 0] +#may be old tcl - not assuming readFile available +set fd [open [info script] r] +set scriptdata [read $fd] +close $fd +set scriptdata [string map [list \r\n \n] $scriptdata] +set in_data 0 +set nextshellpath "" +set nextshelltype "" +puts stderr "PLAT: $plat" +foreach ln [split $scriptdata \n] { + if {[string trim $ln] eq ""} {continue} + if {!$in_data} { + if {[string match ": <>*" $ln]} { + set in_data 1 + } + } else { + if {[string match "*@SET*nextshellpath?${plat}_*" $ln]} { + set lineparts [split $ln =] + set tail [lindex $lineparts 1] + set nextshellpath [string trimright $tail {_"}] + if {$nextshellpath ne "" && $nextshelltype ne ""} { + break + } + } elseif {[string match "*@SET*nextshelltype?${plat}_*" $ln]} { + set lineparts [split $ln =] + set tail [lindex $lineparts 1] + set nextshelltype [string trimright $tail {_"}] + if {$nextshellpath ne "" && $nextshelltype ne ""} { + break + } + } elseif {[string match ": <>*" $ln]} { + break + } + } +} +if {$nextshelltype ne "tcl" && $nextshelltype ne "none"} { + if {$nextshelltype in "pwsh powershell"} { + set scrname [file rootname [info script]].ps1 + set arglist [list] + foreach a $::argv { + set a "'$a'" + lappend arglist $a + } + } else { + set scrname [info script] + set arglist $::argv + } + puts stdout "tclsh launching subshell of type: $nextshelltype shellpath: $nextshellpath on script $scrname with args: $arglist" + #todo - handle /usr/bin/env + #todo - exitcode + if {[llength $nextshellpath] == 1 && [string index $nextshellpath 0] eq {"} && [string index $nextshellpath end] eq {"}} { + set nextshell_words [list $nextshellpath] + } else { + set nextshell_words $nextshellpath + } + set ns_firstword [lindex $nextshellpath 0] + if {[string index $ns_firstword 0] eq {"} && [string index $ns_firstword end] eq {"}} { + set ns_firstword [string range $ns_firstword 1 end-1] + } + + if {[string match {/*/env} $ns_firstword] && $::tcl_platform(platform) ne "windows"} { + set exec_part $nextshellpath + } else { + set epath [auto_execok $ns_firstword] + if {$epath eq ""} { + error "unable to find executable path for first word '$ns_firstword' of nextshellpath '$nextshellpath'" + } else { + set exec_part [list {*}$epath {*}[lrange $nextshellpath 1 end]] + } + } + catch {exec {*}$exec_part $scrname {*}$arglist <@stdin >@stdout 2>@stderr} emsg eopts + + if {[dict exists $eopts -errorcode]} { + set ecode [dict get $eopts -errorcode] + if {[lindex $ecode 0] eq "CHILDSTATUS"} { + exit [lindex $ecode 2] + } else { + puts stderr "error calling next shell $nextshelltype :" + puts stderr $emsg + exit 1 + } + } else { + exit 0 + } +} +#--------------------------------------------------------------------- + namespace eval ::punk::multishell { set last_script_root [file dirname [file normalize ${::argv0}/__]] set last_script [file dirname [file normalize [info script]/__]] @@ -481,7 +839,7 @@ namespace eval ::punk::multishell { # -- --- --- --- --- --- --- --- --- --- --- --- # -puts stderr "No tcl code for this script. Try another program such as perl or bash" +puts stderr "No tcl code for this script. Try another program such as zsh or bash or perl" # # @@ -512,21 +870,26 @@ if {[::punk::multishell::is_main]} { # -- --- --- --- --- --- --- --- --- --- --- --- --- ---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}" - +# Be wary of any non-trivial sed/awk etc - can be brittle to maintain across linux,freebsd,macosx due to differing implementations \ +echo "var0: $0 @: $@" +# echo "script: `echo $0 | sed 's/^-//'`" +# use oldschool backticks and sed - lowest common denominator \ +# echo "shell: " `ps -p $$ | awk '$1 != "PID" {print $(NF)}' | tr -d '()' | sed -E 's/^.*\/|^-//'` +# zsh diversion \ +# if [[ "$argv[*]" != "[*]" ]]; then /usr/bin/env bash "$0" "${argv[@]:2:$((${#argv[@]}-2))}"; exit $?; fi +# \ +ps_shellname=`ps -p $$ | awk '$1 != "PID" {print $(NF)}' | tr -d '()' | sed -E 's/^.*\/|^-//'` +# \ +echo "shell from ps: $ps_shellname argc: ${#@} inner: ${@:2:$((${#@}-2))}" +# non-bash-like diversion \ +if [[ "$ps_shellname" != "bash" && "$ps_shellname" != "zsh" ]]; then /usr/bin/env bash "$0" "${@:2:$((${#@}-2))}"; exit $?; fi +# sh/bash (or zsh?) \ +shift && set -- "${@:1:$((${#@}-1))}" +# \ #echo "shell:" `ps -o args= $$ | sed -E 's/^.*\/|^-//' | awk '{print $1}'` -#------------------------------------------------------ +# \ +echo "args: $@" +# ------------------------------------------------------ # -- This if block only needed if Tcl didn't exit or return above. if false==false # else { then @@ -541,20 +904,30 @@ if false==false # else { # -- # ## ### ### ### ### ### ### ### ### ### ### ### ### ### -if [[ "$OSTYPE" == "linux"* ]]; then +plat=$(uname -s) #platform/system +if [[ "$plat" = "Linux"* ]]; then os="linux" -elif [[ "$OSTYPE" == "darwin"* ]]; then +elif [[ "$plat" == "Darwin"* ]]; then os="macosx" -elif [[ "$OSTYPE" == "freebsd"* ]]; then +elif [[ "$plat" == "FreeBSD"* ]]; then os="freebsd" -elif [[ "$OSTYPE" == "dragonflybsd"* ]]; then +elif [[ "$plat" == "DragonFly"* ]]; then os="dragonflybsd" -elif [[ "$OSTYPE" == "netbsd"* ]]; then +elif [[ "$plat" == "NetBSD"* ]]; then os="netbsd" -elif [[ "$OSTYPE" == "win32" ]]; then +elif [[ "$plat" == "OpenBSD"* ]]; then + os="openbsd" +elif [[ "$plat" = "MINGW32"* ]]; then + os="win32" +elif [[ "$plat" = "MINGW64"* ]]; then + os="win32" +elif [[ "$plat" = "CYGWIN_NT"* ]]; then os="win32" -elif [[ "$OSTYPE" == "msys" ]]; then +elif [[ "$plat" == "MSYS_NT"* ]]; then + #review.. echo MSYS + #win32 binaries - but e.g tclsh installed in msys reports ::tcl_platform(platform) as 'unix' + #bash reports $OSTYPE msys os="win32" #review - need ps/sed/awk to determine shell? interp = `ps -p $$ | awk '$1 != "PID" {print $(NF)}' | tr -d '()' | sed -E 's/^.*\/|^-//'` @@ -564,37 +937,50 @@ elif [[ "$OSTYPE" == "msys" ]]; then #"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}}" +elif [[ "$OSTYPE" == "win32" ]]; then + os="win32" 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" +## This is the sort of sed that will not work across implementations +## shellconfiglines=$( sed -n "/: <>/{:a;n;/: <>/q;p;ba}" "$0" | grep $os) +#awk tested on linux & freebsd +shellconfiglines=$( awk '/^:.*<>.*$/,/^:.*<>.*$/' "$0" | grep $os) +# echo $shellconfiglines; +# readarray requires bash 4.0 +if [[ "$ps_shellname" == "bash" ]]; then + readarray -t arr_oslines <<<"$shellconfiglines" +elif [[ "$ps_shellname" == "zsh" ]]; then + arr_oslines=("${(f)shellconfiglines}") else - echo "unable to find config for os $os" - echo "shellconfigline: $shellconfigline" - nextshellpath="" - nextshelltype="" + #fallback - doesn't seem to work in zsh - untested in early bash + IFS=$'\n' arr_oslines=($shellconfiglines) fi +nextshellpath="" +nextshelltype="" +for ln in "${arr_oslines[@]}"; do + # echo "---- $ln" + if [[ "$ln" == *"nextshellpath"* ]]; then + splitln="${ln#*=}" #remove everything through the first '=' + pathraw="${splitln%%\"*}" #take everything before the quote - use %% to get longest match + #remove trailing underscores (% means must match at end) + nextshellpath="${pathraw/%_*/}" + echo "nextshellpath: $nextshellpath" + elif [[ "$ln" == *"nextshelltype"* ]]; then + splitln="${ln#*=}" + typeraw="${splitln%%\"*}" + nextshelltype="${typeraw/%_*/}" + echo "nextshelltype: $nextshelltype" + fi +done + 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" "$@" + echo bash launching subshell of type: $nextshelltype shellpath: $nextshellpath on "$0" with args "$@" + #e.g /usr/bin/env tclsh "$0" "$@" ${nextshellpath} "$0" "$@" exitcode=$? @@ -842,12 +1228,14 @@ function GetDynamicParamDictionary { return $DynParamDictionary } } +# Example usage: # 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 +# [Parameter(Mandatory)][string] $myargument, +# [Parameter(ValueFromRemainingArguments)] $opts # ) #} #function psmain { @@ -858,10 +1246,15 @@ function GetDynamicParamDictionary { # #called once with $PSBoundParameters dictionary # #can be used to validate arguments, or set a simpler variable name for access # switch ($PSBoundParameters.keys) { -# 'myargumentname' { +# 'myargument' { # Set-Variable -Name $_ -Value $PSBoundParameters."$_" # } -# #... +# 'opts' { +# write-warning "Unused parameters: $($PSBoundParameters.$_)" +# } +# Default { +# write-warning "Unhandled parameter -> [$($_)]" +# } # } # foreach ($boundparam in $PSBoundParameters.GetEnumerator()) { # #... @@ -869,24 +1262,24 @@ function GetDynamicParamDictionary { # } # end { # #Main function logic -# Write-Host "myargumentname value is: $myargumentname" +# Write-Host "myargument value is: $myargument" # #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 +"Script Name : {0}" -f $scriptname | write-host +"Powershell Version: {0}" -f $PSVersionTable.PSVersion.Major | write-host +"powershell args : {0}" -f ($args -join ", ") | write-host # -- --- --- --- +$thisfileContent = Get-Content $scriptname -Raw $startTag = ": <>" $endTag = ": <>" -$fileContent = Get-Content $scriptname -Raw -$pattern = "(?s)$startTag(.*?)$endTag" -$matches = [regex]::Matches($fileContent,$pattern) -$admininfo = $matches[0].Groups[1].Value +$pattern = "(?s)`n$startTag[^`n]*`n(.*?)`n$endTag" +$match = [regex]::Match($thisfileContent,$pattern) $asadmin = 0 -if ($matches.count) { +if ($match.Success) { + $admininfo = $match.Groups[1].Value $asadmin = $admininfo.Contains("asadmin=1") if ($asadmin) { if (-not ([Security.Principal.WindowsPrincipal][Security.Principal.WindowsIdentity]::GetCurrent()).IsInRole([Security.Principal.WindowsBuiltInRole]::Administrator)) { @@ -904,6 +1297,67 @@ if ($matches.count) { } } } +# +$startTag = ": <>" +$endTag = ": <>" +$pattern = "(?s)`n$startTag[^`n]*`n(.*?)`n$endTag" +$match = [regex]::Match($thisfileContent,$pattern) +if ($match.Success) { + $plat = [System.Environment]::OSVersion.Platform + if ($plat -eq "Unix") { + $runtime_ident = [System.Runtime.InteropServices.RuntimeInformation]::RuntimeIdentifier + switch ($runtime_ident.split("-")[0]) { + "freebsd" { + # untested + $os = "freebsd" + } + "linux" { + $os = "linux" + } + "osx" { + # osx-x64 or osx-arm64 ? + $os = "macosx" + } + default { + #openbsd, netbsd ? + $os = "other" + } + } + } else { + $os = "win32" + } + + $matchedlines = $match.Groups[1].Value + $nextshell_type = "" + $nextshell_path = "" + ForEach ($line in $($matchedlines -split "\r?\n")) { + $m = [regex]::Match($line,".*nextshelltype\[${os}[_]+\]=([^_]*)[_]*") + if ($m.Success) { + $nextshell_type = $m.Groups[1].Value + } + $m = [regex]::Match($line,".*nextshellpath\[${os}[_]+\]=([^_]*)[_]*") + if ($m.Success) { + $nextshell_path = $m.Groups[1].Value + } + if ($nextshell_type -ne "" -and $nextshell_path -ne "") { + break + } + } + 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" + + # $arguments = @($($MyInvocation.MyCommand.Path)) + # $arguments += $args + # NOTE - this gives incorrect argument quoting e.g wrong number of arguments received by launched process for arguments: a "b c" + # $process = (Start-Process -FilePath $nextshell_path -ArgumentList $arguments -NoNewWindow -Wait) + # Exit $process.ExitCode + + & $nextshell_path $scriptname $args + exit $LASTEXITCODE + } +} + # -- --- --- --- --- --- --- --- --- --- --- --- --- ---begin powershell Payload # diff --git a/src/lib/app-punk/pkgIndex.tcl b/src/lib/app-punk/pkgIndex.tcl index 6ace9792..ac1128f5 100644 --- a/src/lib/app-punk/pkgIndex.tcl +++ b/src/lib/app-punk/pkgIndex.tcl @@ -1,3 +1 @@ - - package ifneeded app-punk 1.0 [list source [file join $dir repl.tcl]] - +package ifneeded app-punk 1.0 [list source [file join $dir repl.tcl]] \ No newline at end of file diff --git a/src/lib/app-punkshell/pkgIndex.tcl b/src/lib/app-punkshell/pkgIndex.tcl new file mode 100644 index 00000000..1286773f --- /dev/null +++ b/src/lib/app-punkshell/pkgIndex.tcl @@ -0,0 +1,2 @@ +package ifneeded app-punkshell 1.0 [list source [file join $dir punkshell.tcl]] + diff --git a/src/lib/app-punkshell/punkshell.tcl b/src/lib/app-punkshell/punkshell.tcl new file mode 100644 index 00000000..1559f0ec --- /dev/null +++ b/src/lib/app-punkshell/punkshell.tcl @@ -0,0 +1,296 @@ +package provide app-punkshell 1.0 + +package require Thread +package require punk::args +package require shellfilter +package require punk::ansi +package require punk::packagepreference +punk::packagepreference::install + +namespace eval punkshell { + variable chanstack_stderr_redir + variable chanstack_stdout_redir + proc clock_sec {} { + return [expr {[clock millis]/1000.0}] + } + set do_log 0 + if {$do_log} { + set debug_syslog_server 127.0.0.1:514 + #set debug_syslog_server 172.16.6.42:51500 + set error_syslog_server 127.0.0.1:514 + set data_syslog_server 127.0.0.1:514 + } else { + set debug_syslog_server "" + set error_syslog_server "" + set data_syslog_server "" + } + #------------------------------------------------------------------------- + ##don't write to stdout/stderr before you've redirected them to a log using shellfilter functions + ## puts to stdout/stderr will comingle with command's output if performed before the channel stacks are configured. + + #chan configure stdin -buffering line + #chan configure stdout -buffering none + #chan configure stderr -buffering none + + #redir on the shellfilter stack with no log or syslog specified acts to suppress output of stdout & stderr. + #todo - fix shellfilter code to make this noop more efficient (avoid creating corresponding logging thread and filter?) + #JMN + #set redirconfig {-settings {-syslog 127.0.0.1:514 -file ""}} + set redirconfig {} + #lassign [shellfilter::redir_output_to_log "SUPPRESS" {*}$redirconfig] chanstack_stdout_redir chanstack_stderr_redir + #shellfilter::log::write $punkshell_status_log "shellfilter::redir_output_to_log SUPPRESS DONE [clock_sec]" + + set stdout_log "" + set stderr_log "" + #set stdout_log [file normalize ~]/punkshell-stdout.txt + #set stderr_log [file normalize ~]/punkshell-stderr.txt + set stdout_log "[pwd]/punkshell_out.log" + set stderr_log "[pwd]/punkshell_err.log" + + set errdeviceinfo [shellfilter::stack::new punkshellerr -settings [list -tag "punkshellerr" -buffering none -raw 1 -syslog $data_syslog_server -file $stderr_log]] + set outdeviceinfo [shellfilter::stack::new punkshellout -settings [list -tag "punkshellout" -buffering none -raw 1 -syslog $data_syslog_server -file $stdout_log]] + #set commandlog [dict get $outdeviceinfo localchan] + #puts $commandlog "HELLO $commandlog" + #flush $commandlog + + proc do_script {scriptname args} { + #ideally we don't want to launch an external process to run the script + #variable punkshell_status_log + #shellfilter::log::write $punkshell_status_log "do_script got scriptname:'$scriptname' replwhen:$replwhen args:'$args'" + set exepath [file dirname [file join [info nameofexecutable] __dummy__]] + set exedir [file dirname $exepath] + set scriptpath [file normalize $scriptname] + if {![file exists $scriptpath]} { + puts stderr "Failed to find script: '$scriptpath'" + error "bad scriptpath '$scriptpath'" + } + + set script [string map [list %a% $args %s% $scriptpath] { +set normscript %s% +#save values +set prevscript [info script] +set prevglobal [dict create] +foreach g [list ::argv ::argc ::argv0] { + if {[info exists $g]} { + dict set prevglobal $g [set $g] + } +} +#setup and run +set ::argv [list %a%] +set ::argc [llength $::argv] +set ::argv0 $normscript +info script $normscript +source $normscript +#restore values +info script $prevscript +dict with prevglobal {} + }] + + dict set params -tclscript 1 ;#don't give callback a chance to omit/break this + dict set params -teehandle punkshell + #dict set params -teehandle punksh + dict set params -inbuffering none + dict set params -outbuffering none + dict set params -readprocesstranslation crlf + dict set params -outtranslation lf + + set id_err [shellfilter::stack::add stderr ansiwrap -action sink-locked -settings {-colour {red bold}}] + + set exitinfo [shellfilter::run $script {*}$params] + + shellfilter::stack::remove stderr $id_err + + if {[dict exists $exitinfo errorInfo]} { + #strip out the irrelevant info from the errorInfo - we don't want info beyond 'invoked from within' as this is just plumbing related to the script sourcing + set stacktrace [string map [list \r\n \n] [dict get $exitinfo errorInfo]] + set output "" + set tracelines [split $stacktrace \n] + foreach ln $tracelines { + if {[string match "*invoked from within*" $ln]} { + break + } + append output $ln \n + } + set output [string trimright $output \n] + dict set exitinfo errorInfo $output + } + return $exitinfo + } + + proc do_tclkit {kitname replwhen args} { + + set script [string map [list %a% $args %k% $kitname] { +#::tcl::tm::add %m% +set kit %k% +set kitpath [file normalize $kit] +set kitmount $kitpath.0 + +#save values +set prevscript [info script] +set prevglobal [dict create] +foreach g [list ::argv ::argc ::argv0] { + if {[info exists $g]} { + dict set prevglobal $g [set $g] + } +} + +#setup and run +set ::argv [list %a%] +set ::argc [llength $::argv] + +set ::argv0 $kitmount +#puts stderr "setting 'info script' $kitmount/main.tcl" +info script $kitmount/main.tcl +#info script dir must match argv0 for kit main.tcl to return 'starkit' from 'starkit::startup' + +if {![catch { + package require vfs + package require vfs::mk4 + } errMsg]} { + + vfs::mk4::Mount $kitpath $kitmount + lappend ::auto_path $kitmount/lib + if {[file exists "$kitmount/modules"]} { + tcl::tm::add "$kitmount/modules" + } + + #puts stderr "sourcing $kitmount/main.tcl" + #puts stderr "$kitmount/main.tcl exists: [file exists $kitmount/main.tcl]" + #puts stderr "argv : $::argv" + #puts stderr "argv0: $::argv0" + #puts stderr "autopath: $::auto_path" + #puts stdout "starkit::startup [starkit::startup]" + + #usually main.tcl will just be something like: package require app-XXX + #it will usually do nothing if starkit::startup returned 'sourced' + + source $kitmount/main.tcl + +} else { + puts stderr "Unable to load vfs::mk4 for tclkit mounting" +} +#restore values +info script $prevscript +dict with prevglobal {} + }] + + set repl_lines "" + append repl_lines {package require punk::repl} \n + append repl_lines {repl::init -safe 0} \n + append repl_lines {repl::start stdin} \n + + #test + #set replwhen "repl_last" + + if {$replwhen eq "repl_first"} { + #we need to cooperate with the repl to get the script to run on exit + namespace eval ::repl {} + set ::repl::post_script $script + set script "$repl_lines" + } elseif {$replwhen eq "repl_last"} { + append script $repl_lines + } else { + #just the script + } + + dict set params -tclscript 1 ;#don't give callback a chance to omit/break this + dict set params -teehandle punkshell + dict set params -inbuffering none + dict set params -outbuffering none + dict set params -readprocesstranslation crlf + dict set params -outtranslation lf + + set id_err [shellfilter::stack::add stderr ansiwrap -action sink-locked -settings {-colour {red bold}}] + + set exitinfo [shellfilter::run $script {*}$params] + + shellfilter::stack::remove stderr $id_err + + if {[dict exists $exitinfo errorInfo]} { + #strip out the irrelevant info from the errorInfo - we don't want info beyond 'invoked from within' as this is just plumbing related to the script sourcing + set stacktrace [string map [list \r\n \n] [dict get $exitinfo errorInfo]] + set output "" + set tracelines [split $stacktrace \n] + foreach ln $tracelines { + if {[string match "*invoked from within*" $ln]} { + break + } + append output $ln \n + } + set output [string trimright $output \n] + dict set exitinfo errorInfo $output + } + return $exitinfo + } + + + punk::args::define { + @id -id ::punkshell + @cmd -name punkshell + @leaders -min 0 -max 0 + @opts + -debug -type none + @values -min 1 -max -1 + script_or_kit -type string + arg -type any -optional 1 -multiple 1 + } + set argd [punk::args::parse $::argv withid ::punkshell] + lassign [dict values $argd] leaders opts values received + + set script_or_kit [dict get $values script_or_kit] + if {[dict exists $received arg]} { + set arglist [dict get $values arg] + } else { + set arglist [list] + } + + set exitinfo [dict create] + switch -glob -nocase -- $script_or_kit { + lib:* { + #scriptlib + puts stderr "lib:* todo" + } + *.tcl { + set exitinfo [punkshell::do_script $script_or_kit {*}$arglist] + } + *.kit { + set exitinfo [punkshell::do_tclkit $script_or_kit "no_repl" {*}$arglist] + } + default { + puts stderr "unrecognised script extension" + } + } + + catch { + shellfilter::stack::remove stderr $chanstack_stderr_redir + shellfilter::stack::remove stdout $chanstack_stdout_redir + } + shellfilter::stack::delete punkshellout + shellfilter::stack::delete punkshellerr + set free_info [shellthread::manager::shutdown_free_threads] + foreach tid [thread::names] { + thread::release $tid + } + + if {[dict size $exitinfo] == 0} { + puts stderr "No result" + exit 2 + } + + if {[dict exists $exitinfo errorInfo]} { + set einf [dict get $exitinfo errorInfo] + puts stderr "errorCode: [dict get $exitinfo errorCode]" + if {[catch { + punk::ansi::ansiwrap yellow bold $einf + } msg]} { + set msg $einf + } + puts stderr $msg + flush stderr + exit 1 + } else { + puts -nonewline stdout [dict get $exitinfo result] + exit 0 + } +} + diff --git a/src/lib/app-shellspy/pkgIndex.tcl b/src/lib/app-shellspy/pkgIndex.tcl index 4e20e141..e15ce417 100644 --- a/src/lib/app-shellspy/pkgIndex.tcl +++ b/src/lib/app-shellspy/pkgIndex.tcl @@ -1,3 +1,2 @@ - - package ifneeded app-shellspy 1.0 [list source [file join $dir shellspy.tcl]] - +package ifneeded app-shellspy 1.0 [list source [file join $dir shellspy.tcl]] + diff --git a/src/lib/app-shellspy/shellspy.tcl b/src/lib/app-shellspy/shellspy.tcl index 654b5c40..2994077e 100644 --- a/src/lib/app-shellspy/shellspy.tcl +++ b/src/lib/app-shellspy/shellspy.tcl @@ -1,1168 +1,1281 @@ -#! /usr/bin/env tclsh -# -#copyright 2023 Julian Marcel Noble -#license: BSD (revised 3-clause) -# -#see notes at beginning of shellspy namespace re stdout/stderr -# -#SHELLSPY - provides commandline flag information and stdout/stderr logging/mirroring without output/pipeline interference, -# or modified output if modifying filters explicitly configured. -# -#shellspy uses the shellfilter and flagfilter libraries to run a commandline with tee-diversions of stdout/stderr to configured syslog/file logs -#Because it is a tee, the command's stdout/stderr are still available as direct output from this script. -#Various filters/modifiers/redirections can be placed on the channel stacks for stdin/stderr using the shellfilter::stack api -# and other shellfilter:: helpers such as shellfilter::redir_output_to_log -# Redirecting stderr/stdout in this way prior to the actual command run will not interfere with the command/pipeline output due to the way -# shellfilter temporarily inserts it's own tee into the stack at the point of the highest existing redirection it encounters. -# -#A note on input/output convention regarding channels/pipes -# we write to an output, read from an input. -# e.g when creating a pipe with 'lassign [chan pipe] in out' we write to out and read from in. -# This is potentially confusing from an OO-like perspective thinking of a pipe object as a sort of object. -# Don't think of it from the perspective of the pipe - but from the program using it. -# This is not a convention invented here for shellspy - but it seems to match documentation and common use e.g for 'chan pending input|output chanid' -# This matches the way we write to stdout read from stdin. -# Possibly using read/write related naming for pipe ends is clearer. eg 'lassign [chan pipe] rd_pipe1 wr_pipe1' -# -package provide app-shellspy 1.0 - - -#experiment - todo make a flag for it if it's useful -#Middle cap for direct dispatch without flagcheck arg processing or redirections or REPL. -set arg1 [lindex $::argv 0] -if {[file extension $arg1] in [list .tCl]} { - set ::argv [lrange $::argv 1 end] - set ::argc [llength $::argv] - - set exedir [file dirname [info nameofexecutable]] - set binscripts [file join $exedir scriptlib] - if {[file exists $binscripts]} { - set libdir $binscripts - } else { - set libdir [file join [file dirname $exedir] scriptlib]] - } - set scriptname $arg1 - if {[string match lib:* $scriptname]} { - set scriptname [string range $scriptname 4 end] - set scriptname [string trimleft $scriptname :] ;#incase specified as lib:: - set scriptpath $libdir/$scriptname - } else { - set scriptpath $scriptname - } - set scriptpath [file normalize $scriptpath] - - if {![file exists $scriptpath]} { - #try the lowercase version (extension lowercased only) so that file doesn't have to be renamed to use alternate dispatch - set scriptpath [file rootname $scriptpath][string tolower [file extension $scriptpath]] - } - source $scriptpath - - #package require app-punk - -} else { - - - -#set m_dir [file join $starkit::topdir modules] - - -#catch {package require tcllibc} - -#review. we need thread for when configured to pump info to syslog etc - but it is overhead for simple script calls. -#todo - see if we can avoid loading in certain cases (based on punk::config?) -package require Thread - -package require flagfilter -package require shellfilter -package require punk::ansi -package require punk::packagepreference -punk::packagepreference::install - -#The whole punk infrastructure is overkill for calling arbitrary scripts -#package require punk - -#testing -#package require packageTrace - -set ::testconfig 5 - -namespace eval shellspy { - variable chanstack_stderr_redir - variable chanstack_stdout_redir - - variable commands - proc clock_sec {} { - return [expr {[clock millis]/1000.0}] - } - variable shellspy_status_log "shellspy-[clock micros]" - - #todo - default to no logging not even to local syslog - #load a .toml config which can configure logging as desired - set do_log 0 - if {$do_log} { - set debug_syslog_server 127.0.0.1:514 - #set debug_syslog_server 172.16.6.42:51500 - #set debug_syslog_server "" - set error_syslog_server 127.0.0.1:514 - set data_syslog_server 127.0.0.1:514 - } else { - set debug_syslog_server "" - set error_syslog_server "" - set data_syslog_server "" - } - - - - - shellfilter::log::open $shellspy_status_log [list -tag $shellspy_status_log -syslog $debug_syslog_server -file ""] - shellfilter::log::write $shellspy_status_log "shellspy launch with args '$::argv'" - shellfilter::log::write $shellspy_status_log "stdout/stderr encoding: [chan configure stdout -encoding]/[chan configure stderr -encoding]" - - #------------------------------------------------------------------------- - ##don't write to stdout/stderr before you've redirected them to a log using shellfilter functions - ## puts to stdout/stderr will comingle with command's output if performed before the channel stacks are configured. - - chan configure stdin -buffering line - chan configure stdout -buffering none - chan configure stderr -buffering none - - #set id_ansistrip [shellfilter::stack::add stderr ansistrip -settings {}] - #set id_ansistrip [shellfilter::stack::add stdout ansistrip -settings {}] - - #redir on the shellfilter stack with no log or syslog specified acts to suppress output of stdout & stderr. - #todo - fix shellfilter code to make this noop more efficient (avoid creating corresponding logging thread and filter?) - #JMN - #set redirconfig {-settings {-syslog 127.0.0.1:514 -file ""}} - set redirconfig {} - lassign [shellfilter::redir_output_to_log "SUPPRESS" {*}$redirconfig] chanstack_stdout_redir chanstack_stderr_redir - shellfilter::log::write $shellspy_status_log "shellfilter::redir_output_to_log SUPPRESS DONE [clock_sec]" - - - ### - #we can now safely write to stderr/stdout and it will not interfere with stderr/stdout from the dispatched command. - #This is because when shellfilter::run is called it temporarily adds it's own filter in place of the redirection we just added. - # shellfilter::run installs tee_to_pipe on stdout & stderr with -action sink-aside. - # sink-aside means to sink down the filter stack to the topmost filter that is diversionary, and replace it. - # when the command finishes running, the redirecting filter that it displaced is reinstalled in the stack. - ### - - ### - #Note that futher filters installed here will sit 'above' any of the redirecting filters - # so apply to both the shellfilter::run commandline, - # as well as writes to stderr/stdout from here or other libraries operating in this process. - # To bypass the the filter-stack and still emit to syslog etc - - # you can use shellfilter::log::open and shellfilter::log::write e.g - # shellfilter::log::open "mystatuslog" [list -tag "mystatuslog" -syslog 172.16.6.42:51500 -file ""] - # shellfilter::log::write "mystatuslog" "shellspy launch" - # - #### - #set id_ansistrip [shellfilter::stack::add stderr ansistrip -action float -settings {}] - #set id_ansistrip [shellfilter::stack::add stdout ansistrip -action float -settings {}] - - - ##stdin stack operates in reverse compared to stdout/stderr in that first added to stack is first to see the data - ##for stdin: first added to stack is 'upstream' as it will always encounter the data before later ones added to the stack. - ##for stdout: first added to stack is 'downstream' as it will alays encounter the data after others on the stack - #shellfilter::stack::add stdin ansistrip -action {} -settings {} - #shellfilter::stack::add stdin tee_to_log -settings {-tag "input" -raw 1 -syslog 172.16.6.42:51500 -file ""} - - #------------------------------------------------------------------------- - ##note - to use shellfilter::stack::new - the fifo2 end at the local side requires the event loop to be running - ## for interactive testing a relatively simple repl.tcl can be used. - - #todo - default to no logging.. add special flag in checkflags to indicate end of options for matched command only e.g --- ? - # then prioritize these results from checkflags to configure pre-dispatch behaviour by running a predispatch script(?) - # - # we can log flag-processing info coming from checkflags.. but we don't want to do two opt scans and emit it twice. - # configuration of the logging for flag/opt parsing should come from a config file and default to none. - #set stdout_log [file normalize ~]/shellspy-stdout.txt - #set stderr_log [file normalize ~]/shellspy-stderr.txt - set stdout_log "" - set stderr_log "" - - shellfilter::log::write $shellspy_status_log "shellfilter::stack::new shellspyerr ABOUTTO [clock_sec]" - set errdeviceinfo [shellfilter::stack::new shellspyerr -settings [list -tag "shellspyerr" -buffering none -raw 1 -syslog $data_syslog_server -file $stderr_log]] - shellfilter::log::write $shellspy_status_log "shellfilter::stack::new shellspyerr DONE [clock_sec]" - - - shellfilter::log::write $shellspy_status_log "shellfilter::stack::new shellspyout ABOUTTO [clock_sec]" - set outdeviceinfo [shellfilter::stack::new shellspyout -settings [list -tag "shellspyout" -buffering none -raw 1 -syslog $data_syslog_server -file $stdout_log]] - set commandlog [dict get $outdeviceinfo localchan] - #puts $commandlog "HELLO $commandlog" - #flush $commandlog - shellfilter::log::write $shellspy_status_log "shellfilter::stack::new shellspyout DONE [clock_sec]" - - - - #note that this filter is inline with the data teed off to the shellspyout log. - #To filter the main stdout an addition to the stdout stack can be made. specify -action float to have it affect both stdout and the tee'd off data. - set id_ansistrip [shellfilter::stack::add shellspyout ansistrip -settings {}] - shellfilter::log::write $shellspy_status_log "shellfilter::stack::add shellspyout ansistrip DONE [clock_sec]" - - - #set id_out [shellfilter::stack::add stdout rebuffer -settings {}] - - #an example filter to capture some output to a var for later use - this one is for ansible-playbook - #set ::recap "" - #set id_tee_grep [shellfilter::stack::add shellspyout tee_grep_to_var -settings {-grep ".*PLAY RECAP.*|.*fatal:.*|.*changed:.*" -varname ::recap -pre 1 -post 3}] - - namespace import ::flagfilter::check_flags - - namespace eval shellspy::callbacks {} - namespace eval shellspy::parameters {} - - - proc do_callback {func args} { - variable shellspy_status_log - set exedir [file dirname [info nameofexecutable]] - set dispatchtcl [file join $exedir callbacks dispatch.tcl] - if {[file exists $dispatchtcl]} { - source $dispatchtcl - if {[llength [info commands shellspy::callbacks::$func]]} { - shellfilter::log::write $shellspy_status_log "found shellspy::callbacks::$func - calling" - if {[catch { - set args [shellspy::callbacks::$func {*}$args] - } errmsg]} { - shellfilter::log::write $shellspy_status_log "ERROR in shellspy::callbacks::$func\n errormsg:$errmsg" - error $errmsg - } - } - } - return $args - } - proc do_callback_parameters {func args} { - variable shellspy_status_log - set exedir [file dirname [info nameofexecutable]] - set paramtcl [file join $exedir callbacks parameters.tcl] - set params $args - if {[file exists $paramtcl]} { - source $paramtcl - if {[llength [info commands shellspy::parameters::$func]]} { - shellfilter::log::write $shellspy_status_log "found shellspy::parameters::$func - calling" - if {[catch { - set params [shellspy::parameters::$func $params] - } errmsg]} { - shellfilter::log::write $shellspy_status_log "ERROR in shellspy::parameters::$func\n errormsg:$errmsg" - } - } - } - return $params - } - - #some tested configs - proc get_channel_config {config} { - #note tcl script being called from wrong place.. configs don't affect: todo - move it. - set params [dict create] - switch -- $config { - 0 { - #bad for: everything. extra cr - dict set params -inbuffering line - dict set params -outbuffering line - dict set params -readprocesstranslation auto ;#default - dict set params -outtranslation auto - } - 1 { - #ok for: cmd, cmd/u/c,raw,pwsh, sh,raw, tcl script process - #not ok for: bash,wsl, tcl script - dict set params -inbuffering line - dict set params -outbuffering line - dict set params -readprocesstranslation auto ;#default - dict set params -outtranslation lf - } - 2 { - #ok for: cmd, cmd/uc,pwsh,sh , tcl script process - #not ok for: tcl script, bash, wsl - dict set params -inbuffering none ;#default - dict set params -outbuffering none ;#default - dict set params -readprocesstranslation auto ;#default - dict set params -outtranslation lf ;#default - } - 3 { - #ok for: cmd - dict set params -inbuffering line - dict set params -outbuffering line - dict set params -readprocesstranslation lf - dict set params -outtranslation lf - } - 4 { - #ok for: cmd,cmd/uc,raw,sh - #not ok for pwsh,bash,wsl, tcl script, tcl script process - dict set params -inbuffering none - dict set params -outbuffering none - dict set params -readprocesstranslation lf - dict set params -outtranslation lf - } - 5 { - #ok for: pwsh,cmd,cmd/u/c,raw,sh, tcl script process - #not ok for bash,wsl - #ok for vim cmd/u/c but only with to_unix filter on stdout (works in gvim and console) - dict set params -inbuffering none - dict set params -outbuffering none - dict set params -readprocesstranslation crlf - dict set params -outtranslation lf - } - 6 { - #ok for: cmd,cmd/u/c,pwsh,raw,sh,bash - #not ok for: vim with cmd /u/c (?) - dict set params -inbuffering line - dict set params -outbuffering line - dict set params -readprocesstranslation crlf - dict set params -outtranslation lf - } - 7 { - #ok for: sh,bash - #not ok for: wsl (display ok but extra cr), cmd,cmd/u/c,pwsh, tcl script, tcl script process, raw - dict set params -inbuffering none - dict set params -outbuffering none - dict set params -readprocesstranslation crlf - dict set params -outtranslation crlf - } - 8 { - #not ok for anything..all have extra cr - dict set params -inbuffering none - dict set params -outbuffering none - dict set params -readprocesstranslation lf - dict set params -outtranslation crlf - } - } - return $params - } - - proc do_help {args} { - #return [dict create result $::shellspy::commands] - set result "" - foreach cmd $::shellspy::commands { - lassign $cmd tag cmdinfo - if {[lindex $cmdinfo 0] eq "sub"} { - continue - } - if {[dict exists $cmdinfo match]} { - append result "$tag [dict get $cmdinfo match]" \n - } - } - return [dict create result $result] - } - - - #punk86 -tk example: - # punk86 -tk eval "button .tk.b -text doit -command {set ::punkapp::result(shell) guiresult;punkapp::close_window .tk}; pack .tk.b;return somedefaultvalue" - proc do_tclline {flavour args} { - variable chanstack_stderr_redir - variable chanstack_stdout_redir - - if {$flavour in [list "punk" "punkshell"]} { - namespace eval :: {package require punk;package require shellrun} - } elseif {$flavour in [list "tk" "tkshell"]} { - namespace eval :: { - package require Tk - package require punkapp - punkapp::hide_dot_window - toplevel .tk - if {[wm protocol . WM_DELETE_WINDOW] eq ""} { - wm protocol . WM_DELETE_WINDOW [list punkapp::close_window .] - } - wm protocol .tk WM_DELETE_WINDOW [list punkapp::close_window .tk] - } - } - #remove SUPPRESS redirection if it was in place so that shell output is visible - catch { - shellfilter::stack::remove stderr $chanstack_stderr_redir - shellfilter::stack::remove stdout $chanstack_stdout_redir - } - set result_is_error 0 - if {[catch {apply [list {arglist} {namespace eval :: $arglist} ::] $args} result]} { - set result_is_error 1 - } - if {$flavour in [list "punkshell" "tkshell"]} { - set result [namespace eval :: [string map [list %e% $chanstack_stderr_redir %o% $chanstack_stdout_redir %r% $result] { - package require punk - package require shellrun - package require punk::repl - puts stdout "quit to exit" - repl::init -safe 0 - repl::start stdin -defaultresult %r% - }]] - } - - #todo - better exit? - if {$result_is_error} { - if {$flavour eq "tk"} { - return [dict create error [namespace eval :: [list punkapp::wait -defaultresult $result]]] - #todo - better return value e.g from dialog? - } - return [dict create error $result] - } else { - if {$flavour eq "tk"} { - return [dict create result [namespace eval :: [list punkapp::wait -defaultresult $result]]] - #todo - better return value e.g from dialog? - } - return [dict create result $result] - } - } - proc set_punkd {args} { - variable shellspy_status_log - shellfilter::log::write $shellspy_status_log "set_punkd got '$args'" - - set punkd_status_log "set_punkd_log" - shellfilter::log::open $punkd_status_log [list -tag $punkd_status_log -syslog 127.0.0.1:514 -file ""] - shellfilter::log::write $punkd_status_log "set_punkd got '$args'" - return [dict create result ok] - } - - proc do_in_powershell {args} { - variable shellspy_status_log - shellfilter::log::write $shellspy_status_log "do_in_powershell got '$args'" - set args [do_callback powershell {*}$args] - set params [do_callback_parameters powershell] - dict set params -teehandle shellspy - - - #readprocesstranslation lf - doesn't work for buffering line or none - #readprocesstranslation crlf works for buffering line and none with outchantranslation lf - - set params [dict merge $params [get_channel_config $::testconfig]] ;#working: 5 unbuffered, 6 linebuffered - - - dict set params -debug 1 - dict set params -timeout 1000 - - #set exitinfo [shellfilter::run [list pwsh -nologo -noprofile -c {*}$args] -debug 1] - - - set id_err [shellfilter::stack::add stderr ansiwrap -action sink -settings {-colour {red bold}}] - set exitinfo [shellfilter::run [list pwsh -nologo -noprofile -c {*}$args] {*}$params] - shellfilter::stack::remove stderr $id_err - - #Passing args in as a single element will tend to make powershell treat the args as a 'script block' - # (powershell sees items in curly brackets {} as a scriptblock - when called from non-powershell, this tends to just echo back the contents) - #set exitinfo [shellfilter::run [list pwsh -nologo -noprofile -c $args] {*}$params] - if {[lindex $exitinfo 0] eq "exitcode"} { - shellfilter::log::write $shellspy_status_log "do_in_powershell returning $exitinfo" - #exit [lindex $exitinfo 1] - } - return $exitinfo - } - proc do_in_powershell_terminal {args} { - variable shellspy_status_log - shellfilter::log::write $shellspy_status_log "do_in_powershell_terminal got '$args'" - set args [do_callback powershell {*}$args] - set params [do_callback_parameters powershell] - dict set params -teehandle shellspy - set params [dict merge $params [get_channel_config $::testconfig]] ;#working: 5 unbuffered, 6 linebuffered - - #set cmdlist [list pwsh -nologo -noprofile -c {*}$args] - set cmdlist [list pwsh -nologo -c {*}$args] - #the big problem with using the 'script' command is that we get stderr/stdout mashed together. - - #set cmdlist [shellfilter::get_scriptrun_from_cmdlist_dquote_if_not $cmdlist] - shellfilter::log::write $shellspy_status_log "do_in_powershell_terminal as script: '$cmdlist'" - - set id_err [shellfilter::stack::add stderr ansiwrap -action sink -settings {-colour {red bold}}] - set exitinfo [shellfilter::run $cmdlist {*}$params] - shellfilter::stack::remove stderr $id_err - - if {[lindex $exitinfo 0] eq "exitcode"} { - shellfilter::log::write $shellspy_status_log "do_in_powershell_terminal returning $exitinfo" - } - return $exitinfo - } - - - proc do_in_cmdshell {args} { - variable shellspy_status_log - shellfilter::log::write $shellspy_status_log "do_in_cmdshell got '$args'" - set args [do_callback cmdshell {*}$args] - set params [do_callback_parameters cmdshell] - - - dict set params -teehandle shellspy - dict set params -copytempfile 1 - - set params [dict merge $params [get_channel_config $::testconfig]] - - #set id_out [shellfilter::stack::add stdout tounix -action sink-locked -settings {}] - set id_err [shellfilter::stack::add stderr ansiwrap -action sink-locked -settings {-colour {red bold}}] - - #set exitinfo [shellfilter::run "cmd /c $args" -debug 1] - set exitinfo [shellfilter::run [list cmd /c {*}$args] {*}$params] - #set exitinfo [shellfilter::run [list cmd /c {*}$args] -debug 1] - - shellfilter::stack::remove stderr $id_err - - #shellfilter::stack::remove stdout $id_out - - shellfilter::log::write $shellspy_status_log "do_in_cmdshell raw exitinfo: $exitinfo" - - - if {[lindex $exitinfo 0] eq "exitcode"} { - #exit [lindex $exitinfo 1] - #shellfilter::log::write $shellspy_status_log "do_in_cmdshell returning $exitinfo" - #puts stderr "do_in_cmdshell returning $exitinfo" - } - return $exitinfo - } - proc do_in_cmdshellb {args} { - - variable shellspy_status_log - shellfilter::log::write $shellspy_status_log "do_in_cmdshellb got '$args'" - - set args [do_callback cmdshellb {*}$args] - - - shellfilter::log::write $shellspy_status_log "do_in_cmdshellb post_callback args '$args'" - - set params [do_callback_parameters cmdshellb] - dict set params -teehandle shellspy - dict set params -copytempfile 1 - dict set params -debug 0 - - #----------------------------- - #channel config 6 and towindows sink-aside-locked {-junction 1} works with vim-flog - #----------------------------- - set params [dict merge $params [get_channel_config 6]] - #set id_out [shellfilter::stack::add stdout tounix -action sink-aside-locked -junction 1 -settings {}] - - - set exitinfo [shellfilter::run [list cmd /u/c {*}$args] {*}$params] - - #shellfilter::stack::remove stdout $id_out - - if {[lindex $exitinfo 0] eq "exitcode"} { - shellfilter::log::write $shellspy_status_log "do_in_cmdshellb returning with exitcode $exitinfo" - } else { - shellfilter::log::write $shellspy_status_log "do_in_cmdshellb returning WITHOUT exitcode $exitinfo" - } - return $exitinfo - } - proc do_in_cmdshelluc {args} { - variable shellspy_status_log - shellfilter::log::write $shellspy_status_log "do_in_cmdshelluc got '$args'" - set args [do_callback cmdshelluc {*}$args] - set params [do_callback_parameters cmdshell] - #set exitinfo [shellfilter::run "cmd /c $args" -debug 1] - dict set params -teehandle shellspy - dict set params -copytempfile 1 - dict set params -debug 0 - - #set params [dict merge $params [get_channel_config $::testconfig]] - - set params [dict merge $params [get_channel_config 1]] - #set id_out [shellfilter::stack::add stdout tounix -action sink-locked -settings {}] - - set id_out [shellfilter::stack::add stdout tounix -action sink-locked -settings {}] - - set exitinfo [shellfilter::run [list cmd /u/c {*}$args] {*}$params] - shellfilter::stack::remove stdout $id_out - #chan configure stdout -translation crlf - - if {[lindex $exitinfo 0] eq "exitcode"} { - #exit [lindex $exitinfo 1] - shellfilter::log::write $shellspy_status_log "do_in_cmdshelluc returning $exitinfo" - #puts stderr "do_in_cmdshell returning $exitinfo" - } - return $exitinfo - } - proc do_raw {args} { - variable shellspy_status_log - shellfilter::log::write $shellspy_status_log "do_raw got '$args'" - set args [do_callback raw {*}$args] - set params [do_callback_parameters raw] - #set params {} - dict set params -debug 0 - #dict set params -outprefix "_test_" - dict set params -teehandle shellspy - - - set params [dict merge $params [get_channel_config $::testconfig]] - - - if {[llength $params]} { - set exitinfo [shellfilter::run $args {*}$params] - } else { - set exitinfo [shellfilter::run $args -debug 1 -outprefix "j"] - } - if {[lindex $exitinfo 0] eq "exitcode"} { - shellfilter::log::write $shellspy_status_log "do_raw returning $exitinfo" - } - return $exitinfo - } - - proc do_script_process {scriptbin scriptname args} { - variable shellspy_status_log - if {$scriptbin eq "withinterp.word0"} { - set scriptbin $scriptname - set scriptname [lindex $args 0] - set args [lrange $args 1 end] - } - shellfilter::log::write $shellspy_status_log "do_script_process got scriptname:'$scriptname' args:'$args'" - #no script_process callbacks - #set args [do_callback script_process {*}$args] - #set params [do_callback_parameters script_process] - dict set params -teehandle shellspy - - set params [dict merge $params [get_channel_config $::testconfig]] - - set exedir [file dirname [info nameofexecutable]] - if {[file exists $exedir/scriptlib]} { - set libroot $exedir/scriptlib - } else { - set libroot [file dirname $exedir]/scriptlib - } - if {[string match lib:* $scriptname]} { - set scriptname [string range $scriptname 4 end] - set scriptname [string trimleft $scriptname :] ;#incase specified as lib:: - set scriptpath $libroot/$scriptname - } else { - set scriptpath $scriptname - } - set scriptpath [file normalize $scriptpath] - if {![file exists $scriptpath]} { - if {[file extension $scriptpath] eq ""} { - set scriptpath $scriptpath.tcl - } else { - set scriptpath [file rootname $scriptpath][string tolower [file extension $scriptpath]] - } - if {![file exists $scriptpath]} { - puts stderr "Failed to find script: '$scriptpath'" - error "bad scriptpath '$scriptpath' arguments: $scriptbin $scriptname $args" - } - } - - - - #set id_err [shellfilter::stack::add stderr ansiwrap -action sink-locked -settings {-colour {red bold}}] - - - - #todo - use glob to check capitalisation of file tail (.TCL vs .tcl .Tcl etc) - set exitinfo [shellfilter::run [concat [auto_execok $scriptbin] $scriptpath $args] {*}$params] - shellfilter::log::write $shellspy_status_log "do_script_process exitinfo: $exitinfo" - - #shellfilter::stack::remove stderr $id_err - - #if {[lindex $exitinfo 0] eq "exitcode"} { - # shellfilter::log::write $shellspy_status_log "do_script_process returning $exitinfo" - #} - #if {[dict exists $exitinfo errorCode]} { - # exit [dict get $exitinfo $errorCode] - #} - return $exitinfo - } - proc do_script {scriptname replwhen args} { - #ideally we don't want to launch an external process to run the script - variable shellspy_status_log - #shellfilter::log::write $shellspy_status_log "do_script got scriptname:'$scriptname' replwhen:$replwhen args:'$args'" - set exepath [file dirname [file join [info nameofexecutable] __dummy__]] - set exedir [file dirname $exepath] - - if {[file tail $exedir] eq "bin"} { - set basedir [file dirname $exedir] - } else { - set basedir $exedir - } - set libroot [file join $basedir scriptlib] - if {[string match lib:* $scriptname]} { - set scriptname [string range $scriptname 4 end] - set scriptname [string trimleft $scriptname :] ;#incase specified as lib:: - set scriptpath $libroot/$scriptname - } else { - set scriptpath $scriptname - } - set scriptpath [file normalize $scriptpath] - if {![file exists $scriptpath]} { - if {[file extension $scriptpath] eq ""} { - set scriptpath $scriptpath.tcl - } else { - set scriptpath [file rootname $scriptpath][string tolower [file extension $scriptpath]] - } - if {![file exists $scriptpath]} { - puts stderr "Failed to find script: '$scriptpath'" - error "bad scriptpath '$scriptpath'" - } - } - set modulesdir $basedir/modules - - set script [string map [list %a% $args %s% $scriptpath %m% $modulesdir] { -#::tcl::tm::add %m% -set scriptname %s% -set normscript [file normalize $scriptname] - -#save values -set prevscript [info script] -set prevglobal [dict create] -foreach g [list ::argv ::argc ::argv0] { - if {[info exists $g]} { - dict set prevglobal $g [set $g] - } -} - -#setup and run -set ::argv [list %a%] -set ::argc [llength $::argv] -set ::argv0 $normscript -info script $normscript -source $normscript - -#restore values -info script $prevscript -dict with prevglobal {} - }] - - set repl_lines "" - #append repl_lines {puts stderr "starting repl [chan names]"} \n - #append repl_lines {puts stderr "stdin [chan configure stdin]"} \n - append repl_lines {package require punk::repl} \n - append repl_lines {repl::init -safe 0} \n - append repl_lines {repl::start stdin} \n - - #append repl_lines {puts stdout "shutdown message"} \n - - if {$replwhen eq "repl_first"} { - #we need to cooperate with the repl to get the script to run on exit - namespace eval ::repl {} - set ::repl::post_script $script - set script "$repl_lines" - } elseif {$replwhen eq "repl_last"} { - append script $repl_lines - } else { - #just the script - } - - #no script callbacks - #set args [do_callback script {*}$args] - #set params [do_callback_parameters script] - - dict set params -tclscript 1 ;#don't give callback a chance to omit/break this - dict set params -teehandle shellspy - #dict set params -teehandle punksh - - - set params [dict merge $params [get_channel_config $::testconfig]] - - set id_err [shellfilter::stack::add stderr ansiwrap -action sink-locked -settings {-colour {red bold}}] - - set exitinfo [shellfilter::run $script {*}$params] - - shellfilter::stack::remove stderr $id_err - - #if {[lindex $exitinfo 0] eq "exitcode"} { - # shellfilter::log::write $shellspy_status_log "do_script returning $exitinfo" - #} - - #jjj - #shellfilter::log::write $shellspy_status_log "do_script raw exitinfo: $exitinfo" - if {[dict exists $exitinfo errorInfo]} { - #strip out the irrelevant info from the errorInfo - we don't want info beyond 'invoked from within' as this is just plumbing related to the script sourcing - set stacktrace [string map [list \r\n \n] [dict get $exitinfo errorInfo]] - set output "" - set tracelines [split $stacktrace \n] - foreach ln $tracelines { - if {[string match "*invoked from within*" $ln]} { - break - } - append output $ln \n - } - set output [string trimright $output \n] - dict set exitinfo errorInfo $output - #jjj - #shellfilter::log::write $shellspy_status_log "do_script simplified exitinfo: $exitinfo" - } - return $exitinfo - } - - proc shellescape {arglist} { - set out [list] - foreach a $arglist { - set a [string map [list \\ \\\\ ] $a] - lappend out $a - } - return $out - } - proc do_shell {shell args} { - variable shellspy_status_log - shellfilter::log::write $shellspy_status_log "do_shell $shell got '$args' [llength $args]" - set args [do_callback $shell {*}$args] - shellfilter::log::write $shellspy_status_log "do_shell $shell xgot '$args'" - set params [do_callback_parameters $shell] - dict set params -teehandle shellspy - - - set params [dict merge $params [get_channel_config $::testconfig]] - - set id_out [shellfilter::stack::add stdout towindows -action sink-aside-locked -junction 1 -settings {}] - - #shells that take -c and need all args passed together as a string - - set exitinfo [shellfilter::run [concat $shell -c [shellescape $args]] {*}$params] - - shellfilter::stack::remove stdout $id_out - - - if {[lindex $exitinfo 0] eq "exitcode"} { - shellfilter::log::write $shellspy_status_log "do_shell $shell returning $exitinfo" - } - return $exitinfo - } - proc do_wsl {distdefault args} { - variable shellspy_status_log - shellfilter::log::write $shellspy_status_log "do_wsl $distdefault got '$args' [llength $args]" - set args [do_callback wsl {*}$args] ;#use dist? - shellfilter::log::write $shellspy_status_log "do_wsl $distdefault xgot '$args'" - set params [do_callback_parameters wsl] - - dict set params -debug 0 - - set params [dict merge $params [get_channel_config $::testconfig]] - - set id_out [shellfilter::stack::add stdout towindows -action sink-aside-locked -junction 1 -settings {}] - - dict set params -teehandle shellspy ;#shellspyout shellspyerr must exist - set exitinfo [shellfilter::run [concat wsl -d $distdefault -e [shellescape $args]] {*}$params] - - - shellfilter::stack::remove stdout $id_out - - - if {[lindex $exitinfo 0] eq "exitcode"} { - shellfilter::log::write $shellspy_status_log "do_wsl $distdefault returning $exitinfo" - } - return $exitinfo - } - - #todo - load these from a callback - set commands [list] - lappend commands [list punkd [list match [list punkd] dispatch [list shellspy::set_punkd] dispatchtype raw dispatchglobal 1 singleopts {any}]] - lappend commands [list punkd [list sub punkdict singleopts {any}]] - - - #'shout' extension (all uppercase) to force use of tclsh as a separate process - #todo - detect various extensions - and use all script-preceding unmatched args as interpreter+options - #e.g perl,php,python etc. - #For tcl will make it easy to test different interpreter output from tclkitsh, tclsh8.6, tclsh8.7 etc - #for now we have a hardcoded default interpreter for tcl as 'tclsh' - todo: get default interps from config - #(or just attempt launch in case there is shebang line in script) - #we may get ambiguity with existing shell match-specs such as -c /c -r. todo - only match those in first slot? - lappend commands [list tclscriptprocess [list match [list {.*\.TCL$} {.*\.TM$} {.*\.TK$}] dispatch [list shellspy::do_script_process [info nameofexecutable] %matched%] dispatchtype raw dispatchglobal 1 singleopts {any}]] - for {set i 0} {$i < 25} {incr i} { - lappend commands [list tclscriptprocess [list sub word$i singleopts {any}]] - } - - #camelcase convention .Tcl script before repl - lappend commands [list tclscriptbeforerepl [list match [list {.*\.Tcl$} {.*\.Tm$} {.*\.Tk$} ] dispatch [list shellspy::do_script %matched% "repl_last"] dispatchtype raw dispatchglobal 1 singleopts {any}]] - for {set i 0} {$i < 25} {incr i} { - lappend commands [list tclscriptbeforerepl [list sub word$i singleopts {any}]] - } - - - #Backwards Camelcase convention .tcL - means repl first, script last - lappend commands [list tclscriptafterrepl [list match [list {.*\.tcL$} {.*\.tM$} {.*\.tK$} ] dispatch [list shellspy::do_script %matched% "repl_first"] dispatchtype raw dispatchglobal 1 singleopts {any}]] - for {set i 0} {$i < 25} {incr i} { - lappend commands [list tclscriptafterrepl [list sub word$i singleopts {any}]] - } - - - #we've already handled .Tcl .tcL, .tCl, .TCL - handle any other capitalisations as a script in this process - lappend commands [list tclscript [list match [list {.*\.tcl$} {.*\.tCL$} {.*\.TCl$} {.*\.tm$} {.*\.tk$} ] dispatch [list shellspy::do_script %matched% "no_repl"] dispatchtype raw dispatchglobal 1 singleopts {any}]] - for {set i 0} {$i < 25} {incr i} { - lappend commands [list tclscript [list sub word$i singleopts {any}]] - } - #%argN% and %argtakeN% can be used as well as %matched% - %argtakeN% will remove from raw and arguments elements of dispatchrecord - lappend commands [list withinterp [list match {^withinterp$} dispatch [list shellspy::do_script_process %argtake0% %argtake1%] dispatchtype raw dispatchglobal 1 singleopts {any} longopts {any} pairopts {any}]] - for {set i 0} {$i < 25} {incr i} { - lappend commands [list withinterp [list sub word$i singleopts {any} longopts {any} pairopts {any}]] - } - - lappend commands [list runcmdfile [list match [list {.*\.cmd$} {.*\.bat$} ] dispatch [list shellspy::do_in_cmdshell %matched%] dispatchtype raw dispatchglobal 1 singleopts {any} longopts {any}]] - for {set i 0} {$i < 25} {incr i} { - lappend commands [list runcmdfile [list sub word$i singleopts {any}]] - } - - lappend commands [list libscript [list match [list {lib:.*$} ] dispatch [list shellspy::do_script %matched% "no_repl"] dispatchtype raw dispatchglobal 1 singleopts {any}]] - for {set i 0} {$i < 25} {incr i} { - lappend commands [list libscript [list sub word$i singleopts {any}]] - } - - lappend commands [list luascriptprocess [list match [list {.*\.lua|Lua|LUA$}] dispatch [list shellspy::do_script_process lua %matched% "no_repl"] dispatchtype raw dispatchglobal 1 singleopts {any}]] - for {set i 0} {$i < 25} {incr i} { - lappend commands [list luascriptprocess [list sub word$i singleopts {any}]] - } - - lappend commands [list phpscriptprocess [list match [list {.*\.php|Php|PHP$}] dispatch [list shellspy::do_script_process php %matched% "no_repl"] dispatchtype raw dispatchglobal 1 singleopts {any}]] - for {set i 0} {$i < 25} {incr i} { - lappend commands [list phpscriptprocess [list sub word$i singleopts {any}]] - } - - lappend commands [list bashraw [list match {^bash$} dispatch [list shellspy::do_shell bash] dispatchtype raw dispatchglobal 1 singleopts {any}]] - for {set i 0} {$i < 25} {incr i} { - lappend commands [list bashraw [list sub word$i singleopts {any}]] - } - lappend commands [list runbash [list match {^shellbash$} dispatch [list shellspy::do_shell bash] dispatchtype shell dispatchglobal 1 singleopts {any}]] - for {set i 0} {$i < 25} {incr i} { - lappend commands [list runbash [list sub word$i singleopts {any}]] - } - - lappend commands {shraw {match {^sh$} dispatch {shellspy::do_shell sh} dispatchtype raw dispatchglobal 1 singleopts {any}}} - for {set i 0} {$i < 25} {incr i} { - lappend commands [list shraw [list sub word$i singleopts {any}]] - } - - lappend commands {runsh {match {^s$} dispatch {shellspy::do_shell sh} dispatchtype shell dispatchglobal 1 singleopts {any}}} - for {set i 0} {$i < 25} {incr i} { - lappend commands [list runsh [list sub word$i singleopts {any}]] - } - - lappend commands {runraw {match {^-r$} dispatch shellspy::do_raw dispatchtype raw dispatchglobal 1 singleopts {any}}} - for {set i 0} {$i < 25} {incr i} { - lappend commands [list runraw [list sub word$i singleopts {any}]] - } - lappend commands {runpwsh {match {^-c$} dispatch shellspy::do_in_powershell dispatchtype raw dispatchglobal 1 singleopts {any}}} - for {set i 0} {$i < 25} {incr i} { - lappend commands [list runpwsh [list sub word$i singleopts {any}]] - } - lappend commands {runpwsht {match {^pwsh$} dispatch shellspy::do_in_powershell_terminal dispatchtype raw dispatchglobal 1 singleopts {any}}} - for {set i 0} {$i < 25} {incr i} { - lappend commands [list runpwsht [list sub word$i singleopts {any}]] - } - - - lappend commands {runcmd {match {^/c$} dispatch shellspy::do_in_cmdshell dispatchtype raw dispatchglobal 1 singleopts {any} longopts {any}}} - for {set i 0} {$i < 25} {incr i} { - lappend commands [list runcmd [list sub word$i singleopts {any}]] - } - lappend commands {runcmduc {match {^/u/c$} dispatch shellspy::do_in_cmdshelluc dispatchtype raw dispatchglobal 1 singleopts {any} longopts {any}}} - for {set i 0} {$i < 25} {incr i} { - lappend commands [list runcmduc [list sub word$i singleopts {any}]] - } - #cmd with bracketed args () e.g with vim shellxquote set to "(" - lappend commands [list runcmdb [list match {^cmdb$} dispatch [list shellspy::do_in_cmdshellb] dispatchtype raw dispatchglobal 1 singleopts {any} longopts {any} pairopts {any}]] - for {set i 0} {$i < 25} {incr i} { - lappend commands [list runcmdb [list sub word$i singleopts {any} longopts {any} pairopts {any}]] - } - - lappend commands [list wslraw [list match {^wsl$} dispatch [list shellspy::do_wsl AlmaLinux9] dispatchtype raw dispatchglobal 1 singleopts {any} longopts {any}]] - for {set i 0} {$i < 25} {incr i} { - lappend commands [list wslraw [list sub word$i singleopts {any}]] - } - - #e.g - # punk -tcl info patch - # punk -tcl eval "package require punk::char;punk::char::charset_page dingbats" - - lappend commands [list tclline [list match [list {^-tcl$}] dispatch [list shellspy::do_tclline tcl] dispatchtype raw dispatchglobal 1 singleopts {any} longopts {any}]] - for {set i 0} {$i < 25} {incr i} { - lappend commands [list tclline [list sub word$i singleopts {any}]] - } - lappend commands [list punkline [list match {^-punk$} dispatch [list shellspy::do_tclline punk] dispatchtype raw dispatchglobal 1 singleopts {any} longopts {any}]] - for {set i 0} {$i < 25} {incr i} { - lappend commands [list punkline [list sub word$i singleopts {any}]] - } - lappend commands [list tkline [list match {^-tk$} dispatch [list shellspy::do_tclline tk] dispatchtype raw dispatchglobal 1 singleopts {any} longopts {any}]] - for {set i 0} {$i < 25} {incr i} { - lappend commands [list tkline [list sub word$i singleopts {any}]] - } - lappend commands [list tkshellline [list match {^-tkshell$} dispatch [list shellspy::do_tclline tkshell] dispatchtype raw dispatchglobal 1 singleopts {any} longopts {any}]] - for {set i 0} {$i < 25} {incr i} { - lappend commands [list tkshellline [list sub word$i singleopts {any}]] - } - lappend commands [list punkshellline [list match {^-punkshell$} dispatch [list shellspy::do_tclline punkshell] dispatchtype raw dispatchglobal 1 singleopts {any} longopts {any}]] - for {set i 0} {$i < 25} {incr i} { - lappend commands [list punkshellline [list sub word$i singleopts {any}]] - } - - - lappend commands [list help [list match [list {^-help$} {^--help$} {^help$} {^/\?}] dispatch [list shellspy::do_help] dispatchtype raw dispatchglobal 1 singleopts {any} longopts {any}]] - for {set i 0} {$i < 25} {incr i} { - lappend commands [list help [list sub word$i singleopts {any}]] - } - ############################################################################################ - - #todo -noexit flag - - - #echo raw args to diverted stderr before running the argument analysis - puts -nonewline stderr "exe:[info nameofexecutable] script:[info script] shellspy-rawargs: $::argv\n" - set i 1 - foreach a $::argv { - puts -nonewline stderr "arg$i: '$a'\n" - incr i - } - - - set argdefinitions [list \ - -caller punkshell_dispatcher \ - -debugargs 0 \ - -debugargsonerror 2 \ - -return all \ - -soloflags {} \ - -defaults [list] \ - -required {none} \ - -extras {all} \ - -commandprocessors $commands \ - -values $::argv ] - - - set is_call_error 0 - set arglist [list] ;#processed args result - contains dispatch info etc. - if {[catch { - set arglist [check_flags {*}$argdefinitions] - } callError]} { - puts -nonewline stderr "|shellspy-stderr> ERROR during command dispatch\n" - puts -nonewline stderr "|shellspy-stderr> $callError\n" - puts -nonewline stderr "|shellspy-stderr> [set ::errorInfo]\n" - - shellfilter::log::write $shellspy_status_log "check_flags error: $callError" - set is_call_error 1 - } else { - shellfilter::log::write $shellspy_status_log "check_flags result: $arglist" - } - - shellfilter::log::write $shellspy_status_log "check_flags dispatch -done- [clock_sec]" - - #puts stdout "sp2. $::argv" - - if {[catch { - set tidyinfo [shellfilter::logtidyup] - } errMsg]} { - - shellfilter::log::open shellspy-error {-tag shellspy-error -syslog $error_syslog_server} - shellfilter::log::write shellspy-error "logtidyup error $errMsg\n [set ::errorInfo]" - after 200 - } - #don't open more logs.. - #puts stdout ">$tidyinfo" - - #lassign [shellfilter::redir_output_to_log "SUPPRESS"] id_stdout_redir id_stderr_redir - catch { - shellfilter::stack::remove stderr $chanstack_stderr_redir - shellfilter::stack::remove stdout $chanstack_stdout_redir - } - - #shellfilter::log::write $shellspy_status_log "logtidyup -done- $tidyinfo" - - catch { - set errorlist [dict get $tidyinfo errors] - if {[llength $errorlist]} { - foreach err $errorlist { - puts -nonewline stderr "|shellspy-final> worker-error-set $err\n" - } - } - } - - #puts stdout "shellspy -done1-" - #flush stdout - - #shellfilter::log::write $shellspy_status_log "shellspy -done-" - - if {[catch { - shellfilter::logtidyup $shellspy_status_log - #puts stdout "shellspy logtidyup done" - #flush stdout - } errMsg]} { - puts stdout "shellspy logtidyup error $errMsg" - flush stdout - shellfilter::log::open shellspy-final {-tag shellspy-final -syslog $error_syslog_server} - shellfilter::log::write shellspy-final "FINAL logtidyup error $errMsg\n [set ::errorInfo]" - after 100 - } - #puts [shellfilter::stack::status shellspyout] - #puts [shellfilter::stack::status shellspyerr] - - #sample dispatch member of $arglist - #dispatch { - # tclscript { - # command {shellspy::do_script %matched% no_repl} - # matched stdout.tcl arguments {} raw {} dispatchtype raw - # asdispatched {shellspy::do_script stdout.tcl no_repl} - # result {result {}} - # error {} - # } - #} - # or - #dispatch { - # tclscript { - # command xxx - # matched error.tcl arguments {} raw {} dispatchtype raw - # asdispatched {shellspy::do_script error.tcl no_repl} - # result { - # error {This is the error} - # errorCode NONE - # errorInfo This\ is\ the\ error\n\ etc - # } - # error {} - # } - #} - - - shellfilter::stack::delete shellspyout - shellfilter::stack::delete shellspyerr - set free_info [shellthread::manager::shutdown_free_threads] - #puts stdout $free_info - #flush stdout - if {[package provide zzzload] ne ""} { - #if zzzload used and not shutdown - we can get deadlock - #puts "zzzload::loader_tid [set ::zzzload::loader_tid]" - #zzzload::shutdown - } - #puts stdout "threads: [thread::names]" - #flush stdout - #puts stdout "calling release on remaining threads" - foreach tid [thread::names] { - thread::release $tid - } - #puts stdout "threads: [thread::names]" - #flush stdout - - - set colour ""; set reset "" - if {$is_call_error} { - catch { - set colour [punk::ansi::a+ yellow bold underline]; set reset [punk::ansi::a] - } - puts stderr $colour$callError$reset - flush stderr - exit 1 - } else { - if {[dict exists $arglist dispatch tclscript result errorInfo]} { - catch { - set colour [punk::ansi::a+ yellow bold]; set reset [punk::ansi::a] - } - set err [dict get $arglist dispatch tclscript result errorInfo] - if {$err ne ""} { - puts stderr $colour$err$reset - flush stderr - exit 1 - } - } - - foreach tclscript_flavour [list tclline punkline punkshellline tkline tkshellline libscript help] { - if {[dict exists $arglist dispatch $tclscript_flavour result error]} { - catch { - set colour [punk::ansi::a+ yellow bold]; set reset [punk::ansi::a] - } - set err [dict get $arglist dispatch $tclscript_flavour result error] - if {$err ne ""} { - puts stderr $colour$err$reset - flush stderr - exit 1 - } - } - } - } - - - if {[dict exists $arglist errorCode]} { - exit [dict get $arglist errorCode] - } - foreach tclscript_flavour [list tclline punkline punkshellline tkline tkshellline libscript help] { - if {[dict exists $arglist dispatch $tclscript_flavour result result]} { - puts -nonewline stdout [dict get $arglist dispatch $tclscript_flavour result result] - exit 0 - } - } - - #if we call exit - package require Tk script files will exit prematurely - #review - #exit 0 -} - -} +#! /usr/bin/env tclsh +# +#copyright 2023 Julian Marcel Noble +#license: BSD (revised 3-clause) +# +#see notes at beginning of shellspy namespace re stdout/stderr +# +#SHELLSPY - provides commandline flag information and stdout/stderr logging/mirroring without output/pipeline interference, +# or modified output if modifying filters explicitly configured. +# +#shellspy uses the shellfilter and flagfilter libraries to run a commandline with tee-diversions of stdout/stderr to configured syslog/file logs +#Because it is a tee, the command's stdout/stderr are still available as direct output from this script. +#Various filters/modifiers/redirections can be placed on the channel stacks for stdin/stderr using the shellfilter::stack api +# and other shellfilter:: helpers such as shellfilter::redir_output_to_log +# Redirecting stderr/stdout in this way prior to the actual command run will not interfere with the command/pipeline output due to the way +# shellfilter temporarily inserts it's own tee into the stack at the point of the highest existing redirection it encounters. +# +#A note on input/output convention regarding channels/pipes +# we write to an output, read from an input. +# e.g when creating a pipe with 'lassign [chan pipe] in out' we write to out and read from in. +# This is potentially confusing from an OO-like perspective thinking of a pipe object as a sort of object. +# Don't think of it from the perspective of the pipe - but from the program using it. +# This is not a convention invented here for shellspy - but it seems to match documentation and common use e.g for 'chan pending input|output chanid' +# This matches the way we write to stdout read from stdin. +# Possibly using read/write related naming for pipe ends is clearer. eg 'lassign [chan pipe] rd_pipe1 wr_pipe1' +# +package provide app-shellspy 1.0 + + +#experiment - todo make a flag for it if it's useful +#Middle cap for direct dispatch without flagcheck arg processing or redirections or REPL. +set arg1 [lindex $::argv 0] +if {[file extension $arg1] in [list .tCl]} { + set ::argv [lrange $::argv 1 end] + set ::argc [llength $::argv] + + set exedir [file dirname [info nameofexecutable]] + set binscripts [file join $exedir scriptlib] + if {[file exists $binscripts]} { + set libdir $binscripts + } else { + set libdir [file join [file dirname $exedir] scriptlib]] + } + set scriptname $arg1 + if {[string match lib:* $scriptname]} { + set scriptname [string range $scriptname 4 end] + set scriptname [string trimleft $scriptname :] ;#incase specified as lib:: + set scriptpath $libdir/$scriptname + } else { + set scriptpath $scriptname + } + set scriptpath [file normalize $scriptpath] + + if {![file exists $scriptpath]} { + #try the lowercase version (extension lowercased only) so that file doesn't have to be renamed to use alternate dispatch + set scriptpath [file rootname $scriptpath][string tolower [file extension $scriptpath]] + } + source $scriptpath + + #package require app-punk + +} else { + + + +#set m_dir [file join $starkit::topdir modules] + + +#catch {package require tcllibc} + +#review. we need thread for when configured to pump info to syslog etc - but it is overhead for simple script calls. +#todo - see if we can avoid loading in certain cases (based on punk::config?) +package require Thread + +package require flagfilter +package require shellfilter +package require punk::ansi +package require punk::packagepreference +punk::packagepreference::install + +#The whole punk infrastructure is overkill for calling arbitrary scripts +#package require punk + +#testing +#package require packageTrace + +set ::testconfig 5 + +namespace eval shellspy { + variable chanstack_stderr_redir + variable chanstack_stdout_redir + + variable commands + proc clock_sec {} { + return [expr {[clock millis]/1000.0}] + } + variable shellspy_status_log "shellspy-[clock micros]" + + #todo - default to no logging not even to local syslog + #load a .toml config which can configure logging as desired + set do_log 0 + if {$do_log} { + set debug_syslog_server 127.0.0.1:514 + #set debug_syslog_server 172.16.6.42:51500 + set error_syslog_server 127.0.0.1:514 + set data_syslog_server 127.0.0.1:514 + } else { + set debug_syslog_server "" + set error_syslog_server "" + set data_syslog_server "" + } + + + + + shellfilter::log::open $shellspy_status_log [list -tag $shellspy_status_log -syslog $debug_syslog_server -file ""] + shellfilter::log::write $shellspy_status_log "shellspy launch with args '$::argv'" + shellfilter::log::write $shellspy_status_log "stdout/stderr encoding: [chan configure stdout -encoding]/[chan configure stderr -encoding]" + + #------------------------------------------------------------------------- + ##don't write to stdout/stderr before you've redirected them to a log using shellfilter functions + ## puts to stdout/stderr will comingle with command's output if performed before the channel stacks are configured. + + chan configure stdin -buffering line + chan configure stdout -buffering none + chan configure stderr -buffering none + + #set id_ansistrip [shellfilter::stack::add stderr ansistrip -settings {}] + #set id_ansistrip [shellfilter::stack::add stdout ansistrip -settings {}] + + #redir on the shellfilter stack with no log or syslog specified acts to suppress output of stdout & stderr. + #todo - fix shellfilter code to make this noop more efficient (avoid creating corresponding logging thread and filter?) + #JMN + #set redirconfig {-settings {-syslog 127.0.0.1:514 -file ""}} + set redirconfig {} + lassign [shellfilter::redir_output_to_log "SUPPRESS" {*}$redirconfig] chanstack_stdout_redir chanstack_stderr_redir + shellfilter::log::write $shellspy_status_log "shellfilter::redir_output_to_log SUPPRESS DONE [clock_sec]" + + + ### + #we can now safely write to stderr/stdout and it will not interfere with stderr/stdout from the dispatched command. + #This is because when shellfilter::run is called it temporarily adds it's own filter in place of the redirection we just added. + # shellfilter::run installs tee_to_pipe on stdout & stderr with -action sink-aside. + # sink-aside means to sink down the filter stack to the topmost filter that is diversionary, and replace it. + # when the command finishes running, the redirecting filter that it displaced is reinstalled in the stack. + ### + + ### + #Note that futher filters installed here will sit 'above' any of the redirecting filters + # so apply to both the shellfilter::run commandline, + # as well as writes to stderr/stdout from here or other libraries operating in this process. + # To bypass the the filter-stack and still emit to syslog etc - + # you can use shellfilter::log::open and shellfilter::log::write e.g + # shellfilter::log::open "mystatuslog" [list -tag "mystatuslog" -syslog 172.16.6.42:51500 -file ""] + # shellfilter::log::write "mystatuslog" "shellspy launch" + # + #### + #set id_ansistrip [shellfilter::stack::add stderr ansistrip -action float -settings {}] + #set id_ansistrip [shellfilter::stack::add stdout ansistrip -action float -settings {}] + + + ##stdin stack operates in reverse compared to stdout/stderr in that first added to stack is first to see the data + ##for stdin: first added to stack is 'upstream' as it will always encounter the data before later ones added to the stack. + ##for stdout: first added to stack is 'downstream' as it will alays encounter the data after others on the stack + #shellfilter::stack::add stdin ansistrip -action {} -settings {} + #shellfilter::stack::add stdin tee_to_log -settings {-tag "input" -raw 1 -syslog 172.16.6.42:51500 -file ""} + + #------------------------------------------------------------------------- + ##note - to use shellfilter::stack::new - the fifo2 end at the local side requires the event loop to be running + ## for interactive testing a relatively simple repl.tcl can be used. + + #todo - default to no logging.. add special flag in checkflags to indicate end of options for matched command only e.g --- ? + # then prioritize these results from checkflags to configure pre-dispatch behaviour by running a predispatch script(?) + # + # we can log flag-processing info coming from checkflags.. but we don't want to do two opt scans and emit it twice. + # configuration of the logging for flag/opt parsing should come from a config file and default to none. + #set stdout_log [file normalize ~]/shellspy-stdout.txt + #set stderr_log [file normalize ~]/shellspy-stderr.txt + set stdout_log "" + set stderr_log "" + + shellfilter::log::write $shellspy_status_log "shellfilter::stack::new shellspyerr ABOUTTO [clock_sec]" + set errdeviceinfo [shellfilter::stack::new shellspyerr -settings [list -tag "shellspyerr" -buffering none -raw 1 -syslog $data_syslog_server -file $stderr_log]] + shellfilter::log::write $shellspy_status_log "shellfilter::stack::new shellspyerr DONE [clock_sec]" + + + shellfilter::log::write $shellspy_status_log "shellfilter::stack::new shellspyout ABOUTTO [clock_sec]" + set outdeviceinfo [shellfilter::stack::new shellspyout -settings [list -tag "shellspyout" -buffering none -raw 1 -syslog $data_syslog_server -file $stdout_log]] + set commandlog [dict get $outdeviceinfo localchan] + #puts $commandlog "HELLO $commandlog" + #flush $commandlog + shellfilter::log::write $shellspy_status_log "shellfilter::stack::new shellspyout DONE [clock_sec]" + + + + #note that this filter is inline with the data teed off to the shellspyout log. + #To filter the main stdout an addition to the stdout stack can be made. specify -action float to have it affect both stdout and the tee'd off data. + set id_ansistrip [shellfilter::stack::add shellspyout ansistrip -settings {}] + shellfilter::log::write $shellspy_status_log "shellfilter::stack::add shellspyout ansistrip DONE [clock_sec]" + + + #set id_out [shellfilter::stack::add stdout rebuffer -settings {}] + + #an example filter to capture some output to a var for later use - this one is for ansible-playbook + #set ::recap "" + #set id_tee_grep [shellfilter::stack::add shellspyout tee_grep_to_var -settings {-grep ".*PLAY RECAP.*|.*fatal:.*|.*changed:.*" -varname ::recap -pre 1 -post 3}] + + namespace import ::flagfilter::check_flags + + namespace eval shellspy::callbacks {} + namespace eval shellspy::parameters {} + + + proc do_callback {func args} { + variable shellspy_status_log + set exedir [file dirname [info nameofexecutable]] + set dispatchtcl [file join $exedir callbacks dispatch.tcl] + if {[file exists $dispatchtcl]} { + source $dispatchtcl + if {[llength [info commands shellspy::callbacks::$func]]} { + shellfilter::log::write $shellspy_status_log "found shellspy::callbacks::$func - calling" + if {[catch { + set args [shellspy::callbacks::$func {*}$args] + } errmsg]} { + shellfilter::log::write $shellspy_status_log "ERROR in shellspy::callbacks::$func\n errormsg:$errmsg" + error $errmsg + } + } + } + return $args + } + proc do_callback_parameters {func args} { + variable shellspy_status_log + set exedir [file dirname [info nameofexecutable]] + set paramtcl [file join $exedir callbacks parameters.tcl] + set params $args + if {[file exists $paramtcl]} { + source $paramtcl + if {[llength [info commands shellspy::parameters::$func]]} { + shellfilter::log::write $shellspy_status_log "found shellspy::parameters::$func - calling" + if {[catch { + set params [shellspy::parameters::$func $params] + } errmsg]} { + shellfilter::log::write $shellspy_status_log "ERROR in shellspy::parameters::$func\n errormsg:$errmsg" + } + } + } + return $params + } + + #some tested configs + proc get_channel_config {config} { + #note tcl script being called from wrong place.. configs don't affect: todo - move it. + set params [dict create] + switch -- $config { + 0 { + #bad for: everything. extra cr + dict set params -inbuffering line + dict set params -outbuffering line + dict set params -readprocesstranslation auto ;#default + dict set params -outtranslation auto + } + 1 { + #ok for: cmd, cmd/u/c,raw,pwsh, sh,raw, tcl script process + #not ok for: bash,wsl, tcl script + dict set params -inbuffering line + dict set params -outbuffering line + dict set params -readprocesstranslation auto ;#default + dict set params -outtranslation lf + } + 2 { + #ok for: cmd, cmd/uc,pwsh,sh , tcl script process + #not ok for: tcl script, bash, wsl + dict set params -inbuffering none ;#default + dict set params -outbuffering none ;#default + dict set params -readprocesstranslation auto ;#default + dict set params -outtranslation lf ;#default + } + 3 { + #ok for: cmd + dict set params -inbuffering line + dict set params -outbuffering line + dict set params -readprocesstranslation lf + dict set params -outtranslation lf + } + 4 { + #ok for: cmd,cmd/uc,raw,sh + #not ok for pwsh,bash,wsl, tcl script, tcl script process + dict set params -inbuffering none + dict set params -outbuffering none + dict set params -readprocesstranslation lf + dict set params -outtranslation lf + } + 5 { + #ok for: pwsh,cmd,cmd/u/c,raw,sh, tcl script process + #not ok for bash,wsl + #ok for vim cmd/u/c but only with to_unix filter on stdout (works in gvim and console) + dict set params -inbuffering none + dict set params -outbuffering none + dict set params -readprocesstranslation crlf + dict set params -outtranslation lf + } + 6 { + #ok for: cmd,cmd/u/c,pwsh,raw,sh,bash + #not ok for: vim with cmd /u/c (?) + dict set params -inbuffering line + dict set params -outbuffering line + dict set params -readprocesstranslation crlf + dict set params -outtranslation lf + } + 7 { + #ok for: sh,bash + #not ok for: wsl (display ok but extra cr), cmd,cmd/u/c,pwsh, tcl script, tcl script process, raw + dict set params -inbuffering none + dict set params -outbuffering none + dict set params -readprocesstranslation crlf + dict set params -outtranslation crlf + } + 8 { + #not ok for anything..all have extra cr + dict set params -inbuffering none + dict set params -outbuffering none + dict set params -readprocesstranslation lf + dict set params -outtranslation crlf + } + } + return $params + } + + proc do_help {args} { + #return [dict create result $::shellspy::commands] + set result "" + foreach cmd $::shellspy::commands { + lassign $cmd tag cmdinfo + if {[lindex $cmdinfo 0] eq "sub"} { + continue + } + if {[dict exists $cmdinfo match]} { + append result "$tag [dict get $cmdinfo match]" \n + } + } + return [dict create result $result] + } + + + #punk86 -tk example: + # punk86 -tk eval "button .tk.b -text doit -command {set ::punkapp::result(shell) guiresult;punkapp::close_window .tk}; pack .tk.b;return somedefaultvalue" + proc do_tclline {flavour args} { + variable chanstack_stderr_redir + variable chanstack_stdout_redir + + if {$flavour in [list "punk" "punkshell"]} { + namespace eval :: {package require punk;package require shellrun} + } elseif {$flavour in [list "tk" "tkshell"]} { + namespace eval :: { + package require Tk + package require punkapp + punkapp::hide_dot_window + toplevel .tk + if {[wm protocol . WM_DELETE_WINDOW] eq ""} { + wm protocol . WM_DELETE_WINDOW [list punkapp::close_window .] + } + wm protocol .tk WM_DELETE_WINDOW [list punkapp::close_window .tk] + } + } + #remove SUPPRESS redirection if it was in place so that shell output is visible + catch { + shellfilter::stack::remove stderr $chanstack_stderr_redir + shellfilter::stack::remove stdout $chanstack_stdout_redir + } + set result_is_error 0 + if {[catch {apply [list {arglist} {namespace eval :: $arglist} ::] $args} result]} { + set result_is_error 1 + } + if {$flavour in [list "punkshell" "tkshell"]} { + set result [namespace eval :: [string map [list %e% $chanstack_stderr_redir %o% $chanstack_stdout_redir %r% $result] { + package require punk + package require shellrun + package require punk::repl + puts stdout "quit to exit" + repl::init -safe 0 + repl::start stdin -defaultresult %r% + }]] + } + + #todo - better exit? + if {$result_is_error} { + if {$flavour eq "tk"} { + return [dict create error [namespace eval :: [list punkapp::wait -defaultresult $result]]] + #todo - better return value e.g from dialog? + } + return [dict create error $result] + } else { + if {$flavour eq "tk"} { + return [dict create result [namespace eval :: [list punkapp::wait -defaultresult $result]]] + #todo - better return value e.g from dialog? + } + return [dict create result $result] + } + } + proc set_punkd {args} { + variable shellspy_status_log + shellfilter::log::write $shellspy_status_log "set_punkd got '$args'" + + set punkd_status_log "set_punkd_log" + shellfilter::log::open $punkd_status_log [list -tag $punkd_status_log -syslog 127.0.0.1:514 -file ""] + shellfilter::log::write $punkd_status_log "set_punkd got '$args'" + return [dict create result ok] + } + + proc do_in_powershell {args} { + variable shellspy_status_log + shellfilter::log::write $shellspy_status_log "do_in_powershell got '$args'" + set args [do_callback powershell {*}$args] + set params [do_callback_parameters powershell] + dict set params -teehandle shellspy + + + #readprocesstranslation lf - doesn't work for buffering line or none + #readprocesstranslation crlf works for buffering line and none with outchantranslation lf + + set params [dict merge $params [get_channel_config $::testconfig]] ;#working: 5 unbuffered, 6 linebuffered + + + dict set params -debug 1 + dict set params -timeout 1000 + + #set exitinfo [shellfilter::run [list pwsh -nologo -noprofile -c {*}$args] -debug 1] + + + set id_err [shellfilter::stack::add stderr ansiwrap -action sink -settings {-colour {red bold}}] + set exitinfo [shellfilter::run [list pwsh -nologo -noprofile -c {*}$args] {*}$params] + shellfilter::stack::remove stderr $id_err + + #Passing args in as a single element will tend to make powershell treat the args as a 'script block' + # (powershell sees items in curly brackets {} as a scriptblock - when called from non-powershell, this tends to just echo back the contents) + #set exitinfo [shellfilter::run [list pwsh -nologo -noprofile -c $args] {*}$params] + if {[lindex $exitinfo 0] eq "exitcode"} { + shellfilter::log::write $shellspy_status_log "do_in_powershell returning $exitinfo" + #exit [lindex $exitinfo 1] + } + return $exitinfo + } + proc do_in_powershell_terminal {args} { + variable shellspy_status_log + shellfilter::log::write $shellspy_status_log "do_in_powershell_terminal got '$args'" + set args [do_callback powershell {*}$args] + set params [do_callback_parameters powershell] + dict set params -teehandle shellspy + set params [dict merge $params [get_channel_config $::testconfig]] ;#working: 5 unbuffered, 6 linebuffered + + #set cmdlist [list pwsh -nologo -noprofile -c {*}$args] + set cmdlist [list pwsh -nologo -c {*}$args] + #the big problem with using the 'script' command is that we get stderr/stdout mashed together. + + #set cmdlist [shellfilter::get_scriptrun_from_cmdlist_dquote_if_not $cmdlist] + shellfilter::log::write $shellspy_status_log "do_in_powershell_terminal as script: '$cmdlist'" + + set id_err [shellfilter::stack::add stderr ansiwrap -action sink -settings {-colour {red bold}}] + set exitinfo [shellfilter::run $cmdlist {*}$params] + shellfilter::stack::remove stderr $id_err + + if {[lindex $exitinfo 0] eq "exitcode"} { + shellfilter::log::write $shellspy_status_log "do_in_powershell_terminal returning $exitinfo" + } + return $exitinfo + } + + + proc do_in_cmdshell {args} { + variable shellspy_status_log + shellfilter::log::write $shellspy_status_log "do_in_cmdshell got '$args'" + set args [do_callback cmdshell {*}$args] + set params [do_callback_parameters cmdshell] + + + dict set params -teehandle shellspy + dict set params -copytempfile 1 + + set params [dict merge $params [get_channel_config $::testconfig]] + + #set id_out [shellfilter::stack::add stdout tounix -action sink-locked -settings {}] + set id_err [shellfilter::stack::add stderr ansiwrap -action sink-locked -settings {-colour {red bold}}] + + #set exitinfo [shellfilter::run "cmd /c $args" -debug 1] + set exitinfo [shellfilter::run [list cmd /c {*}$args] {*}$params] + #set exitinfo [shellfilter::run [list cmd /c {*}$args] -debug 1] + + shellfilter::stack::remove stderr $id_err + + #shellfilter::stack::remove stdout $id_out + + shellfilter::log::write $shellspy_status_log "do_in_cmdshell raw exitinfo: $exitinfo" + + + if {[lindex $exitinfo 0] eq "exitcode"} { + #exit [lindex $exitinfo 1] + #shellfilter::log::write $shellspy_status_log "do_in_cmdshell returning $exitinfo" + #puts stderr "do_in_cmdshell returning $exitinfo" + } + return $exitinfo + } + proc do_in_cmdshellb {args} { + + variable shellspy_status_log + shellfilter::log::write $shellspy_status_log "do_in_cmdshellb got '$args'" + + set args [do_callback cmdshellb {*}$args] + + + shellfilter::log::write $shellspy_status_log "do_in_cmdshellb post_callback args '$args'" + + set params [do_callback_parameters cmdshellb] + dict set params -teehandle shellspy + dict set params -copytempfile 1 + dict set params -debug 0 + + #----------------------------- + #channel config 6 and towindows sink-aside-locked {-junction 1} works with vim-flog + #----------------------------- + set params [dict merge $params [get_channel_config 6]] + #set id_out [shellfilter::stack::add stdout tounix -action sink-aside-locked -junction 1 -settings {}] + + + set exitinfo [shellfilter::run [list cmd /u/c {*}$args] {*}$params] + + #shellfilter::stack::remove stdout $id_out + + if {[lindex $exitinfo 0] eq "exitcode"} { + shellfilter::log::write $shellspy_status_log "do_in_cmdshellb returning with exitcode $exitinfo" + } else { + shellfilter::log::write $shellspy_status_log "do_in_cmdshellb returning WITHOUT exitcode $exitinfo" + } + return $exitinfo + } + proc do_in_cmdshelluc {args} { + variable shellspy_status_log + shellfilter::log::write $shellspy_status_log "do_in_cmdshelluc got '$args'" + set args [do_callback cmdshelluc {*}$args] + set params [do_callback_parameters cmdshell] + #set exitinfo [shellfilter::run "cmd /c $args" -debug 1] + dict set params -teehandle shellspy + dict set params -copytempfile 1 + dict set params -debug 0 + + #set params [dict merge $params [get_channel_config $::testconfig]] + + set params [dict merge $params [get_channel_config 1]] + #set id_out [shellfilter::stack::add stdout tounix -action sink-locked -settings {}] + + set id_out [shellfilter::stack::add stdout tounix -action sink-locked -settings {}] + + set exitinfo [shellfilter::run [list cmd /u/c {*}$args] {*}$params] + shellfilter::stack::remove stdout $id_out + #chan configure stdout -translation crlf + + if {[lindex $exitinfo 0] eq "exitcode"} { + #exit [lindex $exitinfo 1] + shellfilter::log::write $shellspy_status_log "do_in_cmdshelluc returning $exitinfo" + #puts stderr "do_in_cmdshell returning $exitinfo" + } + return $exitinfo + } + proc do_raw {args} { + variable shellspy_status_log + shellfilter::log::write $shellspy_status_log "do_raw got '$args'" + set args [do_callback raw {*}$args] + set params [do_callback_parameters raw] + #set params {} + dict set params -debug 0 + #dict set params -outprefix "_test_" + dict set params -teehandle shellspy + + + set params [dict merge $params [get_channel_config $::testconfig]] + + + if {[llength $params]} { + set exitinfo [shellfilter::run $args {*}$params] + } else { + set exitinfo [shellfilter::run $args -debug 1 -outprefix "j"] + } + if {[lindex $exitinfo 0] eq "exitcode"} { + shellfilter::log::write $shellspy_status_log "do_raw returning $exitinfo" + } + return $exitinfo + } + + proc do_script_process {scriptbin scriptname args} { + variable shellspy_status_log + if {$scriptbin eq "withinterp.word0"} { + set scriptbin $scriptname + set scriptname [lindex $args 0] + set args [lrange $args 1 end] + } + shellfilter::log::write $shellspy_status_log "do_script_process got scriptname:'$scriptname' args:'$args'" + #no script_process callbacks + #set args [do_callback script_process {*}$args] + #set params [do_callback_parameters script_process] + dict set params -teehandle shellspy + + set params [dict merge $params [get_channel_config $::testconfig]] + + set exedir [file dirname [info nameofexecutable]] + if {[file exists $exedir/scriptlib]} { + set libroot $exedir/scriptlib + } else { + set libroot [file dirname $exedir]/scriptlib + } + if {[string match lib:* $scriptname]} { + set scriptname [string range $scriptname 4 end] + set scriptname [string trimleft $scriptname :] ;#incase specified as lib:: + set scriptpath $libroot/$scriptname + } else { + set scriptpath $scriptname + } + set scriptpath [file normalize $scriptpath] + if {![file exists $scriptpath]} { + if {[file extension $scriptpath] eq ""} { + set scriptpath $scriptpath.tcl + } else { + set scriptpath [file rootname $scriptpath][string tolower [file extension $scriptpath]] + } + if {![file exists $scriptpath]} { + puts stderr "Failed to find script: '$scriptpath'" + error "bad scriptpath '$scriptpath' arguments: $scriptbin $scriptname $args" + } + } + + + + #set id_err [shellfilter::stack::add stderr ansiwrap -action sink-locked -settings {-colour {red bold}}] + + + + #todo - use glob to check capitalisation of file tail (.TCL vs .tcl .Tcl etc) + set exitinfo [shellfilter::run [concat [auto_execok $scriptbin] $scriptpath $args] {*}$params] + shellfilter::log::write $shellspy_status_log "do_script_process exitinfo: $exitinfo" + + #shellfilter::stack::remove stderr $id_err + + #if {[lindex $exitinfo 0] eq "exitcode"} { + # shellfilter::log::write $shellspy_status_log "do_script_process returning $exitinfo" + #} + #if {[dict exists $exitinfo errorCode]} { + # exit [dict get $exitinfo $errorCode] + #} + return $exitinfo + } + + proc do_tclkit {kitname replwhen args} { + puts stderr "app-shellspy: do_tclkit $kitname $replwhen $args" + flush stderr + + set script [string map [list %a% $args %k% $kitname] { +#::tcl::tm::add %m% +set kit %k% +set kitpath [file normalize $kit] +set kitmount $kitpath.0 + +#save values +set prevscript [info script] +set prevglobal [dict create] +foreach g [list ::argv ::argc ::argv0] { + if {[info exists $g]} { + dict set prevglobal $g [set $g] + } +} + +#setup and run +set ::argv [list %a%] +set ::argc [llength $::argv] + +set ::argv0 $kitmount +#puts stderr "setting 'info script' $kitmount/main.tcl" +info script $kitmount/main.tcl +#info script dir must match argv0 for kit main.tcl to return 'starkit' from 'starkit::startup' + +if {![catch { + package require vfs + package require vfs::mk4 + } errMsg]} { + + vfs::mk4::Mount $kitpath $kitmount + lappend ::auto_path $kitmount/lib + if {[file exists "$kitmount/modules"]} { + tcl::tm::add "$kitmount/modules" + } + + #puts stderr "sourcing $kitmount/main.tcl" + #puts stderr "$kitmount/main.tcl exists: [file exists $kitmount/main.tcl]" + #puts stderr "argv : $::argv" + #puts stderr "argv0: $::argv0" + #puts stderr "autopath: $::auto_path" + #puts stdout "starkit::startup [starkit::startup]" + + #usually main.tcl will just be something like: package require app-XXX + #it will usually do nothing if starkit::startup returned 'sourced' + + source $kitmount/main.tcl + +} else { + puts stderr "Unable to load vfs::mk4 for tclkit mounting" +} +#restore values +info script $prevscript +dict with prevglobal {} + }] + + set repl_lines "" + append repl_lines {package require punk::repl} \n + append repl_lines {repl::init -safe 0} \n + append repl_lines {repl::start stdin} \n + + #test + #set replwhen "repl_last" + + if {$replwhen eq "repl_first"} { + #we need to cooperate with the repl to get the script to run on exit + namespace eval ::repl {} + set ::repl::post_script $script + set script "$repl_lines" + } elseif {$replwhen eq "repl_last"} { + append script $repl_lines + } else { + #just the script + } + + dict set params -tclscript 1 ;#don't give callback a chance to omit/break this + dict set params -teehandle shellspy + + + set params [dict merge $params [get_channel_config $::testconfig]] + + set id_err [shellfilter::stack::add stderr ansiwrap -action sink-locked -settings {-colour {red bold}}] + + set exitinfo [shellfilter::run $script {*}$params] + + shellfilter::stack::remove stderr $id_err + + if {[dict exists $exitinfo errorInfo]} { + #strip out the irrelevant info from the errorInfo - we don't want info beyond 'invoked from within' as this is just plumbing related to the script sourcing + set stacktrace [string map [list \r\n \n] [dict get $exitinfo errorInfo]] + set output "" + set tracelines [split $stacktrace \n] + foreach ln $tracelines { + if {[string match "*invoked from within*" $ln]} { + break + } + append output $ln \n + } + set output [string trimright $output \n] + dict set exitinfo errorInfo $output + } + return $exitinfo + } + + proc do_script {scriptname replwhen args} { + #ideally we don't want to launch an external process to run the script + variable shellspy_status_log + #shellfilter::log::write $shellspy_status_log "do_script got scriptname:'$scriptname' replwhen:$replwhen args:'$args'" + set exepath [file dirname [file join [info nameofexecutable] __dummy__]] + set exedir [file dirname $exepath] + + if {[file tail $exedir] eq "bin"} { + set basedir [file dirname $exedir] + } else { + set basedir $exedir + } + set libroot [file join $basedir scriptlib] + if {[string match lib:* $scriptname]} { + set scriptname [string range $scriptname 4 end] + set scriptname [string trimleft $scriptname :] ;#incase specified as lib:: + set scriptpath $libroot/$scriptname + } else { + set scriptpath $scriptname + } + set scriptpath [file normalize $scriptpath] + if {![file exists $scriptpath]} { + if {[file extension $scriptpath] eq ""} { + set scriptpath $scriptpath.tcl + } else { + set scriptpath [file rootname $scriptpath][string tolower [file extension $scriptpath]] + } + if {![file exists $scriptpath]} { + puts stderr "Failed to find script: '$scriptpath'" + error "bad scriptpath '$scriptpath'" + } + } + set modulesdir $basedir/modules + + set script [string map [list %a% $args %s% $scriptpath %m% $modulesdir] { +#::tcl::tm::add %m% +set scriptname %s% +set normscript [file normalize $scriptname] + +#save values +set prevscript [info script] +set prevglobal [dict create] +foreach g [list ::argv ::argc ::argv0] { + if {[info exists $g]} { + dict set prevglobal $g [set $g] + } +} + +#setup and run +set ::argv [list %a%] +set ::argc [llength $::argv] +set ::argv0 $normscript +info script $normscript +source $normscript + +#restore values +info script $prevscript +dict with prevglobal {} + }] + + set repl_lines "" + #append repl_lines {puts stderr "starting repl [chan names]"} \n + #append repl_lines {puts stderr "stdin [chan configure stdin]"} \n + append repl_lines {package require punk::repl} \n + append repl_lines {repl::init -safe 0} \n + append repl_lines {repl::start stdin} \n + + #append repl_lines {puts stdout "shutdown message"} \n + + if {$replwhen eq "repl_first"} { + #we need to cooperate with the repl to get the script to run on exit + namespace eval ::repl {} + set ::repl::post_script $script + set script "$repl_lines" + } elseif {$replwhen eq "repl_last"} { + append script $repl_lines + } else { + #just the script + } + + #no script callbacks + #set args [do_callback script {*}$args] + #set params [do_callback_parameters script] + + dict set params -tclscript 1 ;#don't give callback a chance to omit/break this + dict set params -teehandle shellspy + #dict set params -teehandle punksh + + + set params [dict merge $params [get_channel_config $::testconfig]] + + set id_err [shellfilter::stack::add stderr ansiwrap -action sink-locked -settings {-colour {red bold}}] + + set exitinfo [shellfilter::run $script {*}$params] + + shellfilter::stack::remove stderr $id_err + + #if {[lindex $exitinfo 0] eq "exitcode"} { + # shellfilter::log::write $shellspy_status_log "do_script returning $exitinfo" + #} + + #jjj + #shellfilter::log::write $shellspy_status_log "do_script raw exitinfo: $exitinfo" + if {[dict exists $exitinfo errorInfo]} { + #strip out the irrelevant info from the errorInfo - we don't want info beyond 'invoked from within' as this is just plumbing related to the script sourcing + set stacktrace [string map [list \r\n \n] [dict get $exitinfo errorInfo]] + set output "" + set tracelines [split $stacktrace \n] + foreach ln $tracelines { + if {[string match "*invoked from within*" $ln]} { + break + } + append output $ln \n + } + set output [string trimright $output \n] + dict set exitinfo errorInfo $output + #jjj + #shellfilter::log::write $shellspy_status_log "do_script simplified exitinfo: $exitinfo" + } + return $exitinfo + } + + proc shellescape {arglist} { + set out [list] + foreach a $arglist { + set a [string map [list \\ \\\\ ] $a] + lappend out $a + } + return $out + } + proc do_shell {shell args} { + variable shellspy_status_log + shellfilter::log::write $shellspy_status_log "do_shell $shell got '$args' [llength $args]" + set args [do_callback $shell {*}$args] + shellfilter::log::write $shellspy_status_log "do_shell $shell xgot '$args'" + set params [do_callback_parameters $shell] + dict set params -teehandle shellspy + + + set params [dict merge $params [get_channel_config $::testconfig]] + + set id_out [shellfilter::stack::add stdout towindows -action sink-aside-locked -junction 1 -settings {}] + + #shells that take -c and need all args passed together as a string + + set exitinfo [shellfilter::run [concat $shell -c [shellescape $args]] {*}$params] + + shellfilter::stack::remove stdout $id_out + + + if {[lindex $exitinfo 0] eq "exitcode"} { + shellfilter::log::write $shellspy_status_log "do_shell $shell returning $exitinfo" + } + return $exitinfo + } + proc do_wsl {distdefault args} { + variable shellspy_status_log + shellfilter::log::write $shellspy_status_log "do_wsl $distdefault got '$args' [llength $args]" + set args [do_callback wsl {*}$args] ;#use dist? + shellfilter::log::write $shellspy_status_log "do_wsl $distdefault xgot '$args'" + set params [do_callback_parameters wsl] + + dict set params -debug 0 + + set params [dict merge $params [get_channel_config $::testconfig]] + + set id_out [shellfilter::stack::add stdout towindows -action sink-aside-locked -junction 1 -settings {}] + + dict set params -teehandle shellspy ;#shellspyout shellspyerr must exist + set exitinfo [shellfilter::run [concat wsl -d $distdefault -e [shellescape $args]] {*}$params] + + + shellfilter::stack::remove stdout $id_out + + + if {[lindex $exitinfo 0] eq "exitcode"} { + shellfilter::log::write $shellspy_status_log "do_wsl $distdefault returning $exitinfo" + } + return $exitinfo + } + + #todo - load these from a callback + set commands [list] + lappend commands [list punkd [list match [list punkd] dispatch [list shellspy::set_punkd] dispatchtype raw dispatchglobal 1 singleopts {any}]] + lappend commands [list punkd [list sub punkdict singleopts {any}]] + + + #'shout' extension (all uppercase) to force use of tclsh as a separate process + #todo - detect various extensions - and use all script-preceding unmatched args as interpreter+options + #e.g perl,php,python etc. + #For tcl will make it easy to test different interpreter output from tclkitsh, tclsh8.6, tclsh8.7 etc + #for now we have a hardcoded default interpreter for tcl as 'tclsh' - todo: get default interps from config + #(or just attempt launch in case there is shebang line in script) + #we may get ambiguity with existing shell match-specs such as -c /c -r. todo - only match those in first slot? + lappend commands [list tclscriptprocess [list match [list {.*\.TCL$} {.*\.TM$} {.*\.TK$}] dispatch [list shellspy::do_script_process [info nameofexecutable] %matched%] dispatchtype raw dispatchglobal 1 singleopts {any}]] + for {set i 0} {$i < 25} {incr i} { + lappend commands [list tclscriptprocess [list sub word$i singleopts {any}]] + } + + #camelcase convention .Tcl script before repl + lappend commands [list tclscriptbeforerepl [list match [list {.*\.Tcl$} {.*\.Tm$} {.*\.Tk$} ] dispatch [list shellspy::do_script %matched% "repl_last"] dispatchtype raw dispatchglobal 1 singleopts {any}]] + for {set i 0} {$i < 25} {incr i} { + lappend commands [list tclscriptbeforerepl [list sub word$i singleopts {any}]] + } + + + #Backwards Camelcase convention .tcL - means repl first, script last + lappend commands [list tclscriptafterrepl [list match [list {.*\.tcL$} {.*\.tM$} {.*\.tK$} ] dispatch [list shellspy::do_script %matched% "repl_first"] dispatchtype raw dispatchglobal 1 singleopts {any}]] + for {set i 0} {$i < 25} {incr i} { + lappend commands [list tclscriptafterrepl [list sub word$i singleopts {any}]] + } + + + #we've already handled .Tcl .tcL, .tCl, .TCL - handle any other capitalisations as a script in this process + lappend commands [list tclscript [list match [list {.*\.tcl$} {.*\.tCL$} {.*\.TCl$} {.*\.tm$} {.*\.tk$} ] dispatch [list shellspy::do_script %matched% "no_repl"] dispatchtype raw dispatchglobal 1 singleopts {any}]] + for {set i 0} {$i < 25} {incr i} { + lappend commands [list tclscript [list sub word$i singleopts {any}]] + } + + lappend commands [list tclkit [list match [list {.*\.kit$}] dispatch [list shellspy::do_tclkit %matched% "no_repl"] dispatchtype raw dispatchglobal 1 singleopts {any}]] + for {set i 0} {$i < 25} {incr i} { + lappend commands [list tclkit [list sub word$i singleopts {any}]] + } + + #%argN% and %argtakeN% can be used as well as %matched% - %argtakeN% will remove from raw and arguments elements of dispatchrecord + lappend commands [list withinterp [list match {^withinterp$} dispatch [list shellspy::do_script_process %argtake0% %argtake1%] dispatchtype raw dispatchglobal 1 singleopts {any} longopts {any} pairopts {any}]] + for {set i 0} {$i < 25} {incr i} { + lappend commands [list withinterp [list sub word$i singleopts {any} longopts {any} pairopts {any}]] + } + + lappend commands [list runcmdfile [list match [list {.*\.cmd$} {.*\.bat$} ] dispatch [list shellspy::do_in_cmdshell %matched%] dispatchtype raw dispatchglobal 1 singleopts {any} longopts {any}]] + for {set i 0} {$i < 25} {incr i} { + lappend commands [list runcmdfile [list sub word$i singleopts {any}]] + } + + lappend commands [list libscript [list match [list {lib:.*$} ] dispatch [list shellspy::do_script %matched% "no_repl"] dispatchtype raw dispatchglobal 1 singleopts {any}]] + for {set i 0} {$i < 25} {incr i} { + lappend commands [list libscript [list sub word$i singleopts {any}]] + } + + lappend commands [list luascriptprocess [list match [list {.*\.lua|Lua|LUA$}] dispatch [list shellspy::do_script_process lua %matched% "no_repl"] dispatchtype raw dispatchglobal 1 singleopts {any}]] + for {set i 0} {$i < 25} {incr i} { + lappend commands [list luascriptprocess [list sub word$i singleopts {any}]] + } + + lappend commands [list phpscriptprocess [list match [list {.*\.php|Php|PHP$}] dispatch [list shellspy::do_script_process php %matched% "no_repl"] dispatchtype raw dispatchglobal 1 singleopts {any}]] + for {set i 0} {$i < 25} {incr i} { + lappend commands [list phpscriptprocess [list sub word$i singleopts {any}]] + } + + lappend commands [list bashraw [list match {^bash$} dispatch [list shellspy::do_shell bash] dispatchtype raw dispatchglobal 1 singleopts {any}]] + for {set i 0} {$i < 25} {incr i} { + lappend commands [list bashraw [list sub word$i singleopts {any}]] + } + lappend commands [list runbash [list match {^shellbash$} dispatch [list shellspy::do_shell bash] dispatchtype shell dispatchglobal 1 singleopts {any}]] + for {set i 0} {$i < 25} {incr i} { + lappend commands [list runbash [list sub word$i singleopts {any}]] + } + + lappend commands {shraw {match {^sh$} dispatch {shellspy::do_shell sh} dispatchtype raw dispatchglobal 1 singleopts {any}}} + for {set i 0} {$i < 25} {incr i} { + lappend commands [list shraw [list sub word$i singleopts {any}]] + } + + lappend commands {runsh {match {^s$} dispatch {shellspy::do_shell sh} dispatchtype shell dispatchglobal 1 singleopts {any}}} + for {set i 0} {$i < 25} {incr i} { + lappend commands [list runsh [list sub word$i singleopts {any}]] + } + + lappend commands {runraw {match {^-r$} dispatch shellspy::do_raw dispatchtype raw dispatchglobal 1 singleopts {any}}} + for {set i 0} {$i < 25} {incr i} { + lappend commands [list runraw [list sub word$i singleopts {any}]] + } + lappend commands {runpwsh {match {^-c$} dispatch shellspy::do_in_powershell dispatchtype raw dispatchglobal 1 singleopts {any}}} + for {set i 0} {$i < 25} {incr i} { + lappend commands [list runpwsh [list sub word$i singleopts {any}]] + } + lappend commands {runpwsht {match {^pwsh$} dispatch shellspy::do_in_powershell_terminal dispatchtype raw dispatchglobal 1 singleopts {any}}} + for {set i 0} {$i < 25} {incr i} { + lappend commands [list runpwsht [list sub word$i singleopts {any}]] + } + + + lappend commands {runcmd {match {^/c$} dispatch shellspy::do_in_cmdshell dispatchtype raw dispatchglobal 1 singleopts {any} longopts {any}}} + for {set i 0} {$i < 25} {incr i} { + lappend commands [list runcmd [list sub word$i singleopts {any}]] + } + lappend commands {runcmduc {match {^/u/c$} dispatch shellspy::do_in_cmdshelluc dispatchtype raw dispatchglobal 1 singleopts {any} longopts {any}}} + for {set i 0} {$i < 25} {incr i} { + lappend commands [list runcmduc [list sub word$i singleopts {any}]] + } + #cmd with bracketed args () e.g with vim shellxquote set to "(" + lappend commands [list runcmdb [list match {^cmdb$} dispatch [list shellspy::do_in_cmdshellb] dispatchtype raw dispatchglobal 1 singleopts {any} longopts {any} pairopts {any}]] + for {set i 0} {$i < 25} {incr i} { + lappend commands [list runcmdb [list sub word$i singleopts {any} longopts {any} pairopts {any}]] + } + + lappend commands [list wslraw [list match {^wsl$} dispatch [list shellspy::do_wsl AlmaLinux9] dispatchtype raw dispatchglobal 1 singleopts {any} longopts {any}]] + for {set i 0} {$i < 25} {incr i} { + lappend commands [list wslraw [list sub word$i singleopts {any}]] + } + + #e.g + # punk -tcl info patch + # punk -tcl eval "package require punk::char;punk::char::charset_page dingbats" + + lappend commands [list tclline [list match [list {^-tcl$}] dispatch [list shellspy::do_tclline tcl] dispatchtype raw dispatchglobal 1 singleopts {any} longopts {any}]] + for {set i 0} {$i < 25} {incr i} { + lappend commands [list tclline [list sub word$i singleopts {any}]] + } + lappend commands [list punkline [list match {^-punk$} dispatch [list shellspy::do_tclline punk] dispatchtype raw dispatchglobal 1 singleopts {any} longopts {any}]] + for {set i 0} {$i < 25} {incr i} { + lappend commands [list punkline [list sub word$i singleopts {any}]] + } + lappend commands [list tkline [list match {^-tk$} dispatch [list shellspy::do_tclline tk] dispatchtype raw dispatchglobal 1 singleopts {any} longopts {any}]] + for {set i 0} {$i < 25} {incr i} { + lappend commands [list tkline [list sub word$i singleopts {any}]] + } + lappend commands [list tkshellline [list match {^-tkshell$} dispatch [list shellspy::do_tclline tkshell] dispatchtype raw dispatchglobal 1 singleopts {any} longopts {any}]] + for {set i 0} {$i < 25} {incr i} { + lappend commands [list tkshellline [list sub word$i singleopts {any}]] + } + lappend commands [list punkshellline [list match {^-punkshell$} dispatch [list shellspy::do_tclline punkshell] dispatchtype raw dispatchglobal 1 singleopts {any} longopts {any}]] + for {set i 0} {$i < 25} {incr i} { + lappend commands [list punkshellline [list sub word$i singleopts {any}]] + } + + + lappend commands [list help [list match [list {^-help$} {^--help$} {^help$} {^/\?}] dispatch [list shellspy::do_help] dispatchtype raw dispatchglobal 1 singleopts {any} longopts {any}]] + for {set i 0} {$i < 25} {incr i} { + lappend commands [list help [list sub word$i singleopts {any}]] + } + ############################################################################################ + + #todo -noexit flag + + + #echo raw args to diverted stderr before running the argument analysis + puts -nonewline stderr "exe:[info nameofexecutable] script:[info script] shellspy-rawargs: $::argv\n" + set i 1 + foreach a $::argv { + puts -nonewline stderr "arg$i: '$a'\n" + incr i + } + + + set argdefinitions [list \ + -caller punkshell_dispatcher \ + -debugargs 0 \ + -debugargsonerror 2 \ + -return all \ + -soloflags {} \ + -defaults [list] \ + -required {none} \ + -extras {all} \ + -commandprocessors $commands \ + -values $::argv ] + + + set is_call_error 0 + set arglist [list] ;#processed args result - contains dispatch info etc. + if {[catch { + set arglist [check_flags {*}$argdefinitions] + } callError]} { + puts -nonewline stderr "|shellspy-stderr> ERROR during command dispatch\n" + puts -nonewline stderr "|shellspy-stderr> $callError\n" + puts -nonewline stderr "|shellspy-stderr> [set ::errorInfo]\n" + + shellfilter::log::write $shellspy_status_log "check_flags error: $callError" + set is_call_error 1 + } else { + shellfilter::log::write $shellspy_status_log "check_flags result: $arglist" + } + + shellfilter::log::write $shellspy_status_log "check_flags dispatch -done- [clock_sec]" + + #puts stdout "sp2. $::argv" + + if {[catch { + set tidyinfo [shellfilter::logtidyup] + } errMsg]} { + + shellfilter::log::open shellspy-error {-tag shellspy-error -syslog $error_syslog_server} + shellfilter::log::write shellspy-error "logtidyup error $errMsg\n [set ::errorInfo]" + after 200 + } + #don't open more logs.. + #puts stdout ">$tidyinfo" + + #lassign [shellfilter::redir_output_to_log "SUPPRESS"] id_stdout_redir id_stderr_redir + catch { + shellfilter::stack::remove stderr $chanstack_stderr_redir + shellfilter::stack::remove stdout $chanstack_stdout_redir + } + + #shellfilter::log::write $shellspy_status_log "logtidyup -done- $tidyinfo" + + catch { + set errorlist [dict get $tidyinfo errors] + if {[llength $errorlist]} { + foreach err $errorlist { + puts -nonewline stderr "|shellspy-final> worker-error-set $err\n" + } + } + } + + #puts stdout "shellspy -done1-" + #flush stdout + + #shellfilter::log::write $shellspy_status_log "shellspy -done-" + + if {[catch { + shellfilter::logtidyup $shellspy_status_log + #puts stdout "shellspy logtidyup done" + #flush stdout + } errMsg]} { + puts stdout "shellspy logtidyup error $errMsg" + flush stdout + shellfilter::log::open shellspy-final {-tag shellspy-final -syslog $error_syslog_server} + shellfilter::log::write shellspy-final "FINAL logtidyup error $errMsg\n [set ::errorInfo]" + after 100 + } + #puts [shellfilter::stack::status shellspyout] + #puts [shellfilter::stack::status shellspyerr] + + #sample dispatch member of $arglist + #dispatch { + # tclscript { + # command {shellspy::do_script %matched% no_repl} + # matched stdout.tcl arguments {} raw {} dispatchtype raw + # asdispatched {shellspy::do_script stdout.tcl no_repl} + # result {result {}} + # error {} + # } + #} + # or + #dispatch { + # tclscript { + # command xxx + # matched error.tcl arguments {} raw {} dispatchtype raw + # asdispatched {shellspy::do_script error.tcl no_repl} + # result { + # error {This is the error} + # errorCode NONE + # errorInfo This\ is\ the\ error\n\ etc + # } + # error {} + # } + #} + + + shellfilter::stack::delete shellspyout + shellfilter::stack::delete shellspyerr + set free_info [shellthread::manager::shutdown_free_threads] + #puts stdout $free_info + #flush stdout + if {[package provide zzzload] ne ""} { + #if zzzload used and not shutdown - we can get deadlock + #puts "zzzload::loader_tid [set ::zzzload::loader_tid]" + #zzzload::shutdown + } + #puts stdout "threads: [thread::names]" + #flush stdout + #puts stdout "calling release on remaining threads" + foreach tid [thread::names] { + thread::release $tid + } + #puts stdout "threads: [thread::names]" + #flush stdout + + + set colour ""; set reset "" + if {$is_call_error} { + catch { + set colour [punk::ansi::a+ yellow bold underline]; set reset [punk::ansi::a] + } + puts stderr $colour$callError$reset + flush stderr + exit 1 + } else { + if {[dict exists $arglist dispatch tclscript result errorInfo]} { + catch { + set colour [punk::ansi::a+ yellow bold]; set reset [punk::ansi::a] + } + set err [dict get $arglist dispatch tclscript result errorInfo] + if {$err ne ""} { + puts stderr $colour$err$reset + flush stderr + exit 1 + } + } + + foreach tclscript_flavour [list tclline tclkit punkline punkshellline tkline tkshellline libscript help] { + if {[dict exists $arglist dispatch $tclscript_flavour result error]} { + catch { + set colour [punk::ansi::a+ yellow bold]; set reset [punk::ansi::a] + } + set err [dict get $arglist dispatch $tclscript_flavour result error] + if {$err ne ""} { + puts stderr $colour$err$reset + flush stderr + exit 1 + } + } + } + } + + + if {[dict exists $arglist errorCode]} { + exit [dict get $arglist errorCode] + } + foreach tclscript_flavour [list tclline tclkit punkline punkshellline tkline tkshellline libscript help] { + if {[dict exists $arglist dispatch $tclscript_flavour result result]} { + puts -nonewline stdout [dict get $arglist dispatch $tclscript_flavour result result] + exit 0 + } + } + + #if we call exit - package require Tk script files will exit prematurely + #review + #exit 0 +} + +} diff --git a/src/make.tcl b/src/make.tcl index 2efa1453..1736d3d9 100644 --- a/src/make.tcl +++ b/src/make.tcl @@ -3028,8 +3028,9 @@ foreach vfstail $vfs_tails { kit { if {!$have_sdx} { puts stderr "no sdx available to unwrap $targetkit" - lappend failed_kits [list kit $targetkit reason "sdx_executable_unavailable"] + #don't add to failed_kits here #extraction fail for one type doesn't mean we have fully failed yet + #lappend failed_kits [list kit $targetkit reason "sdx_executable_unavailable"] #$vfs_event targetset_end FAILED #$vfs_event destroy #$vfs_installer destroy @@ -3074,8 +3075,10 @@ foreach vfstail $vfs_tails { if {!$extraction_done} { #TODO: if not extracted - use a default tcl_library for patchlevel and platform? - puts stderr "WARNING: No extraction done from runtime $runtime_fullname" + puts stderr "--------------------------------------------" + puts stderr "\x1b\31mWARNING: No extraction done from runtime $runtime_fullname\x1b\[m" puts stderr "If no init.tcl provided in the vfs at the proper location (containing init.tcl) - the resulting kit will probably not initialise properly!" + puts stderr "--------------------------------------------" file mkdir $targetvfs } diff --git a/src/modules/flagfilter-0.3.tm b/src/modules/flagfilter-999999.0a1.0.tm similarity index 99% rename from src/modules/flagfilter-0.3.tm rename to src/modules/flagfilter-999999.0a1.0.tm index 00f58e82..b5b0bb7b 100644 --- a/src/modules/flagfilter-0.3.tm +++ b/src/modules/flagfilter-999999.0a1.0.tm @@ -1,8 +1,3 @@ -#package provide flagfilter [namespace eval flagfilter {list [variable version 0.2.3]$version}] -#package provide [set ::pkg flagfilter-0.2.3] [namespace eval [lindex [split $pkg -] 0] {list [variable version [lindex [split $pkg -] 1][set ::pkg {}]]$version}] -# -#package provide [lindex [set pkg {flagfilter 0.2.3}] 0] [namespace eval [lindex $pkg 0] {list [variable version [lindex $pkg 1][set pkg {}]]$version}] -package provide [lassign {flagfilter 0.3} pkg ver]$pkg [namespace eval $pkg[set pkg {}] {list [variable version $::ver[set ::ver {}]]$version}] #Note: this is ugly.. particularly when trying to classify flags that are not fully specified i.e raw passthrough. # - we can't know if a flag -x --x etc is expecting a parameter or not. @@ -2185,6 +2180,7 @@ namespace eval flagfilter { set raise_dispatch_error_instead_of_return "" set dict_dispatch_results [list dispatchstatuslist [list] dispatchresultlist [list] dispatchstatus "ok"] #todo - only dispatch if no unallocated args (must get tail_processor to allocate known flags to 'global') + if {[llength $dispatch]} { set dispatchstatuslist [list] set dispatchresultlist [list] @@ -2334,7 +2330,10 @@ namespace eval flagfilter { set commandline [concat $command $matched_in_order $extraflags] } } - + + + + dict set dispatchrecord asdispatched $commandline set dispatchresult "" set dispatcherror "" @@ -2711,6 +2710,8 @@ namespace eval flagfilter { } +package provide [lassign {flagfilter 999999.0a1.0} pkg ver]$pkg [namespace eval $pkg[set pkg {}] {list [variable version $::ver[set ::ver {}]]$version}] + diff --git a/src/modules/flagfilter-buildversion.txt b/src/modules/flagfilter-buildversion.txt new file mode 100644 index 00000000..87e0a7a9 --- /dev/null +++ b/src/modules/flagfilter-buildversion.txt @@ -0,0 +1,3 @@ +0.3.1 +#First line must be a tm version number +#all other lines are ignored. \ No newline at end of file diff --git a/src/modules/punk/char-999999.0a1.0.tm b/src/modules/punk/char-999999.0a1.0.tm index b2274c94..b59a3550 100644 --- a/src/modules/punk/char-999999.0a1.0.tm +++ b/src/modules/punk/char-999999.0a1.0.tm @@ -186,8 +186,9 @@ tcl::namespace::eval punk::char { set r [list "" {*}[split $lowbits ""] $ridx {*}$charlist] $t add_row $r } - puts stderr $t - $t print + set result [$t print] + $t destroy + return $result } #just the 7-bit ascii. use [page ascii] for the 8-bit layout diff --git a/src/modules/punk/mix/templates/utility/scriptappwrappers/multishell.cmd b/src/modules/punk/mix/templates/utility/scriptappwrappers/multishell.cmd index 392d400f..7bfca8d4 100644 --- a/src/modules/punk/mix/templates/utility/scriptappwrappers/multishell.cmd +++ b/src/modules/punk/mix/templates/utility/scriptappwrappers/multishell.cmd @@ -1,4 +1,4 @@ -: "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^ +: "punk MULTISHELL - shebangless polyglot for Tcl Perl sh bash cmd pwsh powershell" + "[rename set S;proc Hide shell_not_supported {proc $shell_not_supported 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 + \ @@ -16,6 +16,70 @@ set -- "$@" "a=[Hide <#;Hide set;S 1 list]"; set -- : "$@";$1 = @' @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 ------------------------------------------------------------------------------------------------------------------------------- +@rem return from endlocal macro - courtesy of jeb +@rem This allows return of values containing special characters from subroutines +@rem https://stackoverflow.com/questions/3262287/make-an-environment-variable-survive-endlocal/8257951#8257951 +@rem ------------------------------------------------------------------------------------------------------------------------------- +@setlocal DisableDelayedExpansion +@echo off +%= 2 blank lines after next are required =% +set LF=^ + + +set ^"\n=^^^%LF%%LF%^%LF%%LF%^^" +%= I use EDE for EnableDelayeExpansion and DDE for DisableDelayedExpansion =% +set ^"endlocal=for %%# in (1 2) do if %%#==2 (%\n% + setlocal EnableDelayedExpansion%\n% + %= Take all variable names into the varName array =%%\n% + set varName_count=0%\n% + for %%C in (!args!) do set "varName[!varName_count!]=%%~C" ^& set /a varName_count+=1%\n% + %= Build one variable with a list of set statements for each variable delimited by newlines =%%\n% + %= The lists looks like --> set result1=myContent\n"set result1=myContent1"\nset result2=content2\nset result2=content2\n =%%\n% + %= Each result exists two times, the first for the case returning to DDE, the second for EDE =%%\n% + %= The correct line will be detected by the (missing) enclosing quotes =%%\n% + set "retContent=1!LF!"%\n% + for /L %%n in (0 1 !varName_count!) do (%\n% + for /F "delims=" %%C in ("!varName[%%n]!") DO (%\n% + set "content=!%%C!"%\n% + set "retContent=!retContent!"set !varName[%%n]!=!content!"!LF!"%\n% + if defined content (%\n% + %= This complex block is only for replacing '!' with '^!' =%%\n% + %= First replacing '"'->'""q' '^'->'^^' =%%\n% + set ^"content_EDE=!content:"=""q!"%\n% + set "content_EDE=!content_EDE:^=^^!"%\n% + %= Now it's poosible to use CALL SET and replace '!'->'""e!' =%%\n% + call set "content_EDE=%%content_EDE:^!=""e^!%%"%\n% + %= Now it's possible to replace '""e' to '^', this is effectivly '!' -> '^!' =%%\n% + set "content_EDE=!content_EDE:""e=^!"%\n% + %= Now restore the quotes =%%\n% + set ^"content_EDE=!content_EDE:""q="!"%\n% + ) ELSE set "content_EDE="%\n% + set "retContent=!retContent!set "!varName[%%n]!=!content_EDE!"!LF!"%\n% + )%\n% + )%\n% + %= Now return all variables from retContent over the barrier =%%\n% + for /F "delims=" %%V in ("!retContent!") DO (%\n% + %= Only the first line can contain a single 1 =%%\n% + if "%%V"=="1" (%\n% + %= We need to call endlocal twice, as there is one more setlocal in the macro itself =%%\n% + endlocal%\n% + endlocal%\n% + ) ELSE (%\n% + %= This is true in EDE =%%\n% + if "!"=="" (%\n% + if %%V==%%~V (%\n% + %%V !%\n% + )%\n% + ) ELSE IF not %%V==%%~V (%\n% + %%~V%\n% + )%\n% + )%\n% + )%\n% + ) else set args=" + +@rem ------------------------------------------------------------------------------------------------------------------------------- +@SETLOCAL EnableExtensions EnableDelayedExpansion @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 @@ -24,7 +88,6 @@ set -- "$@" "a=[Hide <#;Hide set;S 1 list]"; set -- : "$@";$1 = @' @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 @@ -51,8 +114,6 @@ set -- "$@" "a=[Hide <#;Hide set;S 1 list]"; set -- : "$@";$1 = @' : <> @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 @@ -73,7 +134,7 @@ set -- "$@" "a=[Hide <#;Hide set;S 1 list]"; set -- : "$@";$1 = @' @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 -- deck scriptwrap.checkfile filepath @REM -- to check your templates or final wrapped scripts for byte boundary issues @REM -- It will report any labels that are on boundaries @REM -- This is why the nextshell value above is a 2 digit key instead of a string - so that editing the value doesn't change the byte offsets. @@ -83,12 +144,13 @@ set -- "$@" "a=[Hide <#;Hide set;S 1 list]"; set -- : "$@";$1 = @' @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 -- 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 "winpath=%~dp0" %= e.g c:\punkshell\bin\ %= @SET "fname=%~nx0" +@SET "scriptrootname=%~dp0%~n0" %= e.g c:\punkshell\bin\runtime (full path without extension) unavailable after shift, so store it =% @REM @ECHO fname %fname% @REM @ECHO winpath %winpath% @REM @ECHO commandlineascalled %0 @@ -123,17 +185,6 @@ set -- "$@" "a=[Hide <#;Hide set;S 1 list]"; set -- : "$@";$1 = @' @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 ) @@ -178,25 +229,101 @@ set -- "$@" "a=[Hide <#;Hide set;S 1 list]"; set -- : "$@";$1 = @' @IF "!selected_shelltype_trimmed!"=="none" ( SET selected_shelltype_trimmed=pwsh ) + + + + +@set argCount=30 +@rem This is the max number of args we are willing to handle. also bounded by approx 8k char limit of cmd.exe +@rem We do not loop over %* to count args as it is brittle for some inputs e.g will always skip cmd.exe separators e.g comma and semicolon +@rem Set argCount higher if desired, but there is a small amount of additional looping overhead. + +@set tmpfile_base=%TEMP%\punkbatch_params +@call :getUniqueFile %tmpfile_base% ".txt" paramfile +@echo %paramfile% + +%= NOTE when we loop like this using the percent-n args, we lose unquoted separators such as comma and semicolon %= +@rem https://stackoverflow.com/questions/26551/how-can-i-pass-arguments-to-a-batch-file/5493124#5493124 +@rem outer loop required to redirect all rem lines at once to file +@for %%x in (1) do @( + @for /L %%f in (1,1,%argCount%) do @( + @set "argnum=%%~nf" + @set "a1=%%1" + @rem @set "argname=%%!argnum!" + @rem @echo argname: !argname! + @call :rem_output !argnum! !a1! + @shift + ) +) > %paramfile% +@echo off + +@set "newcommandline= " + +@(set target=cmd_pwsh) +@if "%target%"=="cmd_pwsh" ( + @for /F "delims=" %%L in (%paramfile%) do @( + SETLOCAL DisableDelayedExpansion + set "param=%%L" + @REM @echo ######### %%L + @rem call :buildcmdline newcommandline param "{" "}" + @rem call :buildcmdline newcommandline param ' ' %= cmd.exe /c powershell ... -c %= + call :buildcmdline newcommandline param %= cmd.exe /c powershell ... -f %= + @rem @echo . + ) +) ELSE ( + @for /F "delims=" %%L in (%paramfile%) do @( + SETLOCAL DisableDelayedExpansion + set "param=%%L" + call :buildcmdline newcommandline param + ) +) +@REM padding +SETLOCAL EnableDelayedExpansion + +@echo off +@IF EXIST %paramfile% ( + @DEL /F /Q %paramfile% +) +@IF EXIST %paramfile% ( + echo failed to delete %paramfile% + cat %paramfile% +) + + + +@REM @SET "squoted_args=" +@REM @for %%a in (%*) do @( +@REM set "v=%%a" +@REM set "v=!v:'=''!" +@REM SET "squoted_args=!squoted_args!'!v!' " +@REM ) +@REM @SET "squoted_args=%squoted_args:~0,-1%" +@REM @ECHO %squoted_args% + + @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 + REM when run without cmd.exe - pwsh will receive the semicolon (for cmd.exe unquoted semicolon and comma are separators that aren't seen in positional arguments) 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% + @rem pwsh -nop -nol -c set-executionpolicy -Scope Process Unrestricted; "%scriptrootname%.ps1" %arglist% + @rem pwsh -nop -nol -c set-executionpolicy -Scope Process Unrestricted + cmd /c pwsh -nop -nol -ExecutionPolicy bypass -f "%scriptrootname%.ps1" !newcommandline! 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% + @rem powershell -nop -nol -ExecutionPolicy Bypass -c "%scriptrootname%.ps1" %arglist% + cmd /c powershell -nop -nol -ExecutionPolicy Bypass -f "%scriptrootname%.ps1" !newcommandline! SET task_exitcode=!errorlevel! ) ) ELSE ( IF "!selected_shelltype_trimmed!"=="powershell" ( - powershell -nop -nol -ExecutionPolicy Bypass -c "%~dp0%~n0.ps1" %arglist% + @rem powershell -nop -nol -ExecutionPolicy Bypass -c "%scriptrootname%.ps1" %arglist% + cmd /c powershell -nop -nol -ExecutionPolicy Bypass -f "%scriptrootname%.ps1" !newcommandline! SET task_exitcode=!errorlevel! ) ELSE ( IF "!selected_shelltype_trimmed!"=="wslbash" ( @@ -211,7 +338,7 @@ set -- "$@" "a=[Hide <#;Hide set;S 1 list]"; set -- : "$@";$1 = @' 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; + %selected_shellpath_trimmed% "%winpath%%fname%" %arglist% & SET task_exitcode=!errorlevel! & Call; ) ELSE ( ECHO %fname% has invalid nextshelltype value %selected_shelltype% valid options are %validshelltypes% SET task_exitcode=66 @@ -222,9 +349,145 @@ set -- "$@" "a=[Hide <#;Hide set;S 1 list]"; set -- : "$@";$1 = @' ) ) @REM batch file library functions -@REM boundary padding + @GOTO :endlib +@REM padding +@REM padding +@REM padding + +%= ---------------------------------------------------------------------- =% +@rem courtesy of dbenham +:: Example usage +@rem call :getUniqueFile "d:\test\myFile" ".txt" myFile +@rem echo myFile="%myFile%" + +:getUniqueFile baseName extension rtnVar +setlocal +:getUniqueFileLoop +for /f "skip=1" %%A in ('wmic os get localDateTime') do for %%B in (%%A) do set "rtn=%~1_%%B%~2" +if exist "%rtn%" ( + goto :getUniqueFileLoop +) else ( + 2>nul >nul (9>"%rtn%" timeout /nobreak 1) || goto :getUniqueFileLoop +) +endlocal & set "%~3=%rtn%" +exit /b +%= ---------------------------------------------------------------------- =% + +@REM padding +:buildcmdline cmdlinevar paramvar wrapA wrapB + %= quoting for cmd.exe /c pwsh -nop !args! =% + @SETLOCAL EnableDelayedExpansion + + @REM @echo ===================== + set "pval=!%~2:*#=!" + set "pval=!pval:~0,-2!" + @REM set "pval=!pval:~0,-1!" + set "wrapa=%~3" + set "wrapb=%~4" + + @call :strlen pval slen + @rem @echo strlen: !slen! + if "!slen!"=="0" ( + goto :eof + ) + @set /A n = !slen! - 1 + @(set str=) + @set "dq="" + @set "bang=^!" + @(set carat=^^) + @for /l %%i in (0,1,!n!) do @( + (set c=!pval:~%%i,1!) + if "!c!"=="|" ( + set "ch=^^!pval:~%%i,1!" + ) ELSE IF "!c!"=="(" ( + set "ch=^(" + ) ELSE if "!c!"==")" ( + set "ch=^)" + ) ELSE if "!c!"=="&" ( + set "ch=^^&" + ) ELSE if "!c!"=="!dq!" ( + set "ch=^"" + ) ELSE if "!c!"=="!bang!" ( + @rem - double caret - first for initial parsing, second to ensure remains escaped during delayed expansion phase + @rem - REVIEW + set "ch=^^!bang!" + ) ELSE if "!c!"=="^carat" ( + set "ch=^^^^" + ) ELSE if "!c!"=="'" ( + set "ch=''" + ) ELSE ( + set "ch=!c!" + ) + @rem @echo - !ch! + set "str=!str!!ch!" + ) + echo +++++ %~1 = !%1! !str! + + set "%~1=!%1! !wrapa!!str!!wrapb!" + + @rem old method of return - failes to preserve exclamation marks + @rem for /f "delims=" %%A in (""!str!"") do endlocal & set "%~1=!%1! '%%~A'" + @rem macro method of endlocal return - preserving !val! + @echo off + %endlocal% %~1 + + @exit /b + +:rem_output + @rem --------------------------------------------- + @rem rem_output is called for each n in the number of args we process - as we don't have a non-destructive way to count args whilst accepting special chars + @rem we therefore need a way to stop processing on the last received arg so we don't write argCount entries to param.txt if less are received + @rem see 'disappearing quotes' technique + @rem https://stackoverflow.com/questions/4643376/how-to-split-double-quoted-line-into-multiple-lines-in-windows-batch-file/4645113#4645113 + @rem and + @rem https://groups.google.com/g/alt.msdos.batch.nt/c/J71F17Bve9Y (sponge belly) + @echo off + setlocal enableextensions disabledelayedexpansion + set "param1=%~2" + rem do must not be indented + for %%^" in ("") ^ +do if not defined param1 set %%~"param1=%2%%~" + if not defined param1 goto :eof + endlocal + @rem --------------------------------------------- + + @PROMPT @ + @echo on + rem %1 #%2# +@exit /b + +@REM courtesy of: https://stackoverflow.com/users/463115/jeb +:strlen stringVar returnVar +@( + setlocal EnableDelayedExpansion + @SET "rtrn=%~2" + (set^ tmp=!%~1!) + @rem @echo jjjjj !tmp! + @if defined tmp ( + set "len=1" + @for %%P in (4096 2048 1024 512 256 128 64 32 16 8 4 2 1) do @( + @if "!tmp:~%%P,1!" NEQ "" ( + set /a "len+=%%P" + set "tmp=!tmp:~%%P!" + ) + ) + ) ELSE ( + set len=0 + ) +) +@( + endlocal + @IF "%~2" neq "" ( + @SET "%rtrn%=%len%" + ) ELSE ( + @ECHO :strlen result: %len% + ) + exit /b +) + + :getWslPath @SETLOCAL @SET "_path=%~p1" @@ -280,7 +543,7 @@ set -- "$@" "a=[Hide <#;Hide set;S 1 list]"; set -- : "$@";$1 = @' ) ) @EXIT /B -@REM boundary padding +@REM boundary padding @REM boundary padding :getNormalizedScriptTail @SETLOCAL @@ -295,13 +558,12 @@ set -- "$@" "a=[Hide <#;Hide set;S 1 list]"; set -- : "$@";$1 = @' ) @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 +: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' @SETLOCAL @CALL :stringContains %~1 "\" hasBackSlash @CALL :stringContains %~1 "/" hasForwardSlash @@ -327,6 +589,10 @@ set -- "$@" "a=[Hide <#;Hide set;S 1 list]"; set -- : "$@";$1 = @' ) @EXIT /B +@REM boundary padding +@REM boundary padding +@REM boundary padding + :stringContains @REM usage: @CALL:stringContains string needle returnvarname @SETLOCAL @@ -348,7 +614,7 @@ set -- "$@" "a=[Hide <#;Hide set;S 1 list]"; set -- : "$@";$1 = @' @EXIT /B @REM boundary padding @REM boundary padding -:stringToUpper +:stringToUpper strvar returnvar @SETLOCAL @SET "rtrn=%~2" @SET "string=%~1" @@ -384,6 +650,11 @@ set -- "$@" "a=[Hide <#;Hide set;S 1 list]"; set -- : "$@";$1 = @' @EXIT /B @REM boundary padding @REM boundary padding +@REM boundary padding +@REM boundary padding +@REM boundary padding +@REM boundary padding +@REM boundary padding :stringTrimTrailingUnderscores @SETLOCAL @SET "rtrn=%~2" @@ -442,12 +713,104 @@ set -- "$@" "a=[Hide <#;Hide set;S 1 list]"; set -- : "$@";$1 = @' # -- 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 +# -- e.g ./scriptname.cmd in sh or zsh or bash +# -- e.g tclsh scriptname.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 '@ +#--------------------------------------------------------------------- +#divert to configured nextshell +package require platform +set plat_full [platform::generic] +set plat [lindex [split $plat_full -] 0] +#may be old tcl - not assuming readFile available +set fd [open [info script] r] +set scriptdata [read $fd] +close $fd +set scriptdata [string map [list \r\n \n] $scriptdata] +set in_data 0 +set nextshellpath "" +set nextshelltype "" +puts stderr "PLAT: $plat" +foreach ln [split $scriptdata \n] { + if {[string trim $ln] eq ""} {continue} + if {!$in_data} { + if {[string match ": <>*" $ln]} { + set in_data 1 + } + } else { + if {[string match "*@SET*nextshellpath?${plat}_*" $ln]} { + set lineparts [split $ln =] + set tail [lindex $lineparts 1] + set nextshellpath [string trimright $tail {_"}] + if {$nextshellpath ne "" && $nextshelltype ne ""} { + break + } + } elseif {[string match "*@SET*nextshelltype?${plat}_*" $ln]} { + set lineparts [split $ln =] + set tail [lindex $lineparts 1] + set nextshelltype [string trimright $tail {_"}] + if {$nextshellpath ne "" && $nextshelltype ne ""} { + break + } + } elseif {[string match ": <>*" $ln]} { + break + } + } +} +if {$nextshelltype ne "tcl" && $nextshelltype ne "none"} { + if {$nextshelltype in "pwsh powershell"} { + set scrname [file rootname [info script]].ps1 + set arglist [list] + foreach a $::argv { + set a "'$a'" + lappend arglist $a + } + } else { + set scrname [info script] + set arglist $::argv + } + puts stdout "tclsh launching subshell of type: $nextshelltype shellpath: $nextshellpath on script $scrname with args: $arglist" + #todo - handle /usr/bin/env + #todo - exitcode + if {[llength $nextshellpath] == 1 && [string index $nextshellpath 0] eq {"} && [string index $nextshellpath end] eq {"}} { + set nextshell_words [list $nextshellpath] + } else { + set nextshell_words $nextshellpath + } + set ns_firstword [lindex $nextshellpath 0] + if {[string index $ns_firstword 0] eq {"} && [string index $ns_firstword end] eq {"}} { + set ns_firstword [string range $ns_firstword 1 end-1] + } + + if {[string match {/*/env} $ns_firstword] && $::tcl_platform(platform) ne "windows"} { + set exec_part $nextshellpath + } else { + set epath [auto_execok $ns_firstword] + if {$epath eq ""} { + error "unable to find executable path for first word '$ns_firstword' of nextshellpath '$nextshellpath'" + } else { + set exec_part [list {*}$epath {*}[lrange $nextshellpath 1 end]] + } + } + catch {exec {*}$exec_part $scrname {*}$arglist <@stdin >@stdout 2>@stderr} emsg eopts + + if {[dict exists $eopts -errorcode]} { + set ecode [dict get $eopts -errorcode] + if {[lindex $ecode 0] eq "CHILDSTATUS"} { + exit [lindex $ecode 2] + } else { + puts stderr "error calling next shell $nextshelltype :" + puts stderr $emsg + exit 1 + } + } else { + exit 0 + } +} +#--------------------------------------------------------------------- + namespace eval ::punk::multishell { set last_script_root [file dirname [file normalize ${::argv0}/__]] set last_script [file dirname [file normalize [info script]/__]] @@ -481,7 +844,7 @@ namespace eval ::punk::multishell { # -- --- --- --- --- --- --- --- --- --- --- --- # -puts stderr "No tcl code for this script. Try another program such as perl or bash" +puts stderr "No tcl code for this script. Try another program such as zsh or bash or perl" # # @@ -512,21 +875,26 @@ if {[::punk::multishell::is_main]} { # -- --- --- --- --- --- --- --- --- --- --- --- --- ---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}" - +# Be wary of any non-trivial sed/awk etc - can be brittle to maintain across linux,freebsd,macosx due to differing implementations \ +echo "var0: $0 @: $@" +# echo "script: `echo $0 | sed 's/^-//'`" +# use oldschool backticks and sed - lowest common denominator \ +# echo "shell: " `ps -p $$ | awk '$1 != "PID" {print $(NF)}' | tr -d '()' | sed -E 's/^.*\/|^-//'` +# zsh diversion \ +# if [[ "$argv[*]" != "[*]" ]]; then /usr/bin/env bash "$0" "${argv[@]:2:$((${#argv[@]}-2))}"; exit $?; fi +# \ +ps_shellname=`ps -p $$ | awk '$1 != "PID" {print $(NF)}' | tr -d '()' | sed -E 's/^.*\/|^-//'` +# \ +echo "shell from ps: $ps_shellname argc: ${#@} inner: ${@:2:$((${#@}-2))}" +# non-bash-like diversion \ +if [[ "$ps_shellname" != "bash" && "$ps_shellname" != "zsh" ]]; then /usr/bin/env bash "$0" "${@:2:$((${#@}-2))}"; exit $?; fi +# sh/bash (or zsh?) \ +shift && set -- "${@:1:$((${#@}-1))}" +# \ #echo "shell:" `ps -o args= $$ | sed -E 's/^.*\/|^-//' | awk '{print $1}'` -#------------------------------------------------------ +# \ +echo "args: $@" +# ------------------------------------------------------ # -- This if block only needed if Tcl didn't exit or return above. if false==false # else { then @@ -541,20 +909,30 @@ if false==false # else { # -- # ## ### ### ### ### ### ### ### ### ### ### ### ### ### -if [[ "$OSTYPE" == "linux"* ]]; then +plat=$(uname -s) #platform/system +if [[ "$plat" = "Linux"* ]]; then os="linux" -elif [[ "$OSTYPE" == "darwin"* ]]; then +elif [[ "$plat" == "Darwin"* ]]; then os="macosx" -elif [[ "$OSTYPE" == "freebsd"* ]]; then +elif [[ "$plat" == "FreeBSD"* ]]; then os="freebsd" -elif [[ "$OSTYPE" == "dragonflybsd"* ]]; then +elif [[ "$plat" == "DragonFly"* ]]; then os="dragonflybsd" -elif [[ "$OSTYPE" == "netbsd"* ]]; then +elif [[ "$plat" == "NetBSD"* ]]; then os="netbsd" -elif [[ "$OSTYPE" == "win32" ]]; then +elif [[ "$plat" == "OpenBSD"* ]]; then + os="openbsd" +elif [[ "$plat" = "MINGW32"* ]]; then + os="win32" +elif [[ "$plat" = "MINGW64"* ]]; then os="win32" -elif [[ "$OSTYPE" == "msys" ]]; then +elif [[ "$plat" = "CYGWIN_NT"* ]]; then + os="win32" +elif [[ "$plat" == "MSYS_NT"* ]]; then + #review.. echo MSYS + #win32 binaries - but e.g tclsh installed in msys reports ::tcl_platform(platform) as 'unix' + #bash reports $OSTYPE msys os="win32" #review - need ps/sed/awk to determine shell? interp = `ps -p $$ | awk '$1 != "PID" {print $(NF)}' | tr -d '()' | sed -E 's/^.*\/|^-//'` @@ -564,37 +942,50 @@ elif [[ "$OSTYPE" == "msys" ]]; then #"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}}" +elif [[ "$OSTYPE" == "win32" ]]; then + os="win32" 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" +## This is the sort of sed that will not work across implementations +## shellconfiglines=$( sed -n "/: <>/{:a;n;/: <>/q;p;ba}" "$0" | grep $os) +#awk tested on linux & freebsd +shellconfiglines=$( awk '/^:.*<>.*$/,/^:.*<>.*$/' "$0" | grep $os) +# echo $shellconfiglines; +# readarray requires bash 4.0 +if [[ "$ps_shellname" == "bash" ]]; then + readarray -t arr_oslines <<<"$shellconfiglines" +elif [[ "$ps_shellname" == "zsh" ]]; then + arr_oslines=("${(f)shellconfiglines}") else - echo "unable to find config for os $os" - echo "shellconfigline: $shellconfigline" - nextshellpath="" - nextshelltype="" + #fallback - doesn't seem to work in zsh - untested in early bash + IFS=$'\n' arr_oslines=($shellconfiglines) fi +nextshellpath="" +nextshelltype="" +for ln in "${arr_oslines[@]}"; do + # echo "---- $ln" + if [[ "$ln" == *"nextshellpath"* ]]; then + splitln="${ln#*=}" #remove everything through the first '=' + pathraw="${splitln%%\"*}" #take everything before the quote - use %% to get longest match + #remove trailing underscores (% means must match at end) + nextshellpath="${pathraw/%_*/}" + echo "nextshellpath: $nextshellpath" + elif [[ "$ln" == *"nextshelltype"* ]]; then + splitln="${ln#*=}" + typeraw="${splitln%%\"*}" + nextshelltype="${typeraw/%_*/}" + echo "nextshelltype: $nextshelltype" + fi +done + 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" "$@" + echo bash launching subshell of type: $nextshelltype shellpath: $nextshellpath on "$0" with args "$@" + #e.g /usr/bin/env tclsh "$0" "$@" ${nextshellpath} "$0" "$@" exitcode=$? @@ -792,18 +1183,18 @@ 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 -#"Powershell Version: {0}" -f $PSVersionTable.PSVersion.Major | write-host -#"powershell args : {0}" -f ($args -join ", ") | 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 # -- --- --- --- +$thisfileContent = Get-Content $scriptname -Raw $startTag = ": <>" $endTag = ": <>" -$fileContent = Get-Content $scriptname -Raw -$pattern = "(?s)$startTag(.*?)$endTag" -$matches = [regex]::Matches($fileContent,$pattern) -$admininfo = $matches[0].Groups[1].Value +$pattern = "(?s)`n$startTag[^`n]*`n(.*?)`n$endTag" +$match = [regex]::Match($thisfileContent,$pattern) $asadmin = 0 -if ($matches.count) { +if ($match.Success) { + $admininfo = $match.Groups[1].Value $asadmin = $admininfo.Contains("asadmin=1") if ($asadmin) { if (-not ([Security.Principal.WindowsPrincipal][Security.Principal.WindowsIdentity]::GetCurrent()).IsInRole([Security.Principal.WindowsBuiltInRole]::Administrator)) { @@ -821,10 +1212,72 @@ if ($matches.count) { } } } +# +$startTag = ": <>" +$endTag = ": <>" +$pattern = "(?s)`n$startTag[^`n]*`n(.*?)`n$endTag" +$match = [regex]::Match($thisfileContent,$pattern) +if ($match.Success) { + $plat = [System.Environment]::OSVersion.Platform + if ($plat -eq "Unix") { + $runtime_ident = [System.Runtime.InteropServices.RuntimeInformation]::RuntimeIdentifier + switch ($runtime_ident.split("-")[0]) { + "freebsd" { + # untested + $os = "freebsd" + } + "linux" { + $os = "linux" + } + "osx" { + # osx-x64 or osx-arm64 ? + $os = "macosx" + } + default { + #openbsd, netbsd ? + $os = "other" + } + } + } else { + $os = "win32" + } + + $matchedlines = $match.Groups[1].Value + $nextshell_type = "" + $nextshell_path = "" + ForEach ($line in $($matchedlines -split "\r?\n")) { + $m = [regex]::Match($line,".*nextshelltype\[${os}[_]+\]=([^_]*)[_]*") + if ($m.Success) { + $nextshell_type = $m.Groups[1].Value + } + $m = [regex]::Match($line,".*nextshellpath\[${os}[_]+\]=([^_]*)[_]*") + if ($m.Success) { + $nextshell_path = $m.Groups[1].Value + } + if ($nextshell_type -ne "" -and $nextshell_path -ne "") { + break + } + } + 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" + + # $arguments = @($($MyInvocation.MyCommand.Path)) + # $arguments += $args + # NOTE - this gives incorrect argument quoting e.g wrong number of arguments received by launched process for arguments: a "b c" + # $process = (Start-Process -FilePath $nextshell_path -ArgumentList $arguments -NoNewWindow -Wait) + # Exit $process.ExitCode + + & $nextshell_path $scriptname $args + exit $LASTEXITCODE + } +} + # -- --- --- --- --- --- --- --- --- --- --- --- --- ---begin powershell Payload # -Write-Error "No powershell code for this script. Try another program such as perl, tcl or bash" +Write-Error "No powershell code for this script. Try another program such as tcl or bash`n" +"powershell args : {0}" -f ($args -join ", ") | write-host # # diff --git a/src/modules/punk/mix/templates/utility/scriptappwrappers/multishell1.cmd b/src/modules/punk/mix/templates/utility/scriptappwrappers/multishell1.cmd index 9daf7ebf..3fce3bcf 100644 --- a/src/modules/punk/mix/templates/utility/scriptappwrappers/multishell1.cmd +++ b/src/modules/punk/mix/templates/utility/scriptappwrappers/multishell1.cmd @@ -1,5 +1,5 @@ -: "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 = @' +: "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" + @@ -16,41 +16,41 @@ set -- "$@" "a=[Hide <#;Hide set;s 1 list]"; set -- : "$@";$1 = @' @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 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= powershell______ sh______________ wslbash_________ bash____________ tcl_____________ perl____________" +@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 32 chars needed for a target, it can still be done but overall script padding may need checking/adjusting +@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___________]=tclsh___________________________" +: <> +@SET "nextshellpath[win32___________]=tclsh___________________________________________________________" @SET "nextshelltype[win32___________]=tcl_____________" -@SET "nextshellpath[dragonflybsd____]=/usr/bin/env tclsh______________" +@SET "nextshellpath[dragonflybsd____]=/usr/bin/env tclsh______________________________________________" @SET "nextshelltype[dragonflybsd____]=tcl_____________" -@SET "nextshellpath[freebsd_________]=/usr/bin/env tclsh______________" +@SET "nextshellpath[freebsd_________]=/usr/bin/env tclsh______________________________________________" @SET "nextshelltype[freebsd_________]=tcl_____________" -@SET "nextshellpath[netbsd__________]=/usr/bin/env tclsh______________" +@SET "nextshellpath[netbsd__________]=/usr/bin/env tclsh______________________________________________" @SET "nextshelltype[netbsd__________]=tcl_____________" -@SET "nextshellpath[linux___________]=/usr/bin/env tclsh______________" +@SET "nextshellpath[linux___________]=/usr/bin/env tclsh______________________________________________" @SET "nextshelltype[linux___________]=tcl_____________" -@SET "nextshellpath[macosx__________]=/usr/bin/env tclsh______________" +@SET "nextshellpath[macosx__________]=/usr/bin/env tclsh______________________________________________" @SET "nextshelltype[macosx__________]=tcl_____________" -@SET "nextshellpath[other___________]=/usr/bin/env tclsh______________" +@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___________]%" @@ -143,7 +143,7 @@ set -- "$@" "a=[Hide <#;Hide set;s 1 list]"; set -- : "$@";$1 = @' @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 +@ECHO Launching script in new window due to administrator elevation @"%SystemRoot%\System32\WScript.exe" "%vbsGetPrivileges%" %* @EXIT /B @@ -175,43 +175,57 @@ set -- "$@" "a=[Hide <#;Hide set;s 1 list]"; set -- : "$@";$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 +@IF "!selected_shelltype_trimmed!"=="none" ( + SET selected_shelltype_trimmed=pwsh +) +@SET "squoted_args=" +@for %%a in (%*) do @( + set "v=%%a" + set "v=!v:'=''!" + SET "squoted_args=!squoted_args!'!v!' " +) +@SET "squoted_args=%squoted_args:~0,-1%" +@ECHO %squoted_args% +@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; write-host "statusmessage: pwsh-found" >NUL + 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% + pwsh -nop -nol -c set-executionpolicy -Scope Process Unrestricted; "%~dp0%~n0.ps1" %squoted_args% 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% + 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" %squoted_args% 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% + IF "!selected_shelltype_trimmed!"=="powershell" ( + powershell -nop -nol -ExecutionPolicy Bypass -c "%~dp0%~n0.ps1" %squoted_args% 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; + 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 ( - 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 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 + ) ) ) ) @@ -342,7 +356,7 @@ set -- "$@" "a=[Hide <#;Hide set;s 1 list]"; set -- : "$@";$1 = @' @EXIT /B @REM boundary padding @REM boundary padding -:stringToUpper +:stringToUpper @SETLOCAL @SET "rtrn=%~2" @SET "string=%~1" @@ -383,14 +397,15 @@ set -- "$@" "a=[Hide <#;Hide set;s 1 list]"; set -- : "$@";$1 = @' @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:###=% + @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 "" ( @@ -439,7 +454,7 @@ set -- "$@" "a=[Hide <#;Hide set;s 1 list]"; set -- : "$@";$1 = @' # -- e.g tclsh filename.cmd # -- # ## ### ### ### ### ### ### ### ### ### ### ### ### ### -rename set ""; rename s set; set k {-- "$@" "a}; if {[info exists ::env($k)]} {unset ::env($k)} ;# tidyup and restore +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}/__]] @@ -473,6 +488,9 @@ namespace eval ::punk::multishell { #puts "argv0 : $::argv0" # -- --- --- --- --- --- --- --- --- --- --- --- +# +puts stderr "No tcl code for this script. Try another program such as perl or bash" +# # # @@ -502,8 +520,20 @@ if {[::punk::multishell::is_main]} { # -- --- --- --- --- --- --- --- --- --- --- --- --- ---end Tcl Payload # end hide from unix shells \ HEREDOC1B_HIDE_FROM_BASH_AND_SH +#Be wary of any non-trivial sed/awk etc - can be brittle to maintain across linux,freebsd,macosx due to differing implementations +#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 { @@ -518,10 +548,113 @@ if false==false # else { # -- if sh/bash scripting needs to run on windows too. # -- # ## ### ### ### ### ### ### ### ### ### ### ### ### ### -# -- --- --- --- --- --- --- --- --- --- --- --- --- ---begin sh Payload + +plat=$(uname -s) #platform/system +if [[ "$plat" = "Linux"* ]]; then + os="linux" +elif [[ "$plat" == "Darwin"* ]]; then + os="macosx" +elif [[ "$plat" == "FreeBSD"* ]]; then + os="freebsd" +elif [[ "$plat" == "DragonFly"* ]]; then + os="dragonflybsd" +elif [[ "$plat" == "NetBSD"* ]]; then + os="netbsd" +elif [[ "$plat" == "OpenBSD"* ]]; then + os="openbsd" +elif [[ "$plat" = "MINGW32"* ]]; then + os="win32" +elif [[ "$plat" = "MINGW64"* ]]; then + os="win32" +elif [[ "$plat" = "CYGWIN_NT"* ]]; then + os="win32" +elif [[ "$plat" == "MSYS_NT"* ]]; then + #review.. + echo MSYS + #win32 binaries - but e.g tclsh installed in msys reports ::tcl_platform(platform) as 'unix' + #bash reports $OSTYPE 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}}" +elif [[ "$OSTYPE" == "win32" ]]; then + os="win32" +else + #os="$OSTYPE" + os="other" +fi +echo ostype: $OSTYPE +## This is the sort of sed that will not work across implementations +## shellconfiglines=$( sed -n "/: <>/{:a;n;/: <>/q;p;ba}" "$0" | grep $os) +#awk tested on linux & freebsd +shellconfiglines=$( awk '/^:.*<>.*$/,/^:.*<>.*$/' "$0" | grep $os) +#echo $shellconfiglines; +readarray -t arr_oslines <<<"$shellconfiglines" +nextshellpath="" +nextshelltype="" +for ln in "${arr_oslines[@]}"; do + if [[ "$ln" == *"nextshellpath"* ]]; then + splitln="${ln#*=}" #remove everything through the first '=' + pathraw="${splitln%%\"*}" #take everything before the quote - use %% to get longest match + #remove trailing underscores (% means must match at end) + nextshellpath="${pathraw/%_*/}" + echo "nextshellpath: $nextshellpath" + elif [[ "$ln" == *"nextshelltype"* ]]; then + splitln="${ln#*=}" + typeraw="${splitln%%\"*}" + nextshelltype="${typeraw/%_*/}" + fi +done + +#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" +# +echo "No bash code for this script. Try another program such as perl or tcl" >&2 +# + # # @@ -531,8 +664,8 @@ exitcode=0 #-- 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=$? +#/usr/bin/env tclsh "$0" "$@" +#exitcode=$? #echo "sh/bash reporting tcl exitcode: ${exitcode}" #-- override exitcode example #exit 66 @@ -558,8 +691,18 @@ exit ${exitcode} # ## ### ### ### ### ### ### ### ### ### ### ### ### ### =cut #!/user/bin/perl -# -- --- --- --- --- --- --- --- --- --- --- --- --- ---begin perl Payload 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(); @@ -571,13 +714,15 @@ my $exit_code = 0; -my $scriptname = $0; -print "perl $scriptname\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"; +# + # # @@ -585,7 +730,7 @@ foreach my $a(@ARGV) { # -- --- --- --- --- --- --- --- # -$exit_code=system("tclsh", $scriptname, @ARGV); +#$exit_code=system("tclsh", $scriptname, @ARGV); #print "perl reporting tcl exitcode: $exit_code"; # # -- --- --- --- --- --- --- --- @@ -648,12 +793,14 @@ function GetDynamicParamDictionary { return $DynParamDictionary } } +# Example usage: # 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 +# [Parameter(Mandatory)][string] $myargument, +# [Parameter(ValueFromRemainingArguments)] $opts # ) #} #function psmain { @@ -664,10 +811,15 @@ function GetDynamicParamDictionary { # #called once with $PSBoundParameters dictionary # #can be used to validate arguments, or set a simpler variable name for access # switch ($PSBoundParameters.keys) { -# 'myargumentname' { +# 'myargument' { # Set-Variable -Name $_ -Value $PSBoundParameters."$_" # } -# #... +# 'opts' { +# write-warning "Unused parameters: $($PSBoundParameters.$_)" +# } +# Default { +# write-warning "Unhandled parameter -> [$($_)]" +# } # } # foreach ($boundparam in $PSBoundParameters.GetEnumerator()) { # #... @@ -675,17 +827,46 @@ function GetDynamicParamDictionary { # } # end { # #Main function logic -# Write-Host "myargumentname value is: $myargumentname" +# Write-Host "myargument value is: $myargument" # #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 # -- --- --- --- +$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 + +# +Write-Error "No powershell code for this script. Try another program such as perl, tcl or bash" +# # # @@ -693,7 +874,7 @@ function GetDynamicParamDictionary { # -- --- --- --- --- --- --- --- # -tclsh $scriptname $args +#tclsh $scriptname $args #"powershell reporting exitcode: {0}" -f $LASTEXITCODE | write-host # # -- --- --- --- --- --- --- --- diff --git a/src/modules/punk/mix/templates/utility/scriptappwrappers/multishell2.cmd b/src/modules/punk/mix/templates/utility/scriptappwrappers/multishell2.cmd index 17fe4c15..9daf7ebf 100644 --- a/src/modules/punk/mix/templates/utility/scriptappwrappers/multishell2.cmd +++ b/src/modules/punk/mix/templates/utility/scriptappwrappers/multishell2.cmd @@ -1,41 +1,65 @@ -: "[rename set s;proc Hide x {proc $x args {}};Hide :]" "\$(function : {<#pwsh#>})" ^ -set -- "$@" "a=[list shebangless punk MULTISHELL tclsh sh bash cmd pwsh powershell;proc Hide x {proc $x args {}}; 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 @ECHO; Hide ); Hide (;Hide echo; Hide @REM]#not necessary but can help avoid errs in testing" +: "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 \ : { -: STRONG SUGGESTION: DO NOT MODIFY FIRST LINE OF THIS SCRIPT. 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. @REM ############################################################################################################################ -@REM THIS IS A POLYGLOT SCRIPT - supporting payloads in Tcl, bash, sh and/or powershelll (powershell.exe or pwsh.exe) +@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: pmix scriptwrap.multishell -outputfolder +@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 "validshells= ^(10^) 'pwsh' ^(11^) 'sh' (^12^) 'bash' (^13^) 'tclsh'" -@SET "shells[10]=pwsh" -@SET "shells[11]=sh" -@set "shells[12]=bash" -@SET "shells[13]=tclsh" +@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 "nextshell=13" +@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 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 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 ## ### ### ### ### ### ### ### ### ### ### ### ### ### @@ -49,16 +73,16 @@ set -- "$@" "a=[list shebangless punk MULTISHELL tclsh sh bash cmd pwsh powershe @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.checkfile +@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 pmix scriptwrap.checkfile is still recommended. +@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 pmix scriptwrap.checkfile doesn't check all such boundaries. +@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 @@ -89,22 +113,36 @@ set -- "$@" "a=[list shebangless punk MULTISHELL tclsh sh bash cmd pwsh powershe ) @SET "vbsGetPrivileges=%temp%\punk_bat_elevate_%fname%.vbs" @SET arglist=%* -@IF "%1"=="PUNK-ELEVATED" ( +@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 '%1'=='PUNK-ELEVATED' (echo PUNK-ELEVATED & shift /1 & goto :gotPrivileges ) +@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.cmd", args, "", "runas", 1 >> "%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 @@ -113,7 +151,7 @@ set -- "$@" "a=[list shebangless punk MULTISHELL tclsh sh bash cmd pwsh powershe @REM setlocal & pushd . @PUSHD . @cd /d %~dp0 -@IF "%1"=="PUNK-ELEVATED" ( +@IF "is%qstrippedargs:~4,13%"=="isPUNK-ELEVATED" ( @DEL "%vbsGetPrivileges%" 1>nul 2>nul @SET arglist=%arglist:~14% ) @@ -124,7 +162,7 @@ set -- "$@" "a=[list shebangless punk MULTISHELL tclsh sh bash cmd pwsh powershe @if not exist "%~dp0%~n0.ps1" ( @SET need_ps1=1 ) ELSE ( - fc "%~dp0%~n0.cmd" "%~dp0%~n0.ps1" >nul || goto different + fc "%~dp0%~n0%~x0" "%~dp0%~n0.ps1" >nul || goto different @REM @ECHO "files same" @SET need_ps1=0 ) @@ -134,10 +172,10 @@ set -- "$@" "a=[list shebangless punk MULTISHELL tclsh sh bash cmd pwsh powershe @SET need_ps1=1 :pscontinue @IF !need_ps1!==1 ( - COPY "%~dp0%~n0.cmd" "%~dp0%~n0.ps1" >NUL + 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" ( +@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 @@ -145,7 +183,8 @@ set -- "$@" "a=[list shebangless punk MULTISHELL tclsh sh bash cmd pwsh powershe 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! + 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" %* @@ -153,24 +192,31 @@ set -- "$@" "a=[list shebangless punk MULTISHELL tclsh sh bash cmd pwsh powershe SET task_exitcode=!errorlevel! ) ) ELSE ( - IF "!shells[%nextshell%]!"=="bash" ( + IF "%selected_shelltype_trimmed%"=="wslbash" ( CALL :getWslPath %winpath% wslpath REM ECHO wslfullpath "!wslpath!%fname%" - !shells[%nextshell%]! "!wslpath!%fname%" %arglist% & SET task_exitcode=!errorlevel! + %selected_shellpath_trimmed% "!wslpath!%fname%" %arglist% + SET task_exitcode=!errorlevel! ) ELSE ( - REM probably tclsh or sh - IF NOT "x%keyRemoved%"=="x%validshells%" ( + 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 - !shells[%nextshell%]! "%~dp0%fname%" %arglist% & SET task_exitcode=!errorlevel! + 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 nextshell value ^(%nextshell%^) !shells[%nextshell%]! valid options are %validshells% + 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 @@ -179,7 +225,9 @@ set -- "$@" "a=[list shebangless punk MULTISHELL tclsh sh bash cmd pwsh powershe @SET "name=%~nx1" @SET "drive=%~d1" @SET "rtrn=%~2" - @SET "result=/mnt/%drive:~0,1%%_path:\=/%%name%" + @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%" @@ -227,6 +275,7 @@ set -- "$@" "a=[list shebangless punk MULTISHELL tclsh sh bash cmd pwsh powershe ) @EXIT /B @REM boundary padding +@REM boundary padding :getNormalizedScriptTail @SETLOCAL @SET "result=%~nx0" @@ -245,6 +294,8 @@ set -- "$@" "a=[list shebangless punk MULTISHELL tclsh sh bash cmd pwsh powershe @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 @@ -289,7 +340,8 @@ set -- "$@" "a=[list shebangless punk MULTISHELL tclsh sh bash cmd pwsh powershe ) ) @EXIT /B - +@REM boundary padding +@REM boundary padding :stringToUpper @SETLOCAL @SET "rtrn=%~2" @@ -307,7 +359,47 @@ set -- "$@" "a=[list shebangless punk MULTISHELL tclsh sh bash cmd pwsh powershe ) ) @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" @@ -328,6 +420,8 @@ set -- "$@" "a=[list shebangless punk MULTISHELL tclsh sh bash cmd pwsh powershe :endlib : \ +@REM padding +@REM padding @REM @SET taskexit_code=!errorlevel! & goto :exit_multishell @GOTO :exit_multishell # } @@ -348,9 +442,9 @@ set -- "$@" "a=[list shebangless punk MULTISHELL tclsh sh bash cmd pwsh powershe 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_root [file dirname [file normalize ${::argv0}/__]] set last_script [file dirname [file normalize [info script]/__]] - if {[info exists argv0] && + 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 @@ -365,7 +459,7 @@ namespace eval ::punk::multishell { 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}/__]]" + puts stderr "Info: script_root: [file dirname [file normalize ${::argv0}/__]]" return 0 } return [set ::punk::multishell::is_main($script_name)] @@ -380,10 +474,16 @@ namespace eval ::punk::multishell { # -- --- --- --- --- --- --- --- --- --- --- --- -# -# +# +# + +# +# +# +# + # -- --- --- --- --- --- --- --- --- --- --- --- # -- Best practice is to always return or exit above, or just by leaving the below defaults in place. @@ -414,33 +514,33 @@ if false==false # else { # -- 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 @call line above ... to something like @call sh ... @call bash .. or @call env sh ... etc as appropriate +# -- 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" -# -# +# +# # -- --- --- --- --- --- --- --- -# -exitcode=0 ;#default assumption +# #-- 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 "tcl exitcode: ${exitcode}" +#echo "sh/bash reporting tcl exitcode: ${exitcode}" #-- override exitcode example #exit 66 -# +# # -- --- --- --- --- --- --- --- -# -# +# +# #printf "sh/bash done \n" @@ -448,7 +548,57 @@ exitcode=$? #------------------------------------------------------ fi exit ${exitcode} -# end hide sh/bash block from Tcl +# ## ### ### ### ### ### ### ### ### ### ### ### ### ### +# -- 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 @@ -460,9 +610,76 @@ if 0 { # -- 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 +$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 @@ -470,22 +687,22 @@ $scriptname = getScriptName #"powershell args : {0}" -f ($args -join ", ") | write-host # -- --- --- --- -# -# +# +# # -- --- --- --- --- --- --- --- -# +# tclsh $scriptname $args -# +#"powershell reporting exitcode: {0}" -f $LASTEXITCODE | write-host +# # -- --- --- --- --- --- --- --- -# -# +# +# # -- --- --- --- --- --- --- --- --- --- --- --- --- ---end powershell Payload -#"powershell reporting exitcode: {0}" -f $LASTEXITCODE | write-host Exit $LASTEXITCODE # heredoc2 for powershell to ignore block below $1 = @' @@ -498,7 +715,7 @@ $1 = @' : \ @REM @ECHO exitcode: !task_exitcode! : \ -@IF "%1"=="PUNK-ELEVATED" (echo. & @cmd /k echo elevated prompt: type exit to quit) +@IF "is%qstrippedargs:~4,13%"=="isPUNK-ELEVATED" (echo. & @cmd /k echo elevated prompt: type exit to quit) : \ @EXIT /B !task_exitcode! # cmd has exited @@ -509,6 +726,7 @@ $1 = @' # -- powershell multiline comment #> <# +no script engine should try to run me # id:tailblock1 #  diff --git a/src/modules/punk/mix/templates/utility/scriptappwrappers/multishell3.cmd b/src/modules/punk/mix/templates/utility/scriptappwrappers/multishell3.cmd index a9688b6a..17fe4c15 100644 --- a/src/modules/punk/mix/templates/utility/scriptappwrappers/multishell3.cmd +++ b/src/modules/punk/mix/templates/utility/scriptappwrappers/multishell3.cmd @@ -1,34 +1,29 @@ -: "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" + +: "[rename set s;proc Hide x {proc $x args {}};Hide :]" "\$(function : {<#pwsh#>})" ^ +set -- "$@" "a=[list shebangless punk MULTISHELL tclsh sh bash cmd pwsh powershell;proc Hide x {proc $x args {}}; 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 @ECHO; Hide ); Hide (;Hide echo; 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 \ : { +: STRONG SUGGESTION: DO NOT MODIFY FIRST LINE OF THIS SCRIPT. 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. @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: deck scriptwrap.multishell -outputfolder +@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 "validshells= ^(10^) 'pwsh' ^(11^) 'sh' (^12^) 'bash' (^13^) 'tclsh'" @SET "shells[10]=pwsh" @SET "shells[11]=sh" @set "shells[12]=bash" @SET "shells[13]=tclsh" -@SET "shells[14]=perl" : @SET "nextshell=13" : @@ -54,16 +49,16 @@ set -- "$@" "a=[Hide <#;Hide set;s 1 list]"; set -- : "$@";$1 = @' @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 -- pmix 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 -- 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.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 -- It is unknown what versions of cmd interpreters behave this way - and pmix 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 @@ -94,40 +89,22 @@ set -- "$@" "a=[Hide <#;Hide set;s 1 list]"; set -- : "$@";$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" ( +@IF "%1"=="PUNK-ELEVATED" ( GOTO :gotPrivileges ) @IF !asadmin!==1 ( net file 1>NUL 2>NUL @IF '!errorlevel!'=='0' ( GOTO :gotPrivileges ) else ( GOTO :getPrivileges ) ) -@REM -@REM -@REM -@REM -@REM -@REM -@REM -@REM -@REM -@REM -@REM -@REM -@REM -@REM -@REM -@REM @GOTO skip_privileges :getPrivileges -@IF "is%qstrippedargs:~4,13%"=="isPUNK-ELEVATED" (echo PUNK-ELEVATED & shift /1 & goto :gotPrivileges ) +@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 UAC.ShellExecute "%~dp0%~n0.cmd", args, "", "runas", 1 >> "%vbsGetPrivileges%" @ECHO Launching script in new windows due to administrator elevation @"%SystemRoot%\System32\WScript.exe" "%vbsGetPrivileges%" %* @EXIT /B @@ -136,7 +113,7 @@ set -- "$@" "a=[Hide <#;Hide set;s 1 list]"; set -- : "$@";$1 = @' @REM setlocal & pushd . @PUSHD . @cd /d %~dp0 -@IF "is%qstrippedargs:~4,13%"=="isPUNK-ELEVATED" ( +@IF "%1"=="PUNK-ELEVATED" ( @DEL "%vbsGetPrivileges%" 1>nul 2>nul @SET arglist=%arglist:~14% ) @@ -147,7 +124,7 @@ set -- "$@" "a=[Hide <#;Hide set;s 1 list]"; set -- : "$@";$1 = @' @if not exist "%~dp0%~n0.ps1" ( @SET need_ps1=1 ) ELSE ( - fc "%~dp0%~n0%~x0" "%~dp0%~n0.ps1" >nul || goto different + fc "%~dp0%~n0.cmd" "%~dp0%~n0.ps1" >nul || goto different @REM @ECHO "files same" @SET need_ps1=0 ) @@ -157,7 +134,7 @@ set -- "$@" "a=[Hide <#;Hide set;s 1 list]"; set -- : "$@";$1 = @' @SET need_ps1=1 :pscontinue @IF !need_ps1!==1 ( - COPY "%~dp0%~n0%~x0" "%~dp0%~n0.ps1" >NUL + COPY "%~dp0%~n0.cmd" "%~dp0%~n0.ps1" >NUL ) @REM avoid using CALL to launch pwsh,tclsh etc - it will intercept some args such as /? @IF "!shells[%nextshell%]!"=="pwsh" ( @@ -168,8 +145,7 @@ set -- "$@" "a=[Hide <#;Hide set;s 1 list]"; set -- : "$@";$1 = @' 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! + 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" %* @@ -180,26 +156,21 @@ set -- "$@" "a=[Hide <#;Hide set;s 1 list]"; set -- : "$@";$1 = @' IF "!shells[%nextshell%]!"=="bash" ( CALL :getWslPath %winpath% wslpath REM ECHO wslfullpath "!wslpath!%fname%" - !shells[%nextshell%]! "!wslpath!%fname%" %arglist% - SET task_exitcode=!errorlevel! + !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! + !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 - @REM boundary padding GOTO :exit_multishell ) ) ) @REM batch file library functions -@REM boundary padding @GOTO :endlib :getWslPath @@ -256,7 +227,6 @@ set -- "$@" "a=[Hide <#;Hide set;s 1 list]"; set -- : "$@";$1 = @' ) @EXIT /B @REM boundary padding -@REM boundary padding :getNormalizedScriptTail @SETLOCAL @SET "result=%~nx0" @@ -275,8 +245,6 @@ set -- "$@" "a=[Hide <#;Hide set;s 1 list]"; set -- : "$@";$1 = @' @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 @@ -412,15 +380,9 @@ namespace eval ::punk::multishell { # -- --- --- --- --- --- --- --- --- --- --- --- -# -# - -# -# - +# +# -# -# # -- --- --- --- --- --- --- --- --- --- --- --- @@ -452,33 +414,33 @@ if false==false # else { # -- 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 +# -- adjust @call line above ... to something like @call sh ... @call bash .. or @call env sh ... etc as appropriate # -- if sh/bash scripting needs to run on windows too. # -- # ## ### ### ### ### ### ### ### ### ### ### ### ### ### # -- --- --- --- --- --- --- --- --- --- --- --- --- ---begin sh Payload -exitcode=0 #printf "start of bash or sh code" -# -# +# +# # -- --- --- --- --- --- --- --- -# +# +exitcode=0 ;#default assumption #-- 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}" +#echo "tcl exitcode: ${exitcode}" #-- override exitcode example #exit 66 -# +# # -- --- --- --- --- --- --- --- -# -# +# +# #printf "sh/bash done \n" @@ -486,57 +448,7 @@ exitcode=$? #------------------------------------------------------ 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 +# end hide sh/bash 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 @@ -548,76 +460,9 @@ if 0 { # -- 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 +$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 @@ -625,22 +470,22 @@ function GetDynamicParamDictionary { #"powershell args : {0}" -f ($args -join ", ") | write-host # -- --- --- --- -# -# +# +# # -- --- --- --- --- --- --- --- -# +# tclsh $scriptname $args -#"powershell reporting exitcode: {0}" -f $LASTEXITCODE | write-host -# +# # -- --- --- --- --- --- --- --- -# -# +# +# # -- --- --- --- --- --- --- --- --- --- --- --- --- ---end powershell Payload +#"powershell reporting exitcode: {0}" -f $LASTEXITCODE | write-host Exit $LASTEXITCODE # heredoc2 for powershell to ignore block below $1 = @' @@ -653,7 +498,7 @@ $1 = @' : \ @REM @ECHO exitcode: !task_exitcode! : \ -@IF "is%qstrippedargs:~4,13%"=="isPUNK-ELEVATED" (echo. & @cmd /k echo elevated prompt: type exit to quit) +@IF "%1"=="PUNK-ELEVATED" (echo. & @cmd /k echo elevated prompt: type exit to quit) : \ @EXIT /B !task_exitcode! # cmd has exited @@ -664,7 +509,6 @@ $1 = @' # -- powershell multiline comment #> <# -no script engine should try to run me # id:tailblock1 #  diff --git a/src/modules/punk/mix/templates/utility/scriptappwrappers/multishell4.cmd b/src/modules/punk/mix/templates/utility/scriptappwrappers/multishell4.cmd new file mode 100644 index 00000000..a9688b6a --- /dev/null +++ b/src/modules/punk/mix/templates/utility/scriptappwrappers/multishell4.cmd @@ -0,0 +1,680 @@ +: "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: 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. +@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=13" +: +@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 -- 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 +@REM +@REM +@REM +@REM +@REM +@REM +@REM +@REM +@REM +@REM +@REM +@REM +@REM +@REM +@REM +@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 "!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 + @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 +# -- 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/modules/punk/repl-999999.0a1.0.tm b/src/modules/punk/repl-999999.0a1.0.tm index 216cf0b7..a8a5afe8 100644 --- a/src/modules/punk/repl-999999.0a1.0.tm +++ b/src/modules/punk/repl-999999.0a1.0.tm @@ -2418,6 +2418,8 @@ proc repl::repl_process_data {inputchan chunktype chunk stdinlines prompt_config #if {[lindex $command 0] eq "runx"} {} + #temporary hack. + #todo - use happy path return options for non-primary result (like www package) ? if { [string equal -length [string length "d/ "] "d/ " $commandstr] || \ [string equal "d/\n" $commandstr] || \ diff --git a/src/modules/punk/zip-999999.0a1.0.tm b/src/modules/punk/zip-999999.0a1.0.tm index f4d7aaea..1ef31efb 100644 --- a/src/modules/punk/zip-999999.0a1.0.tm +++ b/src/modules/punk/zip-999999.0a1.0.tm @@ -283,9 +283,47 @@ tcl::namespace::eval punk::zip { #if there is an external preamble - extract that. (if there is also an internal preamble - ignore and consider part of the archive-data) #Otherwise extract an internal preamble. - #if neither - + #if neither -? #review - reconsider auto-determination of internal vs external preamble - proc extract_preamble {infile outfile_preamble {outfile_zip ""}} { + punk::args::define { + @id -id ::punk::zip::extract_preamble + @cmd -name punk::zip::extract_preamble -help\ + "Split a zipfs based executable or library into its constituent + binary and zip parts. + + Note that the binary preamble might be either 'within' the zip offsets, + or simply catenated prior to an unadjusted zip. + Some build processes may have 'adjusted' the zip offsets to make the zip cover the entire file + ('file based' offset) whilst the more modern approach is to simply concatenate the binary and the zip + ('archive based' offset). An archive-based offset is simpler and more reliably points to the proper + split location. It also allows 'zipfs info //zipfs:/app' to return the correct offset information. + + Either way, extract_preamble can usually separate them, but in the unusual case that there is both an + external preamble and a preamble within the zip, only the external preamble will be split, with the + internal one remaining in the zip. + + The inverse of this process would be to extract the .zip file created by this split to a folder, + e.g extracted_zip_folder (adjusting contents as required) and then to run: + zipfs mkimg newbinaryname.exe extracted_zip_folder \"\" + " + @values -min 2 -max 3 + infile -type file -optional 0 -help\ + "Name of existing tcl executable or shared lib with attached zipfs filesystem" + outfile_preamble -optional 0 -type file -help\ + "Name of output file for binary preamble to be extracted to. + If this file already exists, an error will be raised" + outfile_zip -default "" -type file -help\ + "Name of output file for zip data to be extracted to. + If this file already exists, an error will be raised" + } + proc extract_preamble {args} { + set argd [punk::args::parse $args withid ::punk::zip::extract_preamble] + lassign [dict values $argd] leaders opts values received + + set infile [dict get $values infile] + set outfile_preamble [dict get $values outfile_preamble] + set outfile_zip [dict get $values outfile_zip] + set inzip [open $infile r] fconfigure $inzip -encoding iso8859-1 -translation binary if {[file exists $outfile_preamble]} { @@ -346,7 +384,7 @@ tcl::namespace::eval punk::zip { #we could scan from top (ugly) - and with binary prefixes we could get false positives in the data that look like PK\3\4 headers #we could either work out the format for all possible executables that could be appended (across all platforms) and understand where they end? #or we just look for the topmost PK\3\4 header pointed to by a CDR record - and assume the CDR is complete - + #step one - read all the CD records and find the highest pointed to local file record (which isn't necessarily the first - but should get us above most if not all of the zip data) #we can't assume they're ordered in any particular way - so we in theory have to look at them all. set baseoffset "unknown" diff --git a/src/modules/shellrun-0.1.1.tm b/src/modules/shellrun-0.1.1.tm index b2ce1feb..8f03892d 100644 --- a/src/modules/shellrun-0.1.1.tm +++ b/src/modules/shellrun-0.1.1.tm @@ -427,7 +427,7 @@ namespace eval shellrun { cmdarg -type any -multiple 1 -optional 1 }] proc runerr {args} { - set argd [punk::args::parse $args withid ::shellrun::runout] + set argd [punk::args::parse $args withid ::shellrun::runerr] lassign [dict values $argd] leaders opts values received if {[dict exists $received "-nonewline"]} { 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 06c5369f..1736d3d9 100644 --- a/src/project_layouts/custom/_project/punk.basic/src/make.tcl +++ b/src/project_layouts/custom/_project/punk.basic/src/make.tcl @@ -195,8 +195,8 @@ namespace eval ::punkboot::lib { } x86_64 { if {$tcl_platform(wordSize) == 4} { - # See Example <1> at the top of this file. - set cpu ix86 + # See Example <1> at the top of this file. + set cpu ix86 } } ppc - @@ -216,26 +216,26 @@ namespace eval ::punkboot::lib { switch -glob -- $plat { windows { if {$tcl_platform(platform) == "unix"} { - set plat cygwin + set plat cygwin } else { - set plat win32 + set plat win32 } if {$cpu eq "amd64"} { - # Do not check wordSize, win32-x64 is an IL32P64 platform. - set cpu x86_64 + # Do not check wordSize, win32-x64 is an IL32P64 platform. + set cpu x86_64 } } sunos { set plat solaris if {[string match "ix86" $cpu]} { - if {$tcl_platform(wordSize) == 8} { - set cpu x86_64 - } + if {$tcl_platform(wordSize) == 8} { + set cpu x86_64 + } } elseif {![string match "ia64*" $cpu]} { - # sparc - if {$tcl_platform(wordSize) == 8} { - append cpu 64 - } + # sparc + if {$tcl_platform(wordSize) == 8} { + append cpu 64 + } } } darwin { @@ -243,24 +243,24 @@ namespace eval ::punkboot::lib { # Correctly identify the cpu when running as a 64bit # process on a machine with a 32bit kernel if {$cpu eq "ix86"} { - if {$tcl_platform(wordSize) == 8} { - set cpu x86_64 - } + if {$tcl_platform(wordSize) == 8} { + set cpu x86_64 + } } } aix { set cpu powerpc if {$tcl_platform(wordSize) == 8} { - append cpu 64 + append cpu 64 } } hp-ux { set plat hpux if {![string match "ia64*" $cpu]} { - set cpu parisc - if {$tcl_platform(wordSize) == 8} { - append cpu 64 - } + set cpu parisc + if {$tcl_platform(wordSize) == 8} { + append cpu 64 + } } } osf1 { @@ -2296,8 +2296,23 @@ if {$::punkboot::command eq "bin"} { } #find runtimes -set rtfolder $sourcefolder/runtime +#set rtfolder $sourcefolder/runtime +#AAA + +switch -glob -- $this_platform_generic { + macosx-* { + #assuming universal binaries x86_64 and arm + set rt_os_arch macosx + } + default { + set rt_os_arch $this_platform_generic + } +} +set rtfolder $binfolder/runtime/$rt_os_arch +set rt_sourcefolder $sourcefolder/runtime ;#where our config lives #review - when building kits for other platforms - it's unlikely runtime will be marked as executable - we should probably process all files in runtime folder except those with certain extensions + + set rtfolder_files [glob -nocomplain -dir $rtfolder -types {f} -tail *] set exclusions {.config .md .ico .txt .doc .pdf .htm .html} ;#we don't encourage other files in runtime folder aside from mapvfs.config - but lets ignore some common possibilities lappend exclusions .zip .7z .pea .bz2 .tar .gz .tgz .z .xz ;#don't allow archives to directly be treated as runtimes - tolerate presence but require user to unpack or rename if they're to be used as runtimes @@ -2311,7 +2326,7 @@ foreach f $rtfolder_files { } if {![llength $runtimes]} { puts stderr "No executable runtimes found in $rtfolder - unable to build any .vfs folders into executables." - puts stderr "Add runtimes to $sourcefolder/runtime if required" + puts stderr "Add runtimes to $rtfolder if required" #todo - don't exit - it is valid to use runtime of - to just build a .kit/.zipkit ? exit 0 } @@ -2350,7 +2365,7 @@ if {$sdxpath eq ""} { #build a dict keyed on runtime executable name. #If no mapfile (or no mapfile entry for that runtime) - the runtime will be paired with a matching .vfs folder in src folder. e.g punk.exe to src/punk.vfs #If vfs folders or runtime executables which are explicitly listed in the mapfile don't exist - warn on stderr - but continue. if such nonexistants found; prompt user for whether to continue or abort. -set mapfile $rtfolder/mapvfs.config +set mapfile $rt_sourcefolder/mapvfs.config set runtime_vfs_map [dict create] set vfs_runtime_map [dict create] if {[file exists $mapfile]} { @@ -2891,8 +2906,8 @@ foreach vfstail $vfs_tails { set extract_kit_type "" while {!$extraction_done && [llength $extraction_trylist]} { - set extract_kit_type [lpop extraction_trylist 0] - switch -- $extract_kit_type { + set extract_kit_try [lpop extraction_trylist 0] + switch -- $extract_kit_try { zip - zipcat { #for a zipkit - we need to extract the existing vfs from the runtime #zipfs mkimg replaces the entire zipped vfs in the runtime - so we need the original data to be part of our targetvfs. @@ -2972,12 +2987,12 @@ foreach vfstail $vfs_tails { zipfile::decode::unzip $archiveinfo $extractedzipfolder }]} { set extraction_done 1 + set extract_kit_type $extract_kit_try + #todo - verify that init.tcl etc are present? + merge_over $extractedzipfolder $targetvfs } - #todo - verify that init.tcl etc are present? - merge_over $extractedzipfolder $targetvfs } - } cookit - cookfs { #upx easy enough to deal with if we have/install a upx executable (avail on windows via scoop, freshports for freebsd and presumably various for linux) @@ -3006,17 +3021,20 @@ foreach vfstail $vfs_tails { #copy from mounted runtime's vfs to the filesystem vfs merge_over $rtmountpoint $targetvfs set extraction_done 1 + set extract_kit_type $extract_kit_try } } } kit { if {!$have_sdx} { - puts stderr "no sdx available to wrap $targetkit" - lappend failed_kits [list kit $targetkit reason "sdx_executable_unavailable"] - $vfs_event targetset_end FAILED - $vfs_event destroy - $vfs_installer destroy - continue + puts stderr "no sdx available to unwrap $targetkit" + #don't add to failed_kits here + #extraction fail for one type doesn't mean we have fully failed yet + #lappend failed_kits [list kit $targetkit reason "sdx_executable_unavailable"] + #$vfs_event targetset_end FAILED + #$vfs_event destroy + #$vfs_installer destroy + continue ;#to next extraction attempt } set raw_runtime $buildfolder/raw_$runtime_fullname @@ -3046,6 +3064,7 @@ foreach vfstail $vfs_tails { merge_over [file rootname $building_runtime].vfs $targetvfs } set extraction_done 1 + set extract_kit_type $extract_kit_try file copy -force $building_runtime $raw_runtime } cd $prev_cwd @@ -3056,8 +3075,10 @@ foreach vfstail $vfs_tails { if {!$extraction_done} { #TODO: if not extracted - use a default tcl_library for patchlevel and platform? - puts stderr "WARNING: No extraction done from runtime $runtime_fullname" + puts stderr "--------------------------------------------" + puts stderr "\x1b\31mWARNING: No extraction done from runtime $runtime_fullname\x1b\[m" puts stderr "If no init.tcl provided in the vfs at the proper location (containing init.tcl) - the resulting kit will probably not initialise properly!" + puts stderr "--------------------------------------------" file mkdir $targetvfs } diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/include_modules.config b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/include_modules.config index 2000d2f0..edd7393d 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/include_modules.config +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/include_modules.config @@ -99,5 +99,6 @@ set bootsupport_modules [list\ modules natsort\ modules oolib\ modules zipper\ + modules zzzload\ ] diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/zzzload-0.1.0.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/zzzload-0.1.0.tm new file mode 100644 index 00000000..def41578 --- /dev/null +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/zzzload-0.1.0.tm @@ -0,0 +1,131 @@ +# -*- tcl -*- +# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from -buildversion.txt +# +# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. +# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# (C) 2023 +# +# @@ Meta Begin +# Application zzzload 0.1.0 +# Meta platform tcl +# Meta license BSD +# @@ Meta End + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Requirements +##e.g package require frobz + +package require Thread + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +namespace eval zzzload { + variable loader_tid "" ;#thread id + proc stacktrace {} { + set stack "Stack trace:\n" + for {set i 1} {$i < [info level]} {incr i} { + set lvl [info level -$i] + set pname [lindex $lvl 0] + append stack [string repeat " " $i]$pname + + if {![catch {info args $pname} pargs]} { + foreach value [lrange $lvl 1 end] arg $pargs { + + if {$value eq ""} { + if {$arg != 0} { + info default $pname $arg value + } + } + append stack " $arg='$value'" + } + } else { + append stack " !unknown vars for $pname" + } + + append stack \n + } + return $stack + } + proc pkg_require {pkgname args} { + variable loader_tid + if {[set ver [package provide twapi]] ne ""} { + #skip the whole shebazzle if it's already loaded + return $ver + } + if {$loader_tid eq ""} { + set loader_tid [thread::create -joinable -preserved] + } + if {![tsv::exists zzzload_pkg $pkgname]} { + #puts stderr "zzzload pkg_require $pkgname" + #puts [stacktrace] + tsv::set zzzload_pkg $pkgname "loading" + tsv::set zzzload_pkg_mutex $pkgname [thread::mutex create] + set cond [thread::cond create] + tsv::set zzzload_pkg_cond $pkgname $cond + thread::send -async $loader_tid [string map [list $pkgname $cond] { + if {![catch {package require } returnver]} { + tsv::set zzzload_pkg $returnver + } else { + tsv::set zzzload_pkg "failed" + } + thread::cond notify + }] + return "loading" + } else { + return [tsv::get zzzload_pkg $pkgname] + } + } + proc pkg_wait {pkgname} { + if {[set ver [package provide twapi]] ne ""} { + return $ver + } + + set pkgstate [tsv::get zzzload_pkg $pkgname] + if {$pkgstate eq "loading"} { + set mutex [tsv::get zzzload_pkg_mutex $pkgname] + thread::mutex lock $mutex + set cond [tsv::get zzzload_pkg_cond $pkgname] + while {[tsv::get zzzload_pkg $pkgname] eq "loading"} { + thread::cond wait $cond $mutex 3000 + } + set result [tsv::get zzzload_pkg $pkgname] + thread::mutex unlock $mutex + return $result + } else { + return $pkgstate + } + } + proc shutdown {} { + variable loader_tid + if {[thread::exists $loader_tid]} { + thread::release $loader_tid + thread::join $loader_tid + set loader_tid "" + } + } + +} + + + + + + + + + + + + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Ready +package provide zzzload [namespace eval zzzload { + variable version + set version 0.1.0 +}] +return \ No newline at end of file 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 06c5369f..1736d3d9 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 @@ -195,8 +195,8 @@ namespace eval ::punkboot::lib { } x86_64 { if {$tcl_platform(wordSize) == 4} { - # See Example <1> at the top of this file. - set cpu ix86 + # See Example <1> at the top of this file. + set cpu ix86 } } ppc - @@ -216,26 +216,26 @@ namespace eval ::punkboot::lib { switch -glob -- $plat { windows { if {$tcl_platform(platform) == "unix"} { - set plat cygwin + set plat cygwin } else { - set plat win32 + set plat win32 } if {$cpu eq "amd64"} { - # Do not check wordSize, win32-x64 is an IL32P64 platform. - set cpu x86_64 + # Do not check wordSize, win32-x64 is an IL32P64 platform. + set cpu x86_64 } } sunos { set plat solaris if {[string match "ix86" $cpu]} { - if {$tcl_platform(wordSize) == 8} { - set cpu x86_64 - } + if {$tcl_platform(wordSize) == 8} { + set cpu x86_64 + } } elseif {![string match "ia64*" $cpu]} { - # sparc - if {$tcl_platform(wordSize) == 8} { - append cpu 64 - } + # sparc + if {$tcl_platform(wordSize) == 8} { + append cpu 64 + } } } darwin { @@ -243,24 +243,24 @@ namespace eval ::punkboot::lib { # Correctly identify the cpu when running as a 64bit # process on a machine with a 32bit kernel if {$cpu eq "ix86"} { - if {$tcl_platform(wordSize) == 8} { - set cpu x86_64 - } + if {$tcl_platform(wordSize) == 8} { + set cpu x86_64 + } } } aix { set cpu powerpc if {$tcl_platform(wordSize) == 8} { - append cpu 64 + append cpu 64 } } hp-ux { set plat hpux if {![string match "ia64*" $cpu]} { - set cpu parisc - if {$tcl_platform(wordSize) == 8} { - append cpu 64 - } + set cpu parisc + if {$tcl_platform(wordSize) == 8} { + append cpu 64 + } } } osf1 { @@ -2296,8 +2296,23 @@ if {$::punkboot::command eq "bin"} { } #find runtimes -set rtfolder $sourcefolder/runtime +#set rtfolder $sourcefolder/runtime +#AAA + +switch -glob -- $this_platform_generic { + macosx-* { + #assuming universal binaries x86_64 and arm + set rt_os_arch macosx + } + default { + set rt_os_arch $this_platform_generic + } +} +set rtfolder $binfolder/runtime/$rt_os_arch +set rt_sourcefolder $sourcefolder/runtime ;#where our config lives #review - when building kits for other platforms - it's unlikely runtime will be marked as executable - we should probably process all files in runtime folder except those with certain extensions + + set rtfolder_files [glob -nocomplain -dir $rtfolder -types {f} -tail *] set exclusions {.config .md .ico .txt .doc .pdf .htm .html} ;#we don't encourage other files in runtime folder aside from mapvfs.config - but lets ignore some common possibilities lappend exclusions .zip .7z .pea .bz2 .tar .gz .tgz .z .xz ;#don't allow archives to directly be treated as runtimes - tolerate presence but require user to unpack or rename if they're to be used as runtimes @@ -2311,7 +2326,7 @@ foreach f $rtfolder_files { } if {![llength $runtimes]} { puts stderr "No executable runtimes found in $rtfolder - unable to build any .vfs folders into executables." - puts stderr "Add runtimes to $sourcefolder/runtime if required" + puts stderr "Add runtimes to $rtfolder if required" #todo - don't exit - it is valid to use runtime of - to just build a .kit/.zipkit ? exit 0 } @@ -2350,7 +2365,7 @@ if {$sdxpath eq ""} { #build a dict keyed on runtime executable name. #If no mapfile (or no mapfile entry for that runtime) - the runtime will be paired with a matching .vfs folder in src folder. e.g punk.exe to src/punk.vfs #If vfs folders or runtime executables which are explicitly listed in the mapfile don't exist - warn on stderr - but continue. if such nonexistants found; prompt user for whether to continue or abort. -set mapfile $rtfolder/mapvfs.config +set mapfile $rt_sourcefolder/mapvfs.config set runtime_vfs_map [dict create] set vfs_runtime_map [dict create] if {[file exists $mapfile]} { @@ -2891,8 +2906,8 @@ foreach vfstail $vfs_tails { set extract_kit_type "" while {!$extraction_done && [llength $extraction_trylist]} { - set extract_kit_type [lpop extraction_trylist 0] - switch -- $extract_kit_type { + set extract_kit_try [lpop extraction_trylist 0] + switch -- $extract_kit_try { zip - zipcat { #for a zipkit - we need to extract the existing vfs from the runtime #zipfs mkimg replaces the entire zipped vfs in the runtime - so we need the original data to be part of our targetvfs. @@ -2972,12 +2987,12 @@ foreach vfstail $vfs_tails { zipfile::decode::unzip $archiveinfo $extractedzipfolder }]} { set extraction_done 1 + set extract_kit_type $extract_kit_try + #todo - verify that init.tcl etc are present? + merge_over $extractedzipfolder $targetvfs } - #todo - verify that init.tcl etc are present? - merge_over $extractedzipfolder $targetvfs } - } cookit - cookfs { #upx easy enough to deal with if we have/install a upx executable (avail on windows via scoop, freshports for freebsd and presumably various for linux) @@ -3006,17 +3021,20 @@ foreach vfstail $vfs_tails { #copy from mounted runtime's vfs to the filesystem vfs merge_over $rtmountpoint $targetvfs set extraction_done 1 + set extract_kit_type $extract_kit_try } } } kit { if {!$have_sdx} { - puts stderr "no sdx available to wrap $targetkit" - lappend failed_kits [list kit $targetkit reason "sdx_executable_unavailable"] - $vfs_event targetset_end FAILED - $vfs_event destroy - $vfs_installer destroy - continue + puts stderr "no sdx available to unwrap $targetkit" + #don't add to failed_kits here + #extraction fail for one type doesn't mean we have fully failed yet + #lappend failed_kits [list kit $targetkit reason "sdx_executable_unavailable"] + #$vfs_event targetset_end FAILED + #$vfs_event destroy + #$vfs_installer destroy + continue ;#to next extraction attempt } set raw_runtime $buildfolder/raw_$runtime_fullname @@ -3046,6 +3064,7 @@ foreach vfstail $vfs_tails { merge_over [file rootname $building_runtime].vfs $targetvfs } set extraction_done 1 + set extract_kit_type $extract_kit_try file copy -force $building_runtime $raw_runtime } cd $prev_cwd @@ -3056,8 +3075,10 @@ foreach vfstail $vfs_tails { if {!$extraction_done} { #TODO: if not extracted - use a default tcl_library for patchlevel and platform? - puts stderr "WARNING: No extraction done from runtime $runtime_fullname" + puts stderr "--------------------------------------------" + puts stderr "\x1b\31mWARNING: No extraction done from runtime $runtime_fullname\x1b\[m" puts stderr "If no init.tcl provided in the vfs at the proper location (containing init.tcl) - the resulting kit will probably not initialise properly!" + puts stderr "--------------------------------------------" file mkdir $targetvfs } diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/include_modules.config b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/include_modules.config index 2000d2f0..edd7393d 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/include_modules.config +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/include_modules.config @@ -99,5 +99,6 @@ set bootsupport_modules [list\ modules natsort\ modules oolib\ modules zipper\ + modules zzzload\ ] diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/zzzload-0.1.0.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/zzzload-0.1.0.tm new file mode 100644 index 00000000..def41578 --- /dev/null +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/zzzload-0.1.0.tm @@ -0,0 +1,131 @@ +# -*- tcl -*- +# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from -buildversion.txt +# +# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. +# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# (C) 2023 +# +# @@ Meta Begin +# Application zzzload 0.1.0 +# Meta platform tcl +# Meta license BSD +# @@ Meta End + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Requirements +##e.g package require frobz + +package require Thread + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +namespace eval zzzload { + variable loader_tid "" ;#thread id + proc stacktrace {} { + set stack "Stack trace:\n" + for {set i 1} {$i < [info level]} {incr i} { + set lvl [info level -$i] + set pname [lindex $lvl 0] + append stack [string repeat " " $i]$pname + + if {![catch {info args $pname} pargs]} { + foreach value [lrange $lvl 1 end] arg $pargs { + + if {$value eq ""} { + if {$arg != 0} { + info default $pname $arg value + } + } + append stack " $arg='$value'" + } + } else { + append stack " !unknown vars for $pname" + } + + append stack \n + } + return $stack + } + proc pkg_require {pkgname args} { + variable loader_tid + if {[set ver [package provide twapi]] ne ""} { + #skip the whole shebazzle if it's already loaded + return $ver + } + if {$loader_tid eq ""} { + set loader_tid [thread::create -joinable -preserved] + } + if {![tsv::exists zzzload_pkg $pkgname]} { + #puts stderr "zzzload pkg_require $pkgname" + #puts [stacktrace] + tsv::set zzzload_pkg $pkgname "loading" + tsv::set zzzload_pkg_mutex $pkgname [thread::mutex create] + set cond [thread::cond create] + tsv::set zzzload_pkg_cond $pkgname $cond + thread::send -async $loader_tid [string map [list $pkgname $cond] { + if {![catch {package require } returnver]} { + tsv::set zzzload_pkg $returnver + } else { + tsv::set zzzload_pkg "failed" + } + thread::cond notify + }] + return "loading" + } else { + return [tsv::get zzzload_pkg $pkgname] + } + } + proc pkg_wait {pkgname} { + if {[set ver [package provide twapi]] ne ""} { + return $ver + } + + set pkgstate [tsv::get zzzload_pkg $pkgname] + if {$pkgstate eq "loading"} { + set mutex [tsv::get zzzload_pkg_mutex $pkgname] + thread::mutex lock $mutex + set cond [tsv::get zzzload_pkg_cond $pkgname] + while {[tsv::get zzzload_pkg $pkgname] eq "loading"} { + thread::cond wait $cond $mutex 3000 + } + set result [tsv::get zzzload_pkg $pkgname] + thread::mutex unlock $mutex + return $result + } else { + return $pkgstate + } + } + proc shutdown {} { + variable loader_tid + if {[thread::exists $loader_tid]} { + thread::release $loader_tid + thread::join $loader_tid + set loader_tid "" + } + } + +} + + + + + + + + + + + + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Ready +package provide zzzload [namespace eval zzzload { + variable version + set version 0.1.0 +}] +return \ No newline at end of file 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 06c5369f..1736d3d9 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 @@ -195,8 +195,8 @@ namespace eval ::punkboot::lib { } x86_64 { if {$tcl_platform(wordSize) == 4} { - # See Example <1> at the top of this file. - set cpu ix86 + # See Example <1> at the top of this file. + set cpu ix86 } } ppc - @@ -216,26 +216,26 @@ namespace eval ::punkboot::lib { switch -glob -- $plat { windows { if {$tcl_platform(platform) == "unix"} { - set plat cygwin + set plat cygwin } else { - set plat win32 + set plat win32 } if {$cpu eq "amd64"} { - # Do not check wordSize, win32-x64 is an IL32P64 platform. - set cpu x86_64 + # Do not check wordSize, win32-x64 is an IL32P64 platform. + set cpu x86_64 } } sunos { set plat solaris if {[string match "ix86" $cpu]} { - if {$tcl_platform(wordSize) == 8} { - set cpu x86_64 - } + if {$tcl_platform(wordSize) == 8} { + set cpu x86_64 + } } elseif {![string match "ia64*" $cpu]} { - # sparc - if {$tcl_platform(wordSize) == 8} { - append cpu 64 - } + # sparc + if {$tcl_platform(wordSize) == 8} { + append cpu 64 + } } } darwin { @@ -243,24 +243,24 @@ namespace eval ::punkboot::lib { # Correctly identify the cpu when running as a 64bit # process on a machine with a 32bit kernel if {$cpu eq "ix86"} { - if {$tcl_platform(wordSize) == 8} { - set cpu x86_64 - } + if {$tcl_platform(wordSize) == 8} { + set cpu x86_64 + } } } aix { set cpu powerpc if {$tcl_platform(wordSize) == 8} { - append cpu 64 + append cpu 64 } } hp-ux { set plat hpux if {![string match "ia64*" $cpu]} { - set cpu parisc - if {$tcl_platform(wordSize) == 8} { - append cpu 64 - } + set cpu parisc + if {$tcl_platform(wordSize) == 8} { + append cpu 64 + } } } osf1 { @@ -2296,8 +2296,23 @@ if {$::punkboot::command eq "bin"} { } #find runtimes -set rtfolder $sourcefolder/runtime +#set rtfolder $sourcefolder/runtime +#AAA + +switch -glob -- $this_platform_generic { + macosx-* { + #assuming universal binaries x86_64 and arm + set rt_os_arch macosx + } + default { + set rt_os_arch $this_platform_generic + } +} +set rtfolder $binfolder/runtime/$rt_os_arch +set rt_sourcefolder $sourcefolder/runtime ;#where our config lives #review - when building kits for other platforms - it's unlikely runtime will be marked as executable - we should probably process all files in runtime folder except those with certain extensions + + set rtfolder_files [glob -nocomplain -dir $rtfolder -types {f} -tail *] set exclusions {.config .md .ico .txt .doc .pdf .htm .html} ;#we don't encourage other files in runtime folder aside from mapvfs.config - but lets ignore some common possibilities lappend exclusions .zip .7z .pea .bz2 .tar .gz .tgz .z .xz ;#don't allow archives to directly be treated as runtimes - tolerate presence but require user to unpack or rename if they're to be used as runtimes @@ -2311,7 +2326,7 @@ foreach f $rtfolder_files { } if {![llength $runtimes]} { puts stderr "No executable runtimes found in $rtfolder - unable to build any .vfs folders into executables." - puts stderr "Add runtimes to $sourcefolder/runtime if required" + puts stderr "Add runtimes to $rtfolder if required" #todo - don't exit - it is valid to use runtime of - to just build a .kit/.zipkit ? exit 0 } @@ -2350,7 +2365,7 @@ if {$sdxpath eq ""} { #build a dict keyed on runtime executable name. #If no mapfile (or no mapfile entry for that runtime) - the runtime will be paired with a matching .vfs folder in src folder. e.g punk.exe to src/punk.vfs #If vfs folders or runtime executables which are explicitly listed in the mapfile don't exist - warn on stderr - but continue. if such nonexistants found; prompt user for whether to continue or abort. -set mapfile $rtfolder/mapvfs.config +set mapfile $rt_sourcefolder/mapvfs.config set runtime_vfs_map [dict create] set vfs_runtime_map [dict create] if {[file exists $mapfile]} { @@ -2891,8 +2906,8 @@ foreach vfstail $vfs_tails { set extract_kit_type "" while {!$extraction_done && [llength $extraction_trylist]} { - set extract_kit_type [lpop extraction_trylist 0] - switch -- $extract_kit_type { + set extract_kit_try [lpop extraction_trylist 0] + switch -- $extract_kit_try { zip - zipcat { #for a zipkit - we need to extract the existing vfs from the runtime #zipfs mkimg replaces the entire zipped vfs in the runtime - so we need the original data to be part of our targetvfs. @@ -2972,12 +2987,12 @@ foreach vfstail $vfs_tails { zipfile::decode::unzip $archiveinfo $extractedzipfolder }]} { set extraction_done 1 + set extract_kit_type $extract_kit_try + #todo - verify that init.tcl etc are present? + merge_over $extractedzipfolder $targetvfs } - #todo - verify that init.tcl etc are present? - merge_over $extractedzipfolder $targetvfs } - } cookit - cookfs { #upx easy enough to deal with if we have/install a upx executable (avail on windows via scoop, freshports for freebsd and presumably various for linux) @@ -3006,17 +3021,20 @@ foreach vfstail $vfs_tails { #copy from mounted runtime's vfs to the filesystem vfs merge_over $rtmountpoint $targetvfs set extraction_done 1 + set extract_kit_type $extract_kit_try } } } kit { if {!$have_sdx} { - puts stderr "no sdx available to wrap $targetkit" - lappend failed_kits [list kit $targetkit reason "sdx_executable_unavailable"] - $vfs_event targetset_end FAILED - $vfs_event destroy - $vfs_installer destroy - continue + puts stderr "no sdx available to unwrap $targetkit" + #don't add to failed_kits here + #extraction fail for one type doesn't mean we have fully failed yet + #lappend failed_kits [list kit $targetkit reason "sdx_executable_unavailable"] + #$vfs_event targetset_end FAILED + #$vfs_event destroy + #$vfs_installer destroy + continue ;#to next extraction attempt } set raw_runtime $buildfolder/raw_$runtime_fullname @@ -3046,6 +3064,7 @@ foreach vfstail $vfs_tails { merge_over [file rootname $building_runtime].vfs $targetvfs } set extraction_done 1 + set extract_kit_type $extract_kit_try file copy -force $building_runtime $raw_runtime } cd $prev_cwd @@ -3056,8 +3075,10 @@ foreach vfstail $vfs_tails { if {!$extraction_done} { #TODO: if not extracted - use a default tcl_library for patchlevel and platform? - puts stderr "WARNING: No extraction done from runtime $runtime_fullname" + puts stderr "--------------------------------------------" + puts stderr "\x1b\31mWARNING: No extraction done from runtime $runtime_fullname\x1b\[m" puts stderr "If no init.tcl provided in the vfs at the proper location (containing init.tcl) - the resulting kit will probably not initialise properly!" + puts stderr "--------------------------------------------" file mkdir $targetvfs } diff --git a/src/runtime/mapvfs.config b/src/runtime/mapvfs.config index c3bf6a1b..0a6c55d1 100644 --- a/src/runtime/mapvfs.config +++ b/src/runtime/mapvfs.config @@ -45,7 +45,7 @@ #made with Bawt (2025-08) #tclkit -#tclkit902.exe {punk9win_for_tkruntime.vfs punk902k kit} +#tclkit902.exe {punk9win_for_tkruntime.vfs punk902kit kit} #static build - with tk dll and tk lib added to zip tclsh902z.exe {punk9win_for_tkruntime.vfs punk902z zip} @@ -55,8 +55,8 @@ tclsh902z.exe {punk9win_for_tkruntime.vfs punk902z zip} #----------------------------------------- #AAA -#tclsh901t.exe {punk9win.vfs punk901t zipcat} -#tclsh901k.exe {mkzipfix.vfs punktest zip} +tclsh901t.exe {punk9win.vfs punk901t zipcat} +#tclsh901k.exe {mkzipfix.vfs punktest zip} diff --git a/src/scriptapps/getpunk_wrap.toml b/src/scriptapps/getpunk_wrap.toml index 19878a63..e206c989 100644 --- a/src/scriptapps/getpunk_wrap.toml +++ b/src/scriptapps/getpunk_wrap.toml @@ -15,6 +15,6 @@ #valid nextshelltype entries are: tcl perl powershell bash. #nextshellpath entries must be 64 characters or less. - win32.nextshellpath="powershell" + win32.nextshellpath="powershell -nop -nol -ExecutionPolicy ByPass -File" win32.nextshelltype="powershell" win32.outputfile="getpunk.cmd" diff --git a/src/scriptapps/getzig.ps1 b/src/scriptapps/getzig.ps1 index 411162b6..9d667d58 100644 --- a/src/scriptapps/getzig.ps1 +++ b/src/scriptapps/getzig.ps1 @@ -7,6 +7,7 @@ #$outbase = Join-Path -Path $PSScriptRoot -ChildPath "../.." $outbase = $PSScriptRoot $outbase = Resolve-Path -Path $outbase +Write-host "Base folder: $outbase" $toolsfolder = Join-Path -Path $outbase -ChildPath "tools" if (-not(Test-Path -Path $toolsfolder -PathType Container)) { #create folder - (can include missing intermediaries) diff --git a/src/scriptapps/getzig_original.polyglot b/src/scriptapps/getzig_original.polyglot new file mode 100644 index 00000000..41af9fed --- /dev/null +++ b/src/scriptapps/getzig_original.polyglot @@ -0,0 +1,18 @@ + +#!/bin/sh +echo `# <#` +mkdir -p ./zig +wget https://ziglang.org/download/0.10.1/zig-linux-x86_64-0.10.1.tar.xz -O ./zig/zig-linux-x86_64-0.10.1.tar.xz +tar -xf ./zig/zig-linux-x86_64-0.10.1.tar.xz -C ./zig --strip-components=1 +rm ./zig/zig-linux-x86_64-0.10.1.tar.xz +echo "Zig installed." +./zig/zig version +exit +#> > $null + +Invoke-WebRequest -Uri "https://ziglang.org/download/0.10.1/zig-windows-x86_64-0.10.1.zip" -OutFile ".\zig-windows-x86_64-0.10.1.zip" +Expand-Archive -Path ".\zig-windows-x86_64-0.10.1.zip" -DestinationPath ".\" -Force +Remove-Item -Path " .\zig-windows-x86_64-0.10.1.zip" +Rename-Item -Path ".\zig-windows-x86_64-0.10.1" -NewName ".\zig" +Write-Host "Zig installed." +./zig/zig.exe version diff --git a/src/scriptapps/getzig_wrap.toml b/src/scriptapps/getzig_wrap.toml index 0a7b5e53..3cfdb55e 100644 --- a/src/scriptapps/getzig_wrap.toml +++ b/src/scriptapps/getzig_wrap.toml @@ -16,6 +16,6 @@ #valid nextshelltype entries are: tcl perl pwsh powershell bash. #nextshellpath entries must be 64 characters or less. - win32.nextshellpath="pwsh" + win32.nextshellpath="pwsh -nop -nol -ExecutionPolicy bypass -c" win32.nextshelltype="pwsh" win32.outputfile="getzig.cmd" diff --git a/src/scriptapps/runtime.bash b/src/scriptapps/runtime.bash index 584a949f..986a0b10 100644 --- a/src/scriptapps/runtime.bash +++ b/src/scriptapps/runtime.bash @@ -12,44 +12,67 @@ scriptroot="${basename%.*}" #e.g "fetchruntime" url_kitbase="https://www.gitea1.intx.com.au/jn/punkbin/raw/branch/master" runtime_available=0 -if [[ "$OSTYPE" == "linux"* ]]; then - arch=$(uname -i) - if [[ "$arch" == "x86_64"* ]]; then +#$OSTYPE varies in capitalization across for example zsh and bash +#uname probably a more consistent bet +arch=$(uname -m) #machine/architecture +plat=$(uname -s) #platform/system +#even though most of the platform prongs are very similar, +#we keep the code separate so it can be tweaked easily for unexpected differences +if [[ "$plat" = "Linux"* ]]; then + if [[ "$arch" = "x86_64"* ]]; then url="${url_kitbase}/linux-x86_64/tclkit-902-Linux64-intel-dyn" archdir="${scriptdir}/runtime/linux-x86_64" output="${archdir}/tclkit-902-Linux64-intel-dyn" runtime_available=1 - elif [[ "$arch" == "arm"* ]]; then + elif [[ "$arch" = "arm"* ]]; then url="${url_kitbase}/linux-arm/tclkit-902-Linux64-arm-dyn" archdir="${scriptdir}/runtime/linux-arm" output="${archdir}/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" + else + archdir="${scriptdir}/runtime/linux-$arch" fi os="linux" -elif [[ "$OSTYPE" == "darwin"* ]]; then +elif [[ "$plat" = "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" archdir="${scriptdir}/runtime/macosx/" output="${archdir}/tclkit-902-Darwin64-dyn" runtime_available=1 -elif [[ "$OSTYPE" == "freebsd"* ]]; then +elif [[ "$plat" = "FreeBSD"* ]]; then + archdir="${scriptdir}/runtime/freebsd-amd64" os="freebsd" -elif [[ "$OSTYPE" == "dragonflybsd"* ]]; then +elif [[ "$plat" == "DragonFly"* ]]; then + archdir="${scriptdir}/runtime/dragonflybsd-$arch" os="dragonflybsd" -elif [[ "$OSTYPE" == "netbsd"* ]]; then +elif [[ "$plat" == "NetBSD"* ]]; then + archdir="${scriptdir}/runtime/netbsd-$arch" os="netbsd" -elif [[ "$OSTYPE" == "win32" ]]; then +elif [[ "$plat" == "OpenBSD"* ]]; then + archdir="${scriptdir}/runtime/openbsd-amd64" + os="openbsd" +elif [[ "$plat" == "MINGW32"* ]]; then + #REVIEW + os="win32" + url="${url_kitbase}/win32-x86_64/tclsh902z.exe" + archdir="${scriptdir}/runtime/win32-x86_64/" + output="${archdir}/tclsh902z.exe" + runtime_available=1 +elif [[ "$plat" == "MINGW64"* ]]; then + #REVIEW os="win32" url="${url_kitbase}/win32-x86_64/tclsh902z.exe" archdir="${scriptdir}/runtime/win32-x86_64/" - output="${archdir}/tcsh902z.exe" + output="${archdir}/tclsh902z.exe" + runtime_available=1 +elif [[ "$plat" == "CYGWIN_NT"* ]]; then + os="win32" + url="${url_kitbase}/win32-x86_64/tclsh902z.exe" + archdir="${scriptdir}/runtime/win32-x86_64/" + output="${archdir}/tclsh902z.exe" runtime_available=1 -elif [[ "$OSTYPE" == "msys" ]]; then +elif [[ "$plat" == "MSYS_NT"* ]]; then echo MSYS os="win32" #use 'command -v' (shell builtin preferred over external which) @@ -64,7 +87,7 @@ elif [[ "$OSTYPE" == "msys" ]]; then output="${archdir}/tclsh902z.exe" runtime_available=1 else - #os="$OSTYPE" + archdir="${scriptdir}/runtime/other" os="other" fi @@ -80,6 +103,10 @@ case "$1" in if [[ $? -eq 0 ]]; then echo "File downloaded to $output" chmod +x $output + if [[ "$plat" == "Linux" ]]; then + echo "Please ensure libxFt.so.2 is available" + echo "e.g on Ubuntu: sudo apt-get install libxft2" + fi else echo "Error: Failed to download to $output" fi @@ -88,24 +115,25 @@ case "$1" in fi ;; "list") - if [ -d $archdir ]; then + if [[ -d "$archdir" ]]; then echo "$(ls $archdir -1 | wc -l) files in $archdir" echo $(ls $archdir -1) else - echo "No runtimes available in $archdir\n Use '$0 fetch' to install." + echo -e "No runtimes available in $archdir\n Use '$0 fetch' to install." fi ;; "run") #todo - lookup active runtime for os-arch from .toml file activeruntime=$(ls $archdir -1 | tail -n 1) activeruntime_fullpath="$archdir/$activeruntime" - echo "using $activeruntime_fullpath" + #echo "using $activeruntime_fullpath" shift - echo "args: $@" + #echo "args: $@" $activeruntime_fullpath "$@" ;; *) echo "Usage: $0 {fetch|list|run}" + echo "received $@" exit 1 ;; esac diff --git a/src/scriptapps/runtime.ps1 b/src/scriptapps/runtime.ps1 index f6cab3b8..87c00e17 100644 --- a/src/scriptapps/runtime.ps1 +++ b/src/scriptapps/runtime.ps1 @@ -36,7 +36,7 @@ function GetDynamicParamDictionary { } function ParameterDefinitions { param( - [Parameter(ValueFromRemainingArguments=$true)] $opts + [Parameter(ValueFromRemainingArguments=$true,Position = 1)][string[]] $opts ) } @@ -44,15 +44,28 @@ function psmain { [CmdletBinding()] #Empty param block (extra params can be added) param( - [Parameter(Mandatory=$false)][string] $action + [Parameter(Mandatory=$false, Position = 0)][string] $action = "" ) dynamicparam { if ($action -eq 'list') { + $parameterAttribute = [System.Management.Automation.ParameterAttribute]@{ + ParameterSetName = "listruntime" + Mandatory = $false + } + $attributeCollection = [System.Collections.ObjectModel.Collection[System.Attribute]]::new() + $attributeCollection.Add($parameterAttribute) + $dynParam1 = [System.Management.Automation.RuntimeDefinedParameter]::new( + 'remote', [switch], $attributeCollection + ) + $paramDictionary = [System.Management.Automation.RuntimeDefinedParameterDictionary]::new() + $paramDictionary.Add('remote', $dynParam1) + return $paramDictionary } elseif ($action -eq 'fetch') { #GetDynamicParamDictionary ParameterDefinitions $parameterAttribute = [System.Management.Automation.ParameterAttribute]@{ ParameterSetName = "fetchruntime" Mandatory = $false + Position = 1 } $attributeCollection = [System.Collections.ObjectModel.Collection[System.Attribute]]::new() $attributeCollection.Add($parameterAttribute) @@ -65,8 +78,39 @@ function psmain { $paramDictionary.Add('runtime', $dynParam1) return $paramDictionary } elseif ($action -eq 'run') { - GetDynamicParamDictionary ParameterDefinitions + #GetDynamicParamDictionary ParameterDefinitions + $parameterAttribute = [System.Management.Automation.ParameterAttribute]@{ + ParameterSetName = "runargs" + Mandatory = $false + ValueFromRemainingArguments = $true + } + $attributeCollection = [System.Collections.ObjectModel.Collection[System.Attribute]]::new() + $attributeCollection.Add($parameterAttribute) + + $dynParam1 = [System.Management.Automation.RuntimeDefinedParameter]::new( + 'opts', [string[]], $attributeCollection + ) + + $paramDictionary = [System.Management.Automation.RuntimeDefinedParameterDictionary]::new() + $paramDictionary.Add('opts', $dynParam1) + return $paramDictionary } else { + #accept all args when action is unrecognised - so we can go to help anyway + $parameterAttribute = [System.Management.Automation.ParameterAttribute]@{ + ParameterSetName = "invalidaction" + Mandatory = $false + ValueFromRemainingArguments = $true + } + $attributeCollection = [System.Collections.ObjectModel.Collection[System.Attribute]]::new() + $attributeCollection.Add($parameterAttribute) + + $dynParam1 = [System.Management.Automation.RuntimeDefinedParameter]::new( + 'opts', [string[]], $attributeCollection + ) + + $paramDictionary = [System.Management.Automation.RuntimeDefinedParameterDictionary]::new() + $paramDictionary.Add('opts', $dynParam1) + return $paramDictionary } } process { @@ -74,7 +118,7 @@ function psmain { #write-host "Bound Parameters:$($PSBoundParameters.Keys)" switch ($PSBoundParameters.keys) { 'action' { - #write-host "got action " $PSBoundParameters.action + write-host "got action " $PSBoundParameters.action Set-Variable -Name $_ -Value $PSBoundParameters."$_" $known_actions = @("fetch", "list", "run") if (-not($known_actions -contains $action)) { @@ -83,10 +127,10 @@ function psmain { } } 'opts' { - #write-warning "Unused parameters: $($PSBoundParameters.$_)" + # write-warning "Unused parameters: $($PSBoundParameters.$_)" } Default { - #write-warning "Unhandled parameter -> [$($_)]" + # write-warning "Unhandled parameter -> [$($_)]" } } #foreach ($boundparam in $PSBoundParameters.Keys) { @@ -100,11 +144,15 @@ function psmain { $outbase = Resolve-Path -Path $outbase #expected script location is the bin folder of a punk project $rtfolder = Join-Path -Path $outbase -ChildPath "runtime" - $archfolder = Join-Path -Path $rtfolder -ChildPath "win32-x86_64" + #Binary artifact server url. (git is not ideal for this - but will do for now - todo - use artifact system within gitea?) + $artifacturl = "https://www.gitea1.intx.com.au/jn/punkbin/raw/branch/master" switch ($action) { 'fetch' { + $arch = "win32-x86_64" + $archfolder = Join-Path -Path $rtfolder -ChildPath "$arch" + $archurl = "$artifacturl/$arch" + $sha1url = "$archurl/sha1sums.txt" $runtime = "tclsh902z.exe" - $archurl = "https://www.gitea1.intx.com.au/jn/punkbin/raw/branch/master/win32-x86_64" foreach ($boundparam in $PSBoundParameters.Keys) { write-host "fetchopt: $boundparam $($PSBoundParameters[$boundparam])" } @@ -112,44 +160,138 @@ function psmain { $runtime = $PSBoundParameters["runtime"] } $fileurl = "$archurl/$runtime" - $output = join-path $archfolder $runtime + + $output = join-path -Path $archfolder -ChildPath $runtime + $sha1local = join-path -Path $archfolder -ChildPath "sha1sums.txt" $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 $fileurl ..." - try { - $response = Invoke-WebRequest -Uri $fileurl -OutFile $output -ErrorAction Stop - Write-Host "Runtime saved at $output" + try { + Write-Host "Fetching $sha1url" + Invoke-WebRequest -Uri $sha1url -OutFile $sha1local -ErrorAction Stop + Write-Host "sha1 saved at $sha1local" + } catch { + Write-Host "An error occurred while downloading ${sha1url}: $($_.Exception.Message)" + if ($_.Exception.Response) { + Write-Host "HTTP Status code: $($_.Exception.Response.StatusCode)" + } + } + if (Test-Path -Path $sha1local -PathType Leaf) { + $sha1Content = Get-Content -Path $sha1local + $stored_sha1 = "" + foreach ($line in $sha1Content) { + #all sha1sums have * (binary indicator) - review + $match = [regex]::Match($line,"(.*) [*]${runtime}$") + if ($match.Success) { + $stored_sha1 = $match.Groups[1].Value + Write-host "stored hash from sha1sums.txt: $storedhash" + break + } + } + if ($stored_sha1 -eq "") { + Write-Host "Unable to locate hash for $runtime in $sha1local - Aborting" + Write-Host "Please download and verify manually" + return + } + + $need_download = $false + if (Test-Path -Path $output -PathType Leaf) { + Write-Host "Runtime already found at $output" + Write-Host "Checking sha1 checksum of local file versus sha1 of server file" + $file_sha1 = Get-FileHash -Path "$output" -Algorithm SHA1 + if (${file_sha1}.Hash -ne $stored_sha1) { + Write-Host "$runtime on server has different sha1 hash - Download required" + $need_download = $true + } + } else { + Write-Host "$runtime not found locally - Download required" + $need_download = $true } - catch { - Write-Host "An error occurred: $($_.Exception.Message)" - if ($_.Exception.Response) { - Write-Host "HTTP Status code: $($_.Exception.Response.StatusCode)" + + if ($need_download) { + Write-Host "Downloading from $fileurl ..." + try { + Invoke-WebRequest -Uri $fileurl -OutFile "${output}.tmp" -ErrorAction Stop + Write-Host "Runtime saved at $output.tmp" + } + catch { + Write-Host "An error occurred while downloading $fileurl $($_.Exception.Message)" + if ($_.Exception.Response) { + Write-Host "HTTP Status code: $($_.Exception.Response.StatusCode)" + } + return + } + Write-Host "comparing sha1 checksum of downloaded file with data in sha1sums.txt" + Start-Sleep -Seconds 1 #REVIEW - give at least some time for windows to do its thing? (av filters?) + $newfile_sha1 = Get-FileHash -Path "${output}.tmp" -Algorithm SHA1 + if (${newfile_sha1}.Hash -eq $stored_sha1) { + Write-Host "sha1 checksum ok" + Move-Item -Path "${output}.tmp" -Destination "${output}" -Force + Write-Host "Runtime is available at ${output}" + } else { + Write-Host "WARNING! sha1 of downloaded file at $output.tmp does not match stored sha1 from sha1sums.txt" + return } + } else { + Write-Host "Local copy of runtime at $output seems to match sha1 checksum of file on server." + Write-Host "No download required" } } else { - Write-Host "Runtime already found at $output" + Write-Host "Unable to consult local copy of sha1sums.txt at $sha1local" + if (Test-Path -Path $output -PathType Leaf) { + Write-Host "A runtime is available at $output - but we failed to retrieve the list of sha1sums from the server" + Write-Host "Unable to check for updated version at this time." + } else { + Write-Host "Please retry - or manually download a runtime from $archurl and verify checksums" + } } } 'run' { #select first (or configured default) runtime and launch, passing arguments + $arch = "win32-x86_64" + $archfolder = Join-Path -Path $rtfolder -ChildPath "$arch" if (-not(Test-Path -Path $archfolder -PathType Container)) { write-host "No runtimes seem to be installed for win32-x86_64`nPlease use 'runtime.cmd fetch' to install" } else { $dircontents = (get-childItem -Path $archfolder -File | Sort-Object Name) if ($dircontents.Count -gt 0) { #write-host "run.." - #write-host "num params: $($PSBoundParameters.opts.count)" - #foreach ($boundparam in $PSBoundParameters.opts) { - # write-host $boundparam - #} + write-host "num params: $($PSBoundParameters.opts.count)" + #todo - use 'active' runtime - need to lookup (PSToml?) #when no 'active' runtime for this os-arch - use last item (sorted in dictionary order) - $active = $dircontents[-1] - #write-host "using: $active" - Start-Process -FilePath $active -ArgumentList $PSBoundParameters.opts -NoNewWindow -Wait + $active = $dircontents[-1].FullName + write-host "using: $active" + if ($PSBoundParameters.opts.Length -gt 0) { + $optsType = $PSBoundParameters.opts.GetType() #method can only be called if .opts is not null + write-host "type of opts: $($optsType.FullName)" + foreach ($boundparam in $PSBoundParameters.opts) { + write-host $boundparam + } + Write-Host "opts: $($PSBoundParameters.opts)" + Write-Host "args: $args" + Write-HOst "argscount: $($args.Count)" + $arglist = @() + foreach ($o in $PSBoundParameters.opts) { + $oquoted = $o -replace '"', "`\`"" + #$oquoted = $oquoted -replace "'", "`'" + if ($oquoted -match "\s") { + $oquoted = "`"$oquoted`"" + } + $arglist += @($oquoted) + } + $arglist = $arglist.TrimEnd(' ') + write-host "arglist: $arglist" + #$arglist = $PSBoundParameters.opts + Start-Process -FilePath $active -ArgumentList $arglist -NoNewWindow -Wait + } else { + #powershell 5.1 and earlier can't accept an empty -ArgumentList value :/ !! + #$arglist = @() + #Start-Process -FilePath $active -ArgumentList $arglist -NoNewWindow -Wait + #Start-Process -FilePath $active -ArgumentList "" -NoNewWindow -Wait + Start-Process -FilePath $active -NoNewWindow -Wait + } } else { write-host "No files found in $archfolder" write-host "No runtimes seem to be installed for win32-x86_64`nPlease use 'runtime.cmd fetch' to install." @@ -157,19 +299,104 @@ function psmain { } } 'list' { - if (test-path -Path $archfolder -Type Container) { - $dircontents = (get-childItem -Path $archfolder -File) - write-host "$(${dircontents}.count) files in $archfolder" - foreach ($f in $dircontents) { - write-host $f.Name + #todo - option to list for other os-arch + $arch = 'win32-x86_64' + $archfolder = Join-Path -Path $rtfolder -ChildPath "$arch" + $sha1local = join-path -Path $archfolder -ChildPath "sha1sums.txt" + $archurl = "$artifacturl/$arch" + $sha1url = "$archurl/sha1sums.txt" + if ( $PSBoundParameters.ContainsKey('remote') ) { + write-host "Checking for available remote runtimes for" + Write-Host "Fetching $sha1url" + Invoke-WebRequest -Uri $sha1url -OutFile $sha1local -ErrorAction Stop + Write-Host "sha1 saved at $sha1local" + $sha1Content = Get-Content -Path $sha1local + $remotedict = @{} + foreach ($line in $sha1Content) { + #all sha1sums have * (binary indicator) - review + $match = [regex]::Match($line,"(.*) [*](.*)$") + if ($match.Success) { + $server_sha1 = $match.Groups[1].Value + $server_rt = $match.Groups[2].Value + $remotedict[$server_rt] = $server_sha1 + } + } + + $localdict = @{} + if (test-path -Path $archfolder -Type Container) { + $dircontents = (get-childItem -Path $archfolder -File | Where-object {-not ($(".txt",".tm") -contains $_.Extension) }) + foreach ($f in $dircontents) { + $local_sha1 = Get-FileHash -Path $(${f}.FullName) -Algorithm SHA1 + $localdict[$f.Name] = ${local_sha1}.Hash + } + } + + Write-host "-----------------------------------------------------------------------" + Write-host "Runtimes for $arch" + Write-host "Local $archfolder" + Write-host "Remote $archurl" + Write-host "-----------------------------------------------------------------------" + Write-host "Local Remote" + Write-host "-----------------------------------------------------------------------" + # 12345678910234567892023456789302345 + $G = "`e[32m" #Green + $Y = "`e[33m" #Yellow + $R = "`e[31m" #Red + $RST = "`e[m" + foreach ($key in $localdict.Keys) { + $local_sha1 = $($localdict[$key]) + if ($remotedict.ContainsKey($key)) { + if ($local_sha1 -eq $remotedict[$key]) { + $rhs = "Same version" + $C = $G + } else { + $rhs = "UPDATE AVAILABLE" + $C = $Y + } + } else { + $C = $R + $rhs = "(not listed on server)" + } + #ansi problems from cmd.exe not in windows terminal - review + $C = "" + $RST = "" + $lhs = "$key".PadRight(35, ' ') + write-host -nonewline "${C}${lhs}${RST}" + write-host $rhs } + $lhs_missing = "-".PadRight(35, ' ') + foreach ($key in $remotedict.Keys) { + if (-not ($localdict.ContainsKey($key))) { + write-host -nonewline $lhs_missing + write-host $key + } + } + Write-host "-----------------------------------------------------------------------" + } else { - write-host "No runtimes seem to be installed for win32-x86_64 in $archfolder`nPlase use 'runtime.cmd fetch' to install." + if (test-path -Path $archfolder -Type Container) { + Write-host "-----------------------------------------------------------------------" + Write-Host "Local runtimes for $arch" + $dircontents = (get-childItem -Path $archfolder -File | Where-object {-not ($(".txt",".tm") -contains $_.Extension) }) + write-host "$(${dircontents}.count) files in $archfolder" + Write-host "-----------------------------------------------------------------------" + foreach ($f in $dircontents) { + write-host $f.Name + } + Write-host "-----------------------------------------------------------------------" + Write-host "Use: 'list -remote' to compare local runtimes with those available on the artifact server" + } else { + write-host "No runtimes seem to be installed for win32-x86_64 in $archfolder`nPlease use 'runtime.cmd fetch' to install." + } } } default { $actions = @("fetch", "list", "run") write-host "Available actions: $actions" + write-host "received" + foreach ($boundparam in $PSBoundParameters.opts) { + write-host $boundparam + } } } @@ -177,8 +404,9 @@ function psmain { } } #write-host (psmain @args) -$returnvalue = psmain @args +#$returnvalue = psmain @args #Write-Host "Function Returned $returnvalue" -ForegroundColor Cyan -return $returnvalue +#return $returnvalue +psmain @args | out-null exit 0 diff --git a/src/scriptapps/runtime_wrap.toml b/src/scriptapps/runtime_wrap.toml index c9840a08..41285863 100644 --- a/src/scriptapps/runtime_wrap.toml +++ b/src/scriptapps/runtime_wrap.toml @@ -15,6 +15,8 @@ #valid nextshelltype entries are: tcl perl powershell bash. #nextshellpath entries must be 64 characters or less. - win32.nextshellpath="powershell" + #don't use -c for launching - or in old powershell, arguments such as "a b" will become 2 arguments a b + #do use -File (even though pwsh doesn't require it) + win32.nextshellpath="powershell -nop -nol -ExecutionPolicy bypass -File" win32.nextshelltype="powershell" win32.outputfile="runtime.cmd" diff --git a/src/scriptapps/tclargs.tcl b/src/scriptapps/tclargs.tcl new file mode 100644 index 00000000..47258278 --- /dev/null +++ b/src/scriptapps/tclargs.tcl @@ -0,0 +1,9 @@ +puts stdout "::argc" +puts stdout $::argc +puts stdout "::argv" +puts stdout "$::argv" +puts stdout ----------------------- +foreach a $::argv { + puts stdout $a +} +puts stdout -done- \ No newline at end of file diff --git a/src/scriptapps/tclargs_wrap.toml b/src/scriptapps/tclargs_wrap.toml new file mode 100644 index 00000000..807fbdd4 --- /dev/null +++ b/src/scriptapps/tclargs_wrap.toml @@ -0,0 +1,15 @@ +[application] + template="punk.multishell.cmd" + as_admin=false + + scripts=[ + "tclargs.tcl", + ] + + default_outputfile="tclargs.cmd" + default_nextshellpath="tclsh" + default_nextshelltype="tcl" + + win32.nextshellpath="tclsh" + win32.nextshelltype="tcl" + win32.outputfile="tclargs.cmd" \ No newline at end of file diff --git a/src/vendormodules/www-2.8.tm b/src/vendormodules/www-2.8.tm new file mode 100644 index 00000000..7fc6b616 --- /dev/null +++ b/src/vendormodules/www-2.8.tm @@ -0,0 +1,2048 @@ +# Package implementing the HTTP protocol. The http package shipping with Tcl +# is too cumbersome and has too many issues to be used effectively. + +# Test sites: +# http://jigsaw.w3.org/HTTP/ +# http://httpbin.org/ + +package require platform +package require Thread +package require sqlite3 + +if {$tcl_platform(platform) ne "windows"} { + # Need the fix for bug f583715154 + package require Tcl 8.6.11- +} + +proc ::oo::Helpers::callback {method args} { + list [uplevel 1 {::namespace which my}] $method {*}$args +} + +namespace eval www { + variable schemes { + http {port 80 command {} secure 0} + https {port 443 command www::encrypt secure 1} + } + variable encodings { + gzip {decode gzip} + deflate {decode deflate} + } + variable config { + -proxy defaultproxy + -pipeline 0 + -urlencoding utf-8 + -socketcmd socket + } + variable headers { + Accept {*/*} + Accept-Encoding {identity} + } + dict set headers User-Agent [format {Tcl-www/%s (%s)} \ + [package present www] [platform::generic]] + + variable formmap [apply [list {} { + set map {} + for {set i 0} {$i <= 256} {incr i} { + set c [format %c $i] + if {![string match {[-._~a-zA-Z0-9]} $c]} { + dict set map $c %[format %.2X $i] + } + } + return $map + }]] + variable tlscfg {} + variable defaultproxy {} + variable logpfx list + variable timer {} + variable persist 300000 + variable maxconn 256 + + # Track the persistent connections using an in-memory sqlite db + sqlite3 [namespace current]::db :memory: + db eval { + create table reuse ( + connection text primary key, + scheme text, + host text, + port text, + persistent boolean default 1 + ); + } + + namespace ensemble create -subcommands { + get post head put delete log configure register certify cookiedb + header urlencode cookies + } -map { + log logpfx + cookiedb cookies::dbfile + } + + namespace ensemble create -command cert -parameters pass -map { + error errcmd info nop verify vfycmd message nop session nop + } -unknown [namespace code unknown] + + namespace ensemble create -command stdcert -parameters pass -map { + error errcmd info nop verify stdvfy message nop session nop + } -unknown [namespace code unknown] + + namespace ensemble create -command nocert -parameters pass -map { + error errcmd info nop verify novfy message nop session nop + } -unknown [namespace code unknown] + + dict set tlscfg -command [list [namespace which nocert] 1] + dict set tlscfg -validatecommand [list [namespace which nocert] 1] +} + +proc www::log {str} { + variable logpfx + if {[catch {uplevel #0 [list {*}$logpfx $str]}]} {logpfx ""} +} + +proc www::logpfx {prefix} { + variable logpfx $prefix + if {$prefix eq ""} {set logpfx list} +} + +# Load the TLS package on the first use of a secure url. +proc www::encrypt {sock host} { + variable tlscfg + package require tls + if {[namespace which ::tls::validate_command] eq ""} { + # Old version of tls uses only -command + dict unset tlscfg -validatecommand + } + proc encrypt {sock host} { + variable tlscfg + ::tls::import $sock -servername $host {*}$tlscfg + } + tailcall encrypt $sock $host +} + +# Execute a script when a variable is accessed +proc www::varevent {name ops {script ""}} { + set cmd {{cmd var arg op} {catch {uplevel #0 $cmd}}} + foreach n [uplevel 1 [list trace info variable $name]] { + lassign $n op prefix + if {$op eq $ops && \ + [lindex $prefix 0] eq "apply" && [lindex $prefix 1] eq $cmd} { + if {[llength [info level 0]] < 4} { + return [lindex $prefix 2] + } + uplevel 1 [list trace remove variable $name $ops $prefix] + } + } + if {$script ne ""} { + uplevel 1 \ + [list trace add variable $name $ops [list apply $cmd $script]] + } + return +} + +oo::class create www::connection { + constructor {host port {transform ""}} { + namespace path [linsert [namespace path] 0 ::www] + variable fd "" timeout 30000 id "" + variable translation {crlf crlf} + variable waiting {} pending {} + # Copy the arguments to namespace variables with the same name + namespace eval [namespace current] \ + [list variable host $host port $port transform $transform] + } + + destructor { + my Disconnect + } + + method Disconnect {} { + my variable fd id + after cancel $id + if {$fd ne ""} { + rename ::www::$fd "" + if {[catch {close $fd} err]} {log "Disconnect: $err"} + set fd "" + } + } + + method Failed {code info {index 0}} { + my variable pending + my Disconnect + set callback [dict get [lindex $pending $index] Request callback] + set opts [dict create -code 1 -level 1 -errorcode $code] + # Clean up the pending request before invoking the callback in case + # the coroutine generates another request for the same connection + set pending [lreplace $pending $index $index] + $callback -options $opts $info + } + + method Failure {args} { + if {[llength $args] == 1} { + set opts [lindex $args] + } else { + set opts [dict create -code 1 -level 1] + lassign $args errorcode result + dict set opts -errorcode $errorcode + } + my variable waiting pending + foreach n [concat $pending $waiting] { + # Inform the caller of the failure + if {[catch {uplevel #0 [linsert [dict get $n callback] end $opts]} err opts]} { + log "Failure: $err" + } + } + my destroy + } + + method Pending {} { + my variable pending + set num 0 + foreach transaction $pending { + if {[dict get $transaction Attempt] > 5} { + my Failed {WWW MAXATTEMPTS} {too many attempts} $num + } else { + incr num + } + } + return [expr {$num > 0}] + } + + method Process {} { + my variable fd waiting pending + if {[llength $waiting] == 0} return + set count [llength $pending] + if {$count && [dict get [lindex $waiting 0] pipeline] == 0} return + if {$count && $fd eq ""} return + # Start processing the next request + set request [my PushRequest] + if {$fd eq ""} { + my Connect + } else { + my Request $count + } + } + + # Connect the socket in another thread to be totally non-blocking + method Connect {} { + my Disconnect + if {![my Pending]} return + coroutine connect my Initiate + } + + method Initiate {} { + if {[my Contact]} { + if {[catch {my Request} err opts]} { + log "Request: $err" + log [dict get $opts -errorinfo] + } + } + } + + method Timeout {} { + my variable pending timeout + if {[dict exists [lindex $pending 0] Request timeout]} { + return [dict get [lindex $pending 0] Request timeout] + } else { + return $timeout + } + } + + method UserVar {data} { + if {[dict exists $data Request result]} { + upvar #0 [dict get $data Request result] var + set var [dict filter $data key {[a-z]*}] + } + } + + method Contact {} { + my variable fd host port connect transform + + # Build a command to open a socket in a separate thread + set cmd [list {cmd} { + global fd result + if {![catch $cmd fd opts]} { + fileevent $fd writable {set result socket} + vwait result + fileevent $fd writable {} + if {[fconfigure $fd -connecting]} { + close $fd + set msg {connection timed out} + set fd "couldn't open socket: $msg" + dict set opts -code 1 + dict set opts -errorcode [list POSIX ETIMEDOUT $msg] + } else { + set error [fconfigure $fd -error] + if {$error eq ""} { + thread::detach $fd + } else { + close $fd + set fd "couldn't open socket: $error" + dict set opts -code 1 + switch $error { + {connection refused} { + dict set opts \ + -errorcode [list POSIX ECONNREFUSED $error] + } + {host is unreachable} { + dict set opts \ + -errorcode [list POSIX EHOSTUNREACH $error] + } + } + } + } + } + return [list $fd $opts] + }] + + set socketcmd [linsert [cget -socketcmd] end -async $host $port] + set script [list apply $cmd $socketcmd] + # Open a plain socket in a helper thread + set tid [thread::create] + set ms [my Timeout] + set id [after $ms [list thread::send -async $tid {set result timeout}]] + set var [namespace which -variable connect] + thread::send -async $tid $script $var + trace add variable $var write [list [info coroutine]] + yieldto list + trace remove variable $var write [list [info coroutine]] + after cancel $id + lassign $connect result opts + thread::release $tid + # Check the socket was opened successfully + if {[dict get $opts -code] == 0} { + set fd $result + coroutine ::www::$fd my Monitor + thread::attach $fd + fconfigure $fd -blocking 0 + # Apply any transformations, such as importing TLS + if {$transform ne ""} { + try { + {*}$transform $fd $host + } trap WWW {result opts} { + # Immediately return WWW errors, without retrying + my Failed [dict get $opts -errorcode] $result + } on error {err opts} { + log "Transform: $err" + } + } + return 1 + } else { + my Failed [list WWW CONNECT $result] $result + } + return 0 + } + + method Monitor {} { + set result [yield] + my Failed [list WWW CONNECT $result] $result + } + + method Request {{num 0}} { + my variable fd pending id + if {[eof $fd]} { + my Connect + } + + my Result connection [self] + set transaction [lindex $pending $num] + dict incr transaction Attempt + lset pending $num $transaction + # Do not report the failure at this point because the callback may + # create a new request that would mess up the order of the messages + if {[dict get $transaction Attempt] > 5} {tailcall my Pending} + try { + my Transmit [dict get $transaction Request] + } trap {POSIX EPIPE} {} { + # Force eof condition + read $fd + tailcall my Connect + } + # Now report any problems to the callers + my Pending + + if {$num == 0} {my Response} + tailcall my Process + } + + method Transmit {request} { + my variable fd + fconfigure $fd -translation [set translation {crlf crlf}] + set method [dict get $request method] + set resource [dict get $request resource] + set head [list "$method $resource HTTP/1.1"] + lappend head "Host: [dict get $request host]" + if {[dict exists $request upgrade]} { + dict update request headers hdrs upgrade upgrade { + header add hdrs Connection Upgrade + header add hdrs Upgrade {*}[dict keys $upgrade] + } + } + foreach {key val} [dict get $request headers] { + lappend head "$key: $val" + } + lappend head "" + set str [join $head \n] + log $str + puts $fd $str + if {[dict exists $request body]} { + fconfigure $fd -translation [lset translation 1 binary] + puts -nonewline $fd [dict get $request body] + } + flush $fd + } + + method Result {args} { + my variable pending + set response [lindex $pending 0] + if {[llength $args] > 1} { + lset pending 0 [dict set response {*}$args] + my UserVar $response + } elseif {[llength $args] == 0} { + return $response + } elseif {[dict exists $response {*}$args]} { + return [dict get $response {*}$args] + } + return + } + + method Response {} { + my variable fd translation id + set ms [my Timeout] + set id [after $ms [callback Timedout]] + fconfigure $fd -translation [lset translation 0 crlf] + # When the tls handshake fails, the readable event doesn't always + # fire. Adding a writable event as well improves reliability. + fileevent $fd readable [callback Statusline] + fileevent $fd writable [callback Statusline] + } + + method Statusline {} { + my variable fd + try { + fileevent $fd writable {} + if {[eof $fd]} { + my Connect + } elseif {[gets $fd line] >= 0} { + log $line + if {[scan $line {HTTP/%s %d %n} version code pos] != 3} { + my Failed [list WWW DATA STATUS] "invalid status line" + } + set reason [string range $line $pos end] + my Result status [dict create line $line \ + version HTTP/$version code $code reason $reason] + fileevent $fd readable [callback Responsehead] + } elseif {[chan pending input $fd] > 1024} { + # A status line shouldn't be this long. + my Failed [list WWW DATA STATUS] "status line too long" + } + } trap {POSIX ECONNABORTED} {msg opts} { + # This happens if there is a problem with the certificate + my Failed [dict get $opts -errorcode] $msg + } + } + + method Responsehead {} { + my variable fd + if {[eof $fd]} { + tailcall my Connect + } + set head [my Result Head] + while {[gets $fd line] >= 0} { + if {$line eq ""} { + set headers [my Headers $head] + my Result Head {} + my Result headers $headers + tailcall my Responsebody $headers + } + lappend head $line + } + my Result Head $head + } + + method Headers {head} { + # Unfold headers + foreach x [lreverse [lsearch -all -regexp $head {^\s}]] { + set str [string trimright [lindex $head [expr {$x - 1}]]] + append str " " [string trimleft [lindex $head $x]] + set head [lreplace $head [expr {$x - 1}] $x $str] + } + log [join $head \n]\n + # Parse headers into a list + set rc {} + foreach str $head { + lassign [slice $str] name value + lappend rc [string tolower $name] $value + } + return $rc + } + + method Responsebody {headers} { + my variable fd translation + set code [dict get [my Result status] code] + variable size 0 length 0 + if {[dict get [my Result Request] method] eq "HEAD"} { + # All responses to the HEAD request method MUST NOT include + # a message-body, even though the presence of entity-header + # fields might lead one to believe they do + tailcall my Finished + } elseif {$code eq "101" && [header exists $headers upgrade]} { + tailcall my Upgrade $headers + } elseif {[string match 1?? $code] || $code in {204 304}} { + # All 1xx (informational), 204 (no content), and 304 (not + # modified) responses MUST NOT include a message-body + tailcall my Finished + } + set enc [header get $headers content-encoding all -lowercase] + set transfer [header get $headers transfer-encoding all -lowercase] + foreach n $transfer {if {$n ni {chunked identity}} {lappend enc $n}} + if {[llength $transfer] == 0} {set transfer [list identity]} + my Result Encoding [lmap name [lreverse $enc] { + set coro encodingcoro_$name + coroutine $coro {*}[encodingcmd $name] + set coro + }] + if {"identity" ni $transfer} { + fileevent $fd readable [callback Responsechunks] + } elseif {[header exists $headers content-length]} { + set length [header get $headers content-length last] + if {$length} { + fconfigure $fd -translation [lset translation 0 binary] + fileevent $fd readable [callback Responsecontent] + } else { + my Finished + } + } elseif {[header get $headers content-type last] \ + eq "multipart/byteranges"} { + # Not currently implemented + my Failure + } else { + # Read data until the connection is closed + fconfigure $fd -translation [lset translation 0 binary] + fileevent $fd readable [callback Responserest] + } + } + + method Responsecontent {} { + my variable fd size length + if {[eof $fd]} { + tailcall my Connect + } + set data [read $fd [expr {$length - $size}]] + if {$data ne ""} { + incr size [string length $data] + my Progress $data + log "Received $size/$length" + if {$size >= $length} { + my Finished + } + } + } + + method Responsechunks {} { + my variable fd translation size length + if {[eof $fd]} { + tailcall my Finished + } + if {$length == 0} { + if {[gets $fd line] <= 0} return + lassign [slice $line {;}] hex ext + scan $hex %x length + if {$length == 0} { + fileevent $fd readable [callback Responsetrailer] + return + } + set size 0 + fconfigure $fd -translation [lset translation 0 binary] + } + set data [read $fd [expr {$length - $size}]] + if {$data ne ""} { + incr size [string length $data] + # log "$size/$length" + my Progress $data + if {$size >= $length} { + fconfigure $fd -translation [lset translation 0 crlf] + set length 0 + } + } + } + + method Responsetrailer {} { + my variable fd + set tail [my Result Tail] + if {[eof $fd]} { + set done 1 + } else { + set done 0 + while {[gets $fd line] >= 0} { + if {$line eq ""} { + set done 1 + break + } + lappend tail $line + } + } + if {$done} { + if {$tail ne ""} { + my Result Tail {} + set headers [my Result headers] + my Result headers [dict merge $headers [my Headers $tail]] + } + tailcall my Finished + } else { + my Result Tail $tail + } + } + + method Responserest {} { + my variable fd + if {[eof $fd]} { + tailcall my Finished + } + my Progress [read $fd] + } + + method Responseidle {} { + my variable fd + read $fd + if {[eof $fd]} { + my destroy + } + } + + method Progress {{data ""}} { + set finish [expr {$data eq ""}] + foreach n [my Result Encoding] { + if {$data ne ""} {set data [$n $data]} + if {$finish} {append data [$n]} + } + if {$data eq ""} return + + set request [my Result Request] + set handler \ + [if {[dict exists $request handler]} {dict get $request handler}] + + if {$handler eq ""} { + set body [my Result Body] + my Result Body [append body $data] + } else { + uplevel #0 [linsert $handler end $data] + } + } + + method PushRequest {} { + # Move the next request from the waiting queue to the pending queue + my variable waiting pending + set waiting [lassign $waiting request] + set transaction [dict create Request $request Attempt 0] + # Provide some information back to the caller + dict set transaction url [dict get $request url] + dict set transaction uri [dict get $request resource] + lappend pending $transaction + return $request + } + + method PopRequest {} { + my variable pending + set pending [lassign $pending result] + return $result + } + + method Finished {} { + my variable fd id pending waiting + # Process any leftover data and end the coroutines + my Progress + set result [my PopRequest] + if {[scan [dict get $result status version] HTTP/%s version] != 1} { + tailcall my Failure \ + "invalid HTTP version: [dict get $result status version]" + } + set connection \ + [header get [dict get $result headers] connection all -lowercase] + after cancel $id + if {[llength $pending]} { + my Response + } else { + fileevent $fd readable [callback Responseidle] + } + if {![package vsatisfies $version 1.1] || "close" in $connection} { + my Disconnect + my Return $result + if {[llength $pending] == 0 && [llength $waiting] == 0} { + # Nothing left to do. Destroy the object, if it still exists. + if {[self] ne ""} {my destroy} + return + } + } else { + keep [self] + my Return $result + } + # The callback may have destroyed the object + if {[self] ne ""} {my Process} + } + + method Return {result} { + set callback [dict get $result Request callback] + set data [if {[dict exists $result Body]} {dict get $result Body}] + dict unset result connection + my UserVar $result + # Just like in TclOO, public names start with a lowercase letter + $callback -options [dict filter $result key {[a-z]*}] $data + } + + method Upgrade {headers} { + my variable fd id + set upgrade [header get $headers upgrade] + # Unfortunately (some) upgrade protocol names are not case sensitive + try { + dict for {name mixin} [dict get [my Result Request] upgrade] { + if {![string equal -nocase $name $upgrade]} continue + after cancel $id + oo::objdefine [self] mixin $mixin + my Startup $headers + return + } + my Failed {WWW UPGRADE} "protocol not supported: $upgrade" + } on error {msg info} { + log [dict get $info -errorinfo] + } + } + + method Timedout {} { + my Failed {WWW DATA TIMEOUT} "timeout waiting for a response" + } + + method request {data} { + my variable waiting + dict set data callback [info coroutine] + lappend waiting $data + return {*}[yieldto my Process] + } + + method fd {} { + my variable fd + return $fd + } + + method disconnect {} { + my Finished + } +} + +# Use a derived class to simplify setting up an HTTP tunnel to a proxy server +oo::class create www::proxyconnect { + superclass www::connection + + constructor {fh} { + namespace path [linsert [namespace path] 0 ::www] + variable fd $fh timeout 30000 id "" + variable translation {crlf crlf} + variable waiting {} pending {} + } + + destructor { + # Obscure the connection destructor, which would disconnect the socket + } + + method connect {resource} { + set request {headers {}} + dict set request method CONNECT + dict set request resource $resource + dict set request host $resource + dict set request url $resource + dict set request path $resource + try { + my request $request + } on ok {data opts} { + set code [dict get $opts status code] + if {![string match 2?? $code]} { + set codegrp [string replace $code 1 2 XX] + set reason [dict get $opts status reason] + dict set opts -code 1 + dict set opts -errorcode [list WWW CODE $codegrp $code $reason] + } + return -options [dict incr opts -level] $data + } + } + + method Responsebody {headers} { + set code [dict get [my Result status] code] + if {[string match 2?? $code]} { + # A "200 Connection established" response doesn't have a body + tailcall my Finished + } else { + # All other responses are treated normally, but will finally fail + next $headers + } + } +} + +namespace eval www::cookies { + variable cookiejar "" + namespace path [namespace parent] + namespace ensemble create -subcommands {delete get store} +} + +proc www::cookies::dbfile {filename} { + variable cookiejar $filename +} + +proc www::cookies::db {args} { + variable cookiejar + sqlite3 [namespace current]::db $cookiejar + set create { + create table if not exists %s.cookies ( + domain text, + path text, + name text, + value text, + created int, + accessed int, + expires int not null default 4294967295, + attributes text, + primary key (domain, path, name) + ); + } + db transaction { + db eval [format $create main] + # Add a temporary database to hold the session cookies + db eval {attach database "" as sess} + db eval [format $create sess] + # Create a view combining the two tables to simplify access + # This must be a temporary view to allow combining two databases + db eval { + create temp view cookieview as \ + select domain, path, name, value, \ + created, accessed, expires, attributes \ + from main.cookies \ + union all \ + select domain, path, name, value, \ + created, accessed, expires, attributes \ + from sess.cookies + } + # Clean up expired cookies + set now [clock seconds] + db eval {delete from cookies where expires < $now} + } + tailcall db {*}$args +} + +proc www::cookies::date {str} { + # Implement most of the weird date and time parsing rules of RFC 6265 + # https://tools.ietf.org/html/rfc6265#section-5.1.1 + set time {} + foreach token [regexp -all -inline -nocase {[0-9A-Z:]+} $str] { + switch -nocase -regexp -matchvar match $token { + {^\d\d?:\d\d?:\d\d?} { + if {![dict exists $time %T]} { + dict set time %T $match + } + } + {^\d{5}} {} + {^\d{4}} { + if {![dict exists $time %Y]} { + dict set time %Y $match + } + } + {^\d{3}} {} + {^\d{2}} { + if {![dict exists $time %d]} { + dict set time %d $match + } elseif {![dict exists $time %Y]} { + incr match [expr {$match < 70 ? 2000 : 1900}] + dict set time %Y $match + } + } + ^jan - ^feb - ^mar - ^apr - + ^may - ^jun - ^jul - ^aug - + ^sep - ^oct - ^nov - ^dec { + if {![dict exists $time %b]} { + dict set time %b $match + } + } + } + } + if {[dict size $time] == 4} { + return [clock scan [join [dict values $time]] \ + -format [join [dict keys $time]] -timezone :UTC] + } + # invalid expiry date +} + +proc www::cookies::store {url args} { + set rec [parseurl $url] + set now [clock seconds] + db transaction { + foreach n $args { + set args {} + foreach av [lassign [split $n {;}] pair] { + lassign [slice $av =] key value + dict set args [string tolower $key] $value + } + lassign [slice $pair =] name value + array unset arg + set host [dict get $rec host] + if {[dict exists $args domain]} { + set str [dict get $args domain] + if {[string index $str 0] eq "."} { + set str [string range $str 1 end] + } + set pat [format {*.%s} [string tolower $str]] + if {$host eq $str || [string match $pat $host]} { + set arg(domain) $pat + } else { + # Reject the cookie because of an invalid domain + continue + } + } else { + set arg(domain) $host + } + set path [dict get $rec path] + set arg(path) [file join [if {[dict exists $args path]} { + dict get $args path + } else { + file dirname $path + }] *] + if {![string match $arg(path) $path]} { + # Reject the cookie because of an invalid path + continue + } + if {[dict exists $args max-age]} { + set maxage [dict get $args max-age] + if {[string is integer -strict $maxage]} { + set arg(expires) [expr {[clock seconds] + $maxage}] + } + } elseif {[dict exists $args expires]} { + set sec [date [dict get $args expires]] + if {$sec ne ""} {set arg(expires) $sec} + } + if {[dict exists $args secure]} { + lappend arg(attr) secure + } + if {[dict exists $args httponly]} { + lappend arg(attr) httponly + } + set arg(created) $now + set arg(accessed) $now + db eval { + select created, attributes from cookies \ + where name = $name \ + and domain = $arg(domain) and path = $arg(path) + } { + set arg(created) $created + } + if {[info exists arg(expires)]} {set db main} else {set db sess} + db eval [format { + replace into %s.cookies \ + (domain, path, name, value, created, accessed, expires, attributes) \ + values ($arg(domain), $arg(path), $name, $value, $arg(created), $arg(accessed), $arg(expires), $arg(attr)) + } $db] + } + } +} + +proc www::cookies::get {url} { + set rec [parseurl $url] + set host [dict get $rec host] + set path [dict get $rec path] + set scheme [dict get $rec scheme] + set attr {} + if {[secure $scheme]} {lappend attr secure} + if {$scheme in {http https}} {lappend attr httponly} + set now [clock seconds] + set rc {} + db eval { + select name, value, attributes, expires from cookieview \ + where (domain = '*.' || $host or $host glob domain) \ + and $path glob path \ + order by length(path), created + } { + set allowed [expr {$expires >= $now}] + foreach a $attributes { + if {$a ni $attr} {set allowed 0} + } + if {$allowed} { + lappend rc $name $value + } + } + return $rc +} + +proc www::cookies::delete {url args} { + set rec [parseurl $url] + set host [dict get $rec host] + set where [list {domain = $host}] + if {$host ne $url} { + set path [dict get $rec path] + lappend where {$path glob path} + } + set i 0 + set names [lmap n $args { + set arg([incr i]) $n + format {$arg(%d)} $i + }] + if {$i} {lappend where [format {name in (%s)} [join $names ,]]} + set query "delete from %s where [join $where { and }]" + db eval [format $query main.cookies] + db eval [format $query sess.cookies] +} + +proc www::slice {str {sep :}} { + set x [string first $sep $str] + if {$x < 0} {return [list [string trim $str]]} + return [list [string trim [string range $str 0 [expr {$x - 1}]]] \ + [string trim [string range $str [expr {$x + [string length $sep]}] end]]] +} + +proc www::secure {scheme} { + variable schemes + if {[dict exists $schemes $scheme secure]} { + return [dict get $schemes $scheme secure] + } else { + return 0 + } +} + +proc www::urljoin {url args} { + foreach n $args { + switch -glob $n { + *://* { + # Absolute URL + set url $n + } + //* { + # URL relative on current scheme + set x [string first :// $url] + set url [string replace $url [expr {$x + 1} end $n] + } + /* { + # URL relative to the root of the website + set x [string first :// $url] + set x [string first / $url [expr {$x + 3}]] + if {$x < 0} { + append url $n + } else { + set url [string replace $url $x end $n] + } + } + * { + # Relative URL + set x [string first ? $url] + if {$x < 0} { + set x [string first # $url] + if {$x < 0} { + set x [string length $url] + } + } + set x [string last / $url $x] + if {$x < [string first :// $url] + 3} { + append url / $n + } else { + set url [string replace $url $x end $n] + } + } + } + } + return $url +} + +proc www::parseurl {url} { + variable schemes + set list [slice $url ://] + if {[llength $list] < 2} {set list [list http $url]} + lassign $list scheme str + if {![dict exists $schemes $scheme port]} { + throw {WWW URL SCHEME} "unknown scheme: $scheme" + } + lassign [slice $str /] authority str + lassign [slice /$str #] resource fragment + lassign [slice $resource ?] path query + set rc [dict create url $url scheme $scheme host localhost \ + port [dict get $schemes $scheme port] \ + command [dict get $schemes $scheme command] \ + resource $resource path $path fragment $fragment] + set slice [slice $authority @] + dict set rc host [lindex $slice end] + if {[llength $slice] > 1} { + lassign [slice [lindex $slice 0]] username password + dict set rc username $username + dict set rc password $password + } + return $rc +} + +proc www::getopt {var list body} { + upvar 1 $var value + dict for {pat code} $body { + switch -glob -- $pat { + -- {# end-of-options option} + -?*:* {# option requiring an argument + set opt [lindex [split $pat :] 0] + set arg($opt) [dict create pattern $pat argument 1] + # set arg(-$opt) $arg($opt) + } + -?* {# option without an argument + set arg($pat) [dict create pattern $pat argument 0] + # set arg(-$pat) $arg($pat) + } + } + } + while {[llength $list]} { + set rest [lassign $list opt] + # Does it look like an option? + if {$opt eq "-" || [string index $opt 0] ne "-"} break + # Is it the end-of-options option? + if {$opt eq "--"} {set list $rest; break} + set value 1 + if {![info exists arg($opt)]} { + throw {WWW GETOPT OPTION} "unknown option: $opt" + } elseif {[dict get $arg($opt) argument]} { + if {![llength $rest]} { + throw {WWW GETOPT ARGUMENT} \ + "option requires an argument: $opt" + } + set rest [lassign $rest value] + } + uplevel 1 [list switch -- [dict get $arg($opt) pattern] $body] + set list $rest + } + return $list +} + +proc www::stdopts {{body {}}} { + return [dict merge { + -timeout:milliseconds { + dict set request timeout $arg + } + -auth:data { + dict set request headers \ + Authorization "Basic [binary encode base64 $arg]" + } + -digest:cred { + dict set request digest [slice $arg] + } + -persistent:bool { + if {[string is false -strict $arg]} { + dict set request headers Connection close + } + } + -headers:dict { + dict update request headers hdrs { + foreach {name value} $arg { + header append hdrs $name $value + } + } + } + -upgrade:dict { + dict set request upgrade $arg + } + -handler:cmdprefix { + dict set request handler $arg + } + -maxredir:cnt { + dict set request maxredir $arg + } + -infovariable:var { + dict set request result $arg + } + } $body] +} + +proc www::postopts {} { + return { + -multipart:type { + dict set request multipart $arg + } + -name:string { + dict set request partdata name $arg + } + -type:mediatype { + dict set request partdata type $arg + } + -file:file { + dict set request partdata file $arg + dict lappend request parts [dict get $request partdata] + dict unset request partdata file + } + -value:string { + dict set request partdata value $arg + dict lappend request parts [dict get $request partdata] + dict unset request partdata value + } + } +} + +proc www::configure {args} { + variable config + variable headers + set args [getopt arg $args { + -accept:mimetypes { + header add headers Accept {*}$arg + } + -maxconnections:count { + if {[string is integer -strict $arg] && $arg > 0} { + variable maxconn $arg + } else { + return -code error -errorcode {WWW CONFIGURE INVALID} \ + "bad argument \"$arg\": must be a positive integer" + } + } + -persist:milliseconds { + if {[string is integer -strict $arg] && $arg > 0} { + variable persist $arg + } else { + return -code error -errorcode {WWW CONFIGURE INVALID} \ + "bad argument \"$arg\": must be a positive integer" + } + } + -pipeline:boolean { + if {[catch {expr {!!$arg}} arg]} { + return -code error -errorcode {WWW CONFIGURE INVALID} \ + "bad argument \"$arg\": must be a boolean value" + } else { + dict set config -pipeline $arg + } + } + -proxy:cmdprefix { + dict set config -proxy $arg + } + -socketcmd:prefix { + dict set config -socketcmd $arg + } + -useragent:string { + header replace headers User-Agent $arg + } + }] +} + +proc www::cget {opt} { + variable config + if {[dict exists $config $opt]} { + return [dict get $config $opt] + } + set valid [lsort [dict keys $config]] + if {[llength $valid] > 1} {lset valid end "or [lindex $valid end]"} + retrun -code error -errorcode {WWW CONFIGURE UNKNOWN} \ + [format {unknown option: "%s"; must be %s} $opt [join $valid ,]] +} + +proc www::certify {cainfo {prefix ""}} { + variable tlscfg + variable cacheck $prefix + set status 0 + if {$cainfo eq ""} { + set status 1 + dict unset tlscfg -cadir + dict unset tlscfg -cafile + } elseif {[file isdir $cainfo]} { + dict set tlscfg -cadir $cainfo + dict unset tlscfg -cafile + } else { + dict set tlscfg -cafile $cainfo + dict unset tlscfg -cadir + } + if {$prefix ne ""} { + set callback [list [namespace which cert] $status] + } elseif {$cainfo ne ""} { + set callback [list [namespace which stdcert] $status] + } else { + set callback [list [namespace which nocert] $status] + } + dict set tlscfg -command $callback + if {[dict exists $tlscfg -validatecommand]} { + dict set tlscfg -validatecommand $callback + } + # Prevent reusing old connections that were created using a different + # certification strategy. + db eval {select connection from reuse where scheme = 'https'} { + $connection destroy + } +} + +proc www::unknown {args} { + return [list [namespace which nop]] +} + +proc www::nop args {} + +proc www::novfy {args} { + # Accept anything + return 1 +} + +proc www::stdvfy {pass chan depth cert status args} { + return $status +} + +proc www::vfycmd {pass chan depth cert status args} { + variable cacheck + try { + if {$pass} {set status 1} + set rc [uplevel #0 [linsert $cacheck end $depth $cert]] + if {[string is boolean -strict $rc]} {set status [string is true $rc]} + } on error msg { + log "Error: $msg" + } + return $status +} + +proc www::errcmd {pass sock msg} { + # Errors aren't necessarily fatal + # Handshake not complete, will retry later + # Resource temporarily unavailable + #$sock $msg +} + +proc www::encodingcmd {name} { + variable encodings + return [dict get $encodings $name] +} + +namespace eval www { + # The three compression formats deflate, compress, and gzip are all the + # same, except for headers and checksums. The Tcl zlib package uses the + # following mapping: + # deflate: raw compressed data only + # compress: 2-byte header (78 ..) + data + ADLER32 checksum + # gzip: 10-byte header (1F 8B 08 ...) + data + CRC-32 checksum + # The http 1.1 spec rfc2616 uses the same names with the following mapping: + # deflate: 2-byte header (78 ..) + data + ADLER32 checksum + # compress: different compression method used by unix compress command + # gzip: 10-byte header (1F 8B 08 ...) + data + CRC-32 checksum + # One additional complication is that Microsoft got it wrong again and + # made IE to expect a bare deflate stream for content-encoding deflate, + # so some sites may provide that instead of the correct format. Other + # browsers adapted by accepting both types. + namespace ensemble create -command decode \ + -subcommands {gzip compress deflate} +} + +proc www::gzip {} { + set cmd [zlib stream gunzip] + set data [yield] + while {$data ne ""} { + set data [yield [$cmd add $data]] + } + set rc [if {![$cmd eof]} {$cmd add -finalize {}}] + $cmd close + return $rc +} + +proc www::deflate {} { + set cmd [zlib stream decompress] + set data [yield] + if {$data ne ""} { + try { + $cmd add $data + } trap {TCL ZLIB DATA} {} { + # log "Decompress failed, trying inflate" + $cmd close + set cmd [zlib stream inflate] + set data [$cmd add $data] + } on ok {data} { + } + set data [yield $data] + while {$data ne ""} { + set data [yield [$cmd add $data]] + } + } + set rc [if {![$cmd eof]} {$cmd add -finalize {}}] + $cmd close + return $rc +} + +proc www::proxies {rec} { + variable config + set cmd [dict get $config -proxy] + if {$cmd eq ""} {return [list DIRECT]} + set host [dict get $rec host] + set scheme [dict get $rec scheme] + if {$scheme eq "https"} { + set url [format %s://%s/ $scheme $host] + } else { + set url [dict get $rec url] + } + try { + return [uplevel 0 [linsert $cmd end $url $host]] + } on error {err opts} { + return [list DIRECT] + } +} + +proc www::noproxy {url host} { + return [list DIRECT] +} + +proc www::defaultproxy {url host} { + variable defaultproxy + if {[dict size $defaultproxy] == 0} { + global env + dict set defaultproxy no {} + foreach n [array names env -regexp {(?i)_proxy$}] { + set scheme [string tolower [string range $n 0 end-6]] + set proxy $env($n) + if {$scheme eq "no"} { + dict set defaultproxy no [split $proxy {;,}] + continue + } elseif {[string match *://* $proxy]} { + set proxy [dict get [parseurl $env(http_proxy)] host] + } + dict set defaultproxy $scheme [list [list PROXY $proxy]] + } + } + set scheme [lindex [slice $url ://] 0] + if {[dict exists $defaultproxy $scheme]} { + foreach domain [dict get $defaultproxy no] { + if {[string match $domain $host]} { + return [list DIRECT] + } + } + return [dict get $defaultproxy $scheme] + } + return [list DIRECT] +} + +proc www::httpproxy {server url host} { + return [list "HTTP $server"] +} + +proc www::httpsproxy {server url host} { + return [list "HTTPS $server"] +} + +proc www::socksproxy {server url host} { + return [list "SOCKS $server"] +} + +proc www::socks4proxy {server url host} { + return [list "SOCKS4 $server"] +} + +proc www::socks5proxy {server url host} { + return [list "SOCKS5 $server"] +} + +proc www::register {scheme port {command ""} {secure 0}} { + variable schemes + dict set schemes $scheme \ + [dict create port $port command $command secure $secure] + return +} + +proc www::urlencode {str} { + variable config + variable formmap + set string [encoding convertto [dict get $config -urlencoding] $str] + return [string map $formmap $str] +} + +proc www::challenge {str} { + scan $str {%s %n} type pos + set rc {} + foreach n [split [string range $str $pos end] ,] { + lassign [slice $n =] key val + if {[string match {"*"} $val]} {set val [string range $val 1 end-1]} + dict set rc $key $val + } + return [list $type $rc] +} + +proc www::hostport {dest {defaultport 80}} { + # Extract host and port from the destination specification + if {[regexp {^\[([[:xdigit:]:]+)\]} $dest ipv6 host]} { + set l [string length $ipv6] + if {$l == [string length $spec]} { + return [list $host $defaultport] + } elseif {[string index $spec $l] eq ":"} { + return [list $host [string range $spec [expr {$l + 1}] end]] + } else { + throw {WWW URL HOSTSPEC} "invalid host specification" + } + } else { + set rc [slice $dest] + if {[llength $rc] < 2} {lappend rc $defaultport} + return $rc + } +} + +proc www::reuse {scheme host port cmd} { + variable timer + variable maxconn + # Check if a connection to the requested destination already exists + db eval {select connection from reuse \ + where scheme = $scheme and host = $host and port = $port} { + after cancel [dict get $timer $connection] + dict unset timer $connection + dict set timer $connection {} + return $connection + } + if {[dict size $timer] >= $maxconn} { + # Delete the oldest connection + dict for {key val} $timer { + $key destroy + break + } + } + set conn [{*}$cmd] + db eval {insert into reuse (connection, scheme, host, port) \ + values($conn, $scheme, $host, $port)} + + # Arrange to update the administration when the object disappears + trace add command $conn delete [list apply [list {obj args} { + release $obj + } [namespace current]]] + + dict set timer $conn {} + return $conn +} + +proc www::release {obj} { + variable timer + log "Deleting connection $obj" + db eval {delete from reuse where connection = $obj} + log "deleted [db changes] rows" + after cancel [dict get $timer $obj] + dict unset timer $obj +} + +proc www::keep {obj} { + variable timer + variable persist + # Stop the timer and move the connection to the end of the dict + after cancel [dict get $timer $obj] + dict unset timer $obj + dict set timer $obj [after $persist [list $obj destroy]] +} + +proc www::headers {extra} { + variable headers + variable encodings + set hdrs $headers + header add hdrs Accept-Encoding {*}[dict keys $encodings] + foreach {name value} $extra { + header replace hdrs $name $value + } + return $hdrs +} + +namespace eval www::header { + namespace ensemble create -subcommands {exists get replace append add} + + proc indexlist {hdrs name} { + return [lmap n [lsearch -all -nocase -exact $hdrs $name] { + if {$n % 2} continue else {expr {$n + 1}} + }] + } + + proc exists {hdrs name} { + # Usage: header exists headerlist name + # Check if a header with the specified name exists + return [expr {[llength [indexlist $hdrs $name]] != 0}] + } + + proc get {hdrs name args} { + # Usage: header get headerlist name ?index? ?-lowercase? + # Return the value of the requested header, if any. By default all + # entries are joined together, separated with a comma and a space. + # The resulting string is returned. + # If an index is specified, that is taken as an indication that the + # header value is defined as a comma-separated list. In that case, + # a Tcl list is constructed from the individual elements of all + # entries. The requested index from the resulting list is returned. + # The special index "all" causes the complete list to be returned. + # When the -lowercase option is specified, all values are converted + # to lower case. + if {[lindex $args 0] eq "-lowercase"} { + set cmd [list string tolower] + set index [lindex $args 1] + } else { + set cmd [list string cat] + set index [lindex $args 0] + } + if {$index eq ""} { + return [join [lmap n [indexlist $hdrs $name] { + {*}$cmd [lindex $hdrs $n] + }] {, }] + } + set list [indexlist $hdrs $name] + set rc {} + if {[string equal -nocase $name Set-Cookie]} { + # The Set-Cookie header is special + foreach h $list {lappend rc [lindex $hdrs $h]} + } else { + foreach h $list { + foreach v [split [lindex $hdrs $h] ,] { + lappend rc [{*}$cmd [string trim $v]] + } + } + } + if {$index eq "all"} { + return $rc + } elseif {$index eq "last"} { + return [lindex $rc end] + } else { + return [lindex $rc $index] + } + } + + proc add {var name args} { + # Usage: header add headerlistvar name ?-nocase? value ?...? + # Add one or more values to a header, if they are not alread present + # The -nocase option makes the compare operation case insensitive. + upvar 1 $var hdrs + set list [get [lappend hdrs] $name all] + set opts -exact + if {[lindex $args 0] eq "-nocase"} { + lappend opts -nocase + set args [lrange $args 1 end] + } + foreach arg $args { + if {[lsearch {*}$opts $list $arg] < 0} { + lappend list $arg + } + } + return [replace hdrs $name [join $list {, }]] + } + + proc append {var name args} { + # Usage: header append headerlistvar name ?value? ?...? + # Set a new value for a header in addition to any existing values + upvar 1 $var hdrs + set list [indexlist [lappend hdrs] $name] + set values [linsert $args 0 {*}[lmap n $list {lindex $hdrs $n}]] + set index end + foreach index [lreverse $list] { + set hdrs [lreplace $hdrs [expr {$index - 1}] $index] + incr index -1 + } + set hdrs [linsert $hdrs $index $name [join $values {, }]] + } + + proc replace {var name args} { + # Usage: header replace headerlistvar name ?value? ?...? + # Set a new value for a header replacing all existing entries. + # Multiple values are joined together into a comma-separated list. + # If no values are specified, all entries for the header are removed. + upvar 1 $var hdrs + set index end + foreach index [lreverse [indexlist [lappend hdrs] $name]] { + set hdrs [lreplace $hdrs [expr {$index - 1}] $index] + incr index -1 + } + if {[llength $args]} { + set hdrs [linsert $hdrs $index $name [join $args {, }]] + } + return $hdrs + } +} + +proc www::boundary {} { + # Generate a unique boundary string + for {set i 0} {$i < 6} {incr i} { + lappend data [expr {int(rand() * 0x100000000)}] + } + # ModSecurity 2.9.2 complains about some characters in the boundary + # string that are perfectly legal according to RFC 2046. "/" is one + # of them. (It looks like this is fixed in ModSecurity 2.9.3.) + # Wireshark also has issues when the boundary contains a "/". + return [string map {/ -} [binary encode base64 [binary format I* $data]]] +} + +proc www::formdata {list} { + return [lmap {name value} $list { + dict create name $name value $value + }] +} + +proc www::multipart {sep parts {disp ""}} { + set rc {} + foreach part $parts { + lassign [bodypart $part $disp] body hdrs + lappend rc "--$sep" + foreach {hdr val} $hdrs { + lappend rc "$hdr: $val" + } + lappend rc "" $body + } + lappend rc --$sep-- + return [join $rc \r\n] +} + +proc www::mimetype {file} { + return application/octet-string +} + +proc www::bodypart {data {disp ""}} { + if {$disp ne ""} { + if {[dict exists $data name]} { + set name [dict get $data name] + } else { + set name value + } + set dispstr [format {%s; name="%s"} $disp $name] + if {[dict exists $data file]} { + set filename [file tail [dict get $data file]] + append dispstr [format {; filename="%s"} $filename] + } + header replace hdrs Content-Disposition $dispstr + } + if {$disp eq "" || ![dict exists $data value]} { + if {[dict exists $data type]} { + set type [dict get $data type] + } elseif {[dict exists $data file]} { + set type [mimetype [dict get $data file]] + } else { + set type application/octet-string + } + header replace hdrs Content-Type $type + } + if {[dict exists $data value]} { + set body [dict get $data value] + } elseif {[dict exists $data file]} { + set f [open [dict get $data file] rb] + set body [read $f] + close $f + } else { + set body {} + } + return [list $body $hdrs] +} + +proc www::bodybuilder {method url request args} { + dict lappend request headers + dict lappend request parts + if {[llength $args] % 2} { + dict set request partdata value [lindex $args end] + set args [lrange $args 0 end-1] + dict lappend request parts [dict get $request partdata] + } + if {$method in {POST}} { + if {[llength [dict get $request parts]] == 0} { + set type application/x-www-form-urlencoded + } elseif {[llength [dict get $request parts]] > 1 || [llength $args]} { + set type multipart/form-data + } else { + set type application/octet-string + } + } elseif {[llength [dict get $request parts]] > 1} { + set type multipart/mixed + } elseif {[llength [dict get $request parts]]} { + set type application/octet-string + } else { + set type "" + } + + if {[dict exists $request multipart]} { + switch [dict get $request multipart] { + "" { + set type "" + } + formdata { + set type multipart/form-data + } + default { + set type multipart/[dict get $request multipart] + } + } + } + + set query {} + set parts [if {[dict exists $request parts]} {dict get $request parts}] + if {$type eq "multipart/form-data"} { + set sep [boundary] + set body [multipart $sep [concat $parts [formdata $args]] form-data] + append type "; boundary=$sep" + } elseif {$type eq "application/x-www-form-urlencoded"} { + set body [join [lmap {key val} $args { + string cat [urlencode $key] = [urlencode $val] + }] &] + } else { + set query $args + if {[string match multipart/* $type]} { + set sep [boundary] + set body [multipart $sep $parts] + append type "; boundary=$sep" + } elseif {[llength $parts]} { + lassign [bodypart [lindex $parts 0]] body hdrs + set type [header get $hdrs Content-Type] + } + } + if {[llength $query]} { + append url ? [join [lmap {key val} $args { + string cat [urlencode $key] = [urlencode $val] + }] &] + } + dict set request url $url + if {$type ne ""} { + dict set request body $body + dict set request headers Content-Type $type + } + return $request +} + +proc www::request {method url request args} { + variable requestid + set request [bodybuilder $method $url $request {*}$args] + # Get a local copy of the requestid, because the requestcoro may need to + # perform a new request to obtain proxies, which would change requestid + set id [incr requestid] + set cmdline [list coroutine request$id requestcoro $method $request] + set coro [info coroutine] + if {$coro ne ""} { + {*}$cmdline [list $coro] + lassign [yield] data opts + } else { + variable result + {*}$cmdline [list set [namespace which -variable result]($id)] + vwait [namespace which -variable result]($id) + lassign $result($id) data opts + unset result($id) + } + if {[dict get $opts -code]} { + return -options [dict incr opts -level] $data + } + set code [dict get $opts status code] + if {$code in {101 200 201 202 204 207 304}} { + # 101 Switching protocols + # 200 OK + # 201 Created + # 202 Accepted + # 204 No Content + # 207 Multi-Status (WEBDAV) + # 304 Not Modified + return -options [dict incr opts -level] $data + } elseif {$code in {301 302 303 307 308}} { + # 301 Moved Permanently + # 302 Found + # 303 See Other + # 307 Temporary Redirect + # 308 Permanent Redirect + set redir [dict get $request maxredir] + if {$redir > 0} { + dict incr request maxredir -1 + } + if {$redir} { + if {$code eq "303"} { + set method GET + dict unset request body + # Remove any Content-Length headers + dict update request headers hdrs { + header replace hdrs Content-Length + } + } + set url [dict get $request url] + set location [header get [dict get $opts headers] location] + log "Redirected to: $location" + tailcall request $method [urljoin $url $location] $request + } + } elseif {$code eq "401" \ + && [header exists [dict get $opts headers] www-authenticate]} { + # 401 Unauthorized + set challenge [header get [dict get $opts headers] www-authenticate] + lassign [challenge $challenge] type args + # RFC 2068 10.4.2: If the request already included Authorization + # credentials, then the 401 response indicates that authorization + # has been refused for those credentials. + # RFC 2069 2.1.1: stale - A flag, indicating that the previous + # request from the client was rejected because the nonce value was + # stale. If stale is TRUE (in upper or lower case), the client may + # wish to simply retry the request with a new encrypted response, + # without reprompting the user for a new username and password. + set stale [expr {[dict exists $args stale] \ + && [string equal -nocase [dict get $args stale] true]}] + set auth [header get [dict get $request headers] Authorization] + if {$auth ne "" && !$stale} { + # Credentials must be incorrect + } elseif {$type eq "Digest" && [dict exists $request digest]} { + package require www::digest + lassign [dict get $request digest] user password + set body \ + [if {[dict exists $request body]} {dict get $request body}] + set uri [dict get $opts uri] + dict update request headers hdrs { + set cred \ + [digest::digest $args $user $password $method $uri $body] + header replace hdrs Authorization $cred + } + tailcall request $method [dict get $opts url] $request + } + } + set codegrp [string replace $code 1 2 XX] + set reason [dict get $opts status reason] + dict set opts -code 1 + dict set opts -errorcode [list WWW CODE $codegrp $code $reason] + return -options [dict incr opts -level] $data +} + +proc www::requestcoro {method request callback} { + variable config + variable headers + variable schemes + set url [dict get $request url] + set hdrs [dict get $request headers] + set cookies [lmap {n v} [cookies get $url] {string cat $n = $v}] + if {[llength $cookies]} { + header replace hdrs Cookie [join $cookies {; }] + } else { + header replace hdrs Cookie + } + set rec [parseurl $url] + set proxies [proxies $rec] + foreach n $proxies { + lassign $n keyword arg + set scheme [dict get $rec scheme] + switch $keyword { + PROXY - HTTP - HTTPS { + if {$keyword eq "HTTPS"} { + set version https + } else { + set version http + } + set transform [dict get $schemes $scheme command] + if {[llength $transform]} { + # If a transformation must be applied, an HTTP tunnel is + # needed via the CONNECT method + # Once the tunnel is established, the connection is to the + # remote server. Scheme, host and port must point there. + set host [dict get $rec host] + set port [dict get $rec port] + set transform \ + [list proxyinit $version $host $port $transform] + lassign [hostport $arg 8080] phost pport + set command [list connection new $phost $pport $transform] + # The resource is just the local path + set resource [dict get $rec resource] + } else { + # The connection is to the proxy, so the scheme, host and + # port must point to that for reuse + lassign [hostport $arg 8080] host port + set scheme $version + set transform [dict get $schemes $scheme command] + set command [list connection new $host $port $transform] + # The resource is the full remote path + set resource $url + } + } + SOCKS - SOCKS4 - SOCKS5 { + package require www::socks + if {$keyword eq "SOCKS5"} { + set version socks5 + } else { + set version socks4 + } + lassign [hostport [dict get $rec host] [dict get $rec port]] \ + host port + lassign [hostport $arg 1080] phost pport + set transform [dict get $schemes $scheme command] + set transform [list socksinit $version $host $port $transform] + set command [list connection new $phost $pport $transform] + set scheme $version+$scheme + set resource [dict get $rec resource] + } + default { + # DIRECT + lassign [hostport [dict get $rec host] [dict get $rec port]] \ + host port + set transform [dict get $schemes $scheme command] + set command [list connection new $host $port $transform] + set resource [dict get $rec resource] + } + } + + set conn [reuse $scheme $host $port $command] + + dict set rec method $method + dict set rec pipeline [dict get $config -pipeline] + if {[dict exists $request body]} { + header replace hdrs \ + Content-Length [string length [dict get $request body]] + dict set rec body [dict get $request body] + } + foreach key {timeout upgrade handler result} { + if {[dict exists $request $key]} { + dict set rec $key [dict get $request $key] + } + } + dict set rec headers [headers $hdrs] + dict set rec callback [list [info coroutine]] + try { + $conn request [dict replace $rec resource $resource] + } on ok {data opts} { + } trap {WWW CONNECT} {data opts} { + log "proxy $n failed: $data" + continue + } on error {data opts} { + log "requestcoro error: $data" + } + # log "requestcoro: $opts" + if {[dict exists $opts headers]} { + set cookies [header get [dict get $opts headers] set-cookie all] + if {[llength $cookies]} { + cookies store $url {*}$cookies + } + } + {*}$callback [list $data $opts] + return + } + log "All proxies exhausted: $proxies" + # Retry with http -> https ? + {*}$callback [list $data $opts] +} + +proc www::parseopts {optspec arglist} { + set request {headers {} maxredir 20} + # Call getopts twice to allow options to be specified before and after the url + set args [getopt arg [lassign [getopt arg $arglist $optspec] url] $optspec] + return [linsert $args 0 $url $request] +} + +proc www::get {args} { + set args [lassign [parseopts [stdopts] $args] url request] + if {[llength $args] % 2} { + throw {WWW ARGS} "expected key/value pairs" + } + request GET $url $request {*}$args +} + +proc www::head {args} { + set args [lassign [parseopts [stdopts] $args] url request] + if {[llength $args] % 2} { + throw {WWW ARGS} "expected key/value pairs" + } + request HEAD $url $request {*}$args +} + +proc www::post {args} { + request POST {*}[parseopts [stdopts [postopts]] $args] +} + +proc www::put {args} { + request PUT {*}[parseopts [stdopts [postopts]] $args] +} + +proc www::delete {args} { + request DELETE {*}[parseopts [stdopts [postopts]] $args] +} + +proc www::proxyinit {scheme host port cmd fd args} { + variable schemes + # Apply a transformation for the connection to the proxy, if necessary + set transform [dict get $schemes $scheme command] + if {[llength $transform]} {{*}$transform $fd {*}$args} + if {[llength $cmd]} { + # Create a proxyconnect object for the CONNECT transaction to the proxy + set obj [proxyconnect new $fd] + # Actually start the connection + try { + $obj connect $host:$port + } finally { + $obj destroy + } + # Apply the transformation on the tunneled connection to the server + {*}$cmd $fd $host + } +} + +proc www::socksinit {version host port cmd fd args} { + socks $version $fd $host $port + if {[llength $cmd]} { + {*}$cmd $fd {*}$args + } +} diff --git a/src/vendormodules/www/digest-2.1.tm b/src/vendormodules/www/digest-2.1.tm new file mode 100644 index 00000000..966f63a5 --- /dev/null +++ b/src/vendormodules/www/digest-2.1.tm @@ -0,0 +1,83 @@ +namespace eval www::digest { + variable noncecount +} + +# HTTP/1.1 401 Unauthorized +# WWW-Authenticate: Digest +# realm="testrealm@host.com", +# qop="auth,auth-int", +# nonce="dcd98b7102dd2f0e8b11d0f600bfb0c093", +# opaque="5ccc069c403ebaf9f0171e9517f40e41" + +proc www::digest::md5 {str} { + package require md5 + return [string tolower [::md5::md5 -hex $str]] +} + +proc www::digest::sha256 {str} { + package require sha256 + return [::sha2::sha256 -hex $str] +} + +proc www::digest::digest {challenge username password method uri {body ""}} { + variable noncecount + if {[dict exists $challenge algorithm]} { + set algorithm [dict get $challenge algorithm] + } else { + set algorithm MD5 + } + switch $algorithm { + MD5 - MD5-sess {set hash md5} + SHA-256 - SHA-256-sess {set hash sha256} + default { + error "unsupported algorithm: $algorithm" + } + } + set interlude [dict get $challenge nonce] + set keys {username realm nonce uri response} + if {[dict exists $challenge qop]} { + set qops [split [dict get $challenge qop] ,] + if {"auth" in $qops} { + set qop auth + } elseif {"auth-int" in $qops} { + set qop auth-int + } else { + error "unsupported qop: [join $qops {, }]" + } + set nonce [dict get $challenge nonce] + # Generate a random cnonce + set cnonce [format %08x [expr {int(rand() * 0x100000000)}]] + set nc [format %08X [incr noncecount($nonce)]] + append interlude : $nc : $cnonce : $qop + lappend keys qop nc cnonce + if {[dict exists $challenge algorithm]} {lappend keys algorithm} + if {[dict exists $challenge opaque]} {lappend keys opaque} + } else { + set qop auth + } + foreach n $keys { + dict set rc $n \ + [if {[dict exists $challenge $n]} {dict get $challenge $n}] + } + dict set rc username $username + dict set rc uri $uri + if {[dict exists $rc qop]} { + dict set rc qop $qop + dict set rc cnonce $cnonce + dict set rc nc $nc + } + set A1 [$hash $username:[dict get $challenge realm]:$password] + if {[string match {*-sess} $algorithm]} {append A1 : $nonce : $cnonce} + set A2 [$hash $method:$uri] + if {$qop eq "auth-int"} {append A2 : $body} + dict set rc response [$hash $A1:$interlude:$A2] + set authlist {} + dict for {key val} $rc { + if {$key ni {qop nc}} { + lappend authlist [format {%s="%s"} $key $val] + } else { + lappend authlist $key=$val + } + } + return "Digest [join $authlist ,]" +} diff --git a/src/vendormodules/www/http2-1.1.tm b/src/vendormodules/www/http2-1.1.tm new file mode 100644 index 00000000..aa2bda62 --- /dev/null +++ b/src/vendormodules/www/http2-1.1.tm @@ -0,0 +1,1551 @@ +# Helper library for adding http/2 support to www + +# https://httpbin.org/ + +package require www 2.7 + +# trace add execution fileevent enter entertrace +proc entertrace {cmd op} {puts $cmd} + +if {[package vsatisfies [package require tls] 1.8-]} { + # Override the encrypt proc from the www package to add the -alpn option + proc www::encrypt {sock host} { + variable tlscfg + tls::import $sock -servername $host -alpn {h2 http/1.1} {*}$tlscfg + } +} + +oo::class create www::http2helper { + method Contact {} { + my variable fd + if {![next]} {return 0} + # Wait for the TLS handshake to complete + fileevent $fd writable [list [info coroutine] handshake] + yield + fileevent $fd writable {} + # Check the ALPN negotiation result + if {[catch {dict get [tls::status $fd] alpn} alpn]} {set alpn ""} + if {$alpn eq "h2"} { + oo::objdefine [self] mixin http2 + my Startup {} + } + return 1 + } + + method PushRequest {} { + my variable waiting pending + set waiting [lassign $waiting request] + + if {[dict get $request scheme] eq "http"} { + dict lappend request upgrade h2c http2 + # Add the headers needed for an HTTP/2 upgrade + dict update request headers hdrs { + foreach {name value} [www::http2 headers] { + header append hdrs $name $value + } + } + } + + lappend pending [dict create Request $request Attempt 0] + return $request + } +} + +oo::define www::connection { + mixin -append www::http2helper +} + +namespace eval www::http2 { + variable defaultsettings { + tablesize 4096 + pushenable 1 + maxstreams 2147483647 + windowsize 65536 + maxframesize 16384 + maxtablesize 2147483647 + } + variable preferredsettings { + tablesize 65536 + pushenable 0 + maxstreams 100 + windowsize 1048576 + maxtablesize 262144 + } + variable errorcodes { + NO_ERROR + PROTOCOL_ERROR + INTERNAL_ERROR + FLOW_CONTROL_ERROR + SETTINGS_TIMEOUT + STREAM_CLOSED + FRAME_SIZE_ERROR + REFUSED_STREAM + CANCEL + COMPRESSION_ERROR + CONNECT_ERROR + ENHANCE_YOUR_CALM + INADEQUATE_SECURITY + HTTP_1_1_REQUIRED + } + variable fixed { + {""} + {:authority} + {:method GET} + {:method POST} + {:path /} + {:path /index.html} + {:scheme http} + {:scheme https} + {:status 200} + {:status 204} + {:status 206} + {:status 304} + {:status 400} + {:status 404} + {:status 500} + {accept-charset} + {accept-encoding "gzip, deflate"} + {accept-language} + {accept-ranges} + {accept} + {access-control-allow-origin} + {age} + {allow} + {authorization} + {cache-control} + {content-disposition} + {content-encoding} + {content-language} + {content-length} + {content-location} + {content-range} + {content-type} + {cookie} + {date} + {etag} + {expect} + {expires} + {from} + {host} + {if-match} + {if-modified-since} + {if-none-match} + {if-range} + {if-unmodified-since} + {last-modified} + {link} + {location} + {max-forwards} + {proxy-authenticate} + {proxy-authorization} + {range} + {referer} + {refresh} + {retry-after} + {server} + {set-cookie} + {strict-transport-security} + {transfer-encoding} + {user-agent} + {vary} + {via} + {www-authenticate} + } +} + +namespace eval www::http2::huffman { + namespace ensemble create -subcommands {decode encode} + variable map { + 1111111111000 \x00 + 11111111111111111011000 \x01 + 1111111111111111111111100010 \x02 + 1111111111111111111111100011 \x03 + 1111111111111111111111100100 \x04 + 1111111111111111111111100101 \x05 + 1111111111111111111111100110 \x06 + 1111111111111111111111100111 \x07 + 1111111111111111111111101000 \x08 + 111111111111111111101010 \x09 + 111111111111111111111111111100 \x0A + 1111111111111111111111101001 \x0B + 1111111111111111111111101010 \x0C + 111111111111111111111111111101 \x0D + 1111111111111111111111101011 \x0E + 1111111111111111111111101100 \x0F + 1111111111111111111111101101 \x10 + 1111111111111111111111101110 \x11 + 1111111111111111111111101111 \x12 + 1111111111111111111111110000 \x13 + 1111111111111111111111110001 \x14 + 1111111111111111111111110010 \x15 + 111111111111111111111111111110 \x16 + 1111111111111111111111110011 \x17 + 1111111111111111111111110100 \x18 + 1111111111111111111111110101 \x19 + 1111111111111111111111110110 \x1A + 1111111111111111111111110111 \x1B + 1111111111111111111111111000 \x1C + 1111111111111111111111111001 \x1D + 1111111111111111111111111010 \x1E + 1111111111111111111111111011 \x1F + 010100 \x20 + 1111111000 \x21 + 1111111001 \x22 + 111111111010 \X23 + 1111111111001 \x24 + 010101 \x25 + 11111000 \x26 + 11111111010 \x27 + 1111111010 \x28 + 1111111011 \x29 + 11111001 \x2A + 11111111011 \x2B + 11111010 \x2C + 010110 \x2D + 010111 \x2E + 011000 \x2F + 00000 \x30 + 00001 \x31 + 00010 \x32 + 011001 \x33 + 011010 \x34 + 011011 \x35 + 011100 \x36 + 011101 \x37 + 011110 \x38 + 011111 \x39 + 1011100 \x3A + 11111011 \x3B + 111111111111100 \x3C + 100000 \x3D + 111111111011 \x3E + 1111111100 \x3F + 1111111111010 \x40 + 100001 \x41 + 1011101 \x42 + 1011110 \x43 + 1011111 \x44 + 1100000 \x45 + 1100001 \x46 + 1100010 \x47 + 1100011 \x48 + 1100100 \x49 + 1100101 \x4A + 1100110 \x4B + 1100111 \x4C + 1101000 \x4D + 1101001 \x4E + 1101010 \x4F + 1101011 \x50 + 1101100 \x51 + 1101101 \x52 + 1101110 \x53 + 1101111 \x54 + 1110000 \x55 + 1110001 \x56 + 1110010 \x57 + 11111100 \x58 + 1110011 \x59 + 11111101 \x5A + 1111111111011 \x5B + 1111111111111110000 \x5C + 1111111111100 \x5D + 11111111111100 \x5E + 100010 \x5F + 111111111111101 \x60 + 00011 \x61 + 100011 \x62 + 00100 \x63 + 100100 \x64 + 00101 \x65 + 100101 \x66 + 100110 \x67 + 100111 \x68 + 00110 \x69 + 1110100 \x6A + 1110101 \x6B + 101000 \x6C + 101001 \x6D + 101010 \x6E + 00111 \x6F + 101011 \x70 + 1110110 \x71 + 101100 \x72 + 01000 \x73 + 01001 \x74 + 101101 \x75 + 1110111 \x76 + 1111000 \x77 + 1111001 \x78 + 1111010 \x79 + 1111011 \x7A + 111111111111110 \x7B + 11111111100 \x7C + 11111111111101 \x7D + 1111111111101 \x7E + 1111111111111111111111111100 \x7F + 11111111111111100110 \x80 + 1111111111111111010010 \x81 + 11111111111111100111 \x82 + 11111111111111101000 \x83 + 1111111111111111010011 \x84 + 1111111111111111010100 \x85 + 1111111111111111010101 \x86 + 11111111111111111011001 \x87 + 1111111111111111010110 \x88 + 11111111111111111011010 \x89 + 11111111111111111011011 \x8A + 11111111111111111011100 \x8B + 11111111111111111011101 \x8C + 11111111111111111011110 \x8D + 111111111111111111101011 \x8E + 11111111111111111011111 \x8F + 111111111111111111101100 \x90 + 111111111111111111101101 \x91 + 1111111111111111010111 \x92 + 11111111111111111100000 \x93 + 111111111111111111101110 \x94 + 11111111111111111100001 \x95 + 11111111111111111100010 \x96 + 11111111111111111100011 \x97 + 11111111111111111100100 \x98 + 111111111111111011100 \x99 + 1111111111111111011000 \x9A + 11111111111111111100101 \x9B + 1111111111111111011001 \x9C + 11111111111111111100110 \x9D + 11111111111111111100111 \x9E + 111111111111111111101111 \x9F + 1111111111111111011010 \xA0 + 111111111111111011101 \xA1 + 11111111111111101001 \xA2 + 1111111111111111011011 \xA3 + 1111111111111111011100 \xA4 + 11111111111111111101000 \xA5 + 11111111111111111101001 \xA6 + 111111111111111011110 \xA7 + 11111111111111111101010 \xA8 + 1111111111111111011101 \xA9 + 1111111111111111011110 \xAA + 111111111111111111110000 \xAB + 111111111111111011111 \xAC + 1111111111111111011111 \xAD + 11111111111111111101011 \xAE + 11111111111111111101100 \xAF + 111111111111111100000 \xB0 + 111111111111111100001 \xB1 + 1111111111111111100000 \xB2 + 111111111111111100010 \xB3 + 11111111111111111101101 \xB4 + 1111111111111111100001 \xB5 + 11111111111111111101110 \xB6 + 11111111111111111101111 \xB7 + 11111111111111101010 \xB8 + 1111111111111111100010 \xB9 + 1111111111111111100011 \xBA + 1111111111111111100100 \xBB + 11111111111111111110000 \xBC + 1111111111111111100101 \xBD + 1111111111111111100110 \xBE + 11111111111111111110001 \xBF + 11111111111111111111100000 \xC0 + 11111111111111111111100001 \xC1 + 11111111111111101011 \xC2 + 1111111111111110001 \xC3 + 1111111111111111100111 \xC4 + 11111111111111111110010 \xC5 + 1111111111111111101000 \xC6 + 1111111111111111111101100 \xC7 + 11111111111111111111100010 \xC8 + 11111111111111111111100011 \xC9 + 11111111111111111111100100 \xCA + 111111111111111111111011110 \xCB + 111111111111111111111011111 \xCC + 11111111111111111111100101 \xCD + 111111111111111111110001 \xCE + 1111111111111111111101101 \xCF + 1111111111111110010 \xD0 + 111111111111111100011 \xD1 + 11111111111111111111100110 \xD2 + 111111111111111111111100000 \xD3 + 111111111111111111111100001 \xD4 + 11111111111111111111100111 \xD5 + 111111111111111111111100010 \xD6 + 111111111111111111110010 \xD7 + 111111111111111100100 \xD8 + 111111111111111100101 \xD9 + 11111111111111111111101000 \xDA + 11111111111111111111101001 \xDB + 1111111111111111111111111101 \xDC + 111111111111111111111100011 \xDD + 111111111111111111111100100 \xDE + 111111111111111111111100101 \xDF + 11111111111111101100 \xE0 + 111111111111111111110011 \xE1 + 11111111111111101101 \xE2 + 111111111111111100110 \xE3 + 1111111111111111101001 \xE4 + 111111111111111100111 \xE5 + 111111111111111101000 \xE6 + 11111111111111111110011 \xE7 + 1111111111111111101010 \xE8 + 1111111111111111101011 \xE9 + 1111111111111111111101110 \xEA + 1111111111111111111101111 \xEB + 111111111111111111110100 \xEC + 111111111111111111110101 \xED + 11111111111111111111101010 \xEE + 11111111111111111110100 \xEF + 11111111111111111111101011 \xF0 + 111111111111111111111100110 \xF1 + 11111111111111111111101100 \xF2 + 11111111111111111111101101 \xF3 + 111111111111111111111100111 \xF4 + 111111111111111111111101000 \xF5 + 111111111111111111111101001 \xF6 + 111111111111111111111101010 \xF7 + 111111111111111111111101011 \xF8 + 1111111111111111111111111110 \xF9 + 111111111111111111111101100 \xFA + 111111111111111111111101101 \xFB + 111111111111111111111101110 \xFC + 111111111111111111111101111 \xFD + 111111111111111111111110000 \xFE + 11111111111111111111101110 \xFF + } + variable rmap [lreverse $map] + lappend map 111111111111111111111111111111 \x00 +} + +proc www::http2::huffman::decode {data} { + variable map + binary scan $data B* bits + append bits 111111111111111111111111111111 + set str [regsub \0001*$ [string map $map $bits] {}] + return [encoding convertfrom utf-8 $str] +} + +proc www::http2::huffman::encode {str {utf8 0}} { + variable rmap + if {!$utf8} {set str [encoding convertto utf-8 $str]} + set bits [string map $rmap $str] + append bits [string repeat 1 [expr {-[string length $bits] % 8}]] + return [binary format B* $bits] +} + +proc www::http2::errormessage {code} { + variable errorcodes + set str [lindex $errorcodes $code] + if {$str eq ""} {set str "UNKNOWN_ERROR_CODE_$code"} + return $str +} + +proc www::http2::errorcode {value} { + variable errorcodes + set code [lsearch -exact $errorcodes $value] + if {$code < 0 && $value ne "INTERNAL_ERROR"} { + tailcall errorcode INTERNAL_ERROR + } + return $code +} + +proc www::http2::integer {var cnt} { + upvar 1 $var data + set mask [expr {(1 << $cnt) - 1}] + binary scan $data cu integer + set integer [expr {$integer & $mask}] + set i 1 + if {$integer == $mask} { + while 1 { + binary scan [string index $data $i] cu next + set integer [expr {$integer + (($next & 0x7f) << 7 * ($i - 1))}] + incr i + if {($next & 0x80) == 0} break + } + } + set data [string range $data $i end] + return $integer +} + +proc www::http2::makeint {num cnt {flags 0}} { + set mask [expr {(1 << $cnt) - 1}] + if {$num < $mask} { + lappend rc [expr {$num | $flags << $cnt}] + } else { + lappend rc [expr {$mask | $flags << $cnt}] + set num [expr {$num - $mask}] + while {$num >= 128} { + lappend rc [expr {$num & 0x7f | 0x80}] + set num [expr {$num >> 7}] + } + lappend rc $num + } + return [binary format c* $rc] +} + +proc www::http2::makestr {str} { + set data [encoding convertto utf-8 $str] + set huff [huffman encode $data 1] + if {[string length $huff] < [string length $data]} { + return [makeint [string length $huff] 7 1]$huff + } else { + return [makeint [string length $data] 7 0]$data + } +} + +proc www::http2::strlen {str} { + set len [string length [encoding convertto utf-8 $str]] + return [expr {$len + [string length [makeint $len 7]]}] +} + +oo::class create www::http2 { + method Startup {headers} { + log "HTTP/2 connection: [self]" + namespace path [linsert [namespace path] 0 ::www::http2] + namespace upvar ::www::http2 \ + defaultsettings default preferredsettings prefs + my variable fd space limit + variable data "" stream {} laststream -1 lastreceived 0 + variable backlog {} continuation 0 concurrent 0 + # Connection windows start at 64k + set space(0) 65536 ;# Receiving window + set limit(0) 65536 ;# Sending window + # Initialize the header compression tables + variable context + dict set context compress \ + [dict create table $::www::http2::fixed size 0 maxsize 4096] + dict set context decompress \ + [dict create table $::www::http2::fixed size 0 maxsize 4096] + # Set initial local and remote settings + variable settings $default remote $default + fconfigure $fd -translation binary -buffering none -blocking 0 + # Send magic + log "[self] Startup: PRI * HTTP/2.0\\r\\n\\r\\nSM\\r\\n\\r\\n" + puts -nonewline $fd "PRI * HTTP/2.0\r\n\r\nSM\r\n\r\n" + my ChangeSettings $prefs + if {[header exists $headers upgrade]} { + # Upgrade from HTTP/1.1 to HTTP/2 + set request [my PopRequest] + # The HTTP/1.1 request that is sent prior to upgrade is assigned + # a stream identifier of 1 with default priority values. Stream 1 + # is implicitly "half-closed" from the client toward the server, + # since the request is completed as an HTTP/1.1 request. + # (RFC7540 3.2) + set laststream 1 + set coro [my StartStream 1 half_closed_local] + $coro request [dict get $request Request] upgrade + } + # Process any HTTP/2 frames the server may have sent along with the 101 + if {[my Trap my Frame]} { + # Set the connection window size to 16MB + my ResizeWindow 0 16777216 + fileevent $fd readable [callback Trap my Frame] + # Pick up any requests that have already been queued + my Process + } + } + + method ConnectionError {type msg} { + my variable lastreceived + log "ConnectionError $type $msg" + # Send GoAway message + my SendFrame 0 7 0b0 \ + [binary format IIa* $lastreceived [errorcode $type] $msg] + # After sending the GOAWAY frame for an error condition, the endpoint + # MUST close the TCP connection. (RFC7540 5.4.1) + if {$type ne "NO_ERROR"} {my destroy} + } + + method StreamError {sid type msg} { + log "StreamError ($sid): $type $msg" + # Send RST_STREAM message + my SendFrame $sid 3 0b0 [binary format I [errorcode $type]] + } + + method PackString {var} { + upvar 1 $var data + binary scan $data B encoded + set len [integer data 7] + set str [string range $data 0 [expr {$len - 1}]] + if {$encoded} {set str [huffman decode $str]} + set data [string range $data $len end] + return $str + } + + method Index {op name value} { + my variable context + set index [llength $::www::http2::fixed] + dict with context $op { + set table [linsert $table $index [list $name $value]] + incr size [expr {[strlen $name] + [strlen $value] + 32}] + } + return [my Evict $op] + } + + method Evict {op} { + my variable context + dict with context $op { + while {$size > $maxsize} { + lassign [lindex $table end] name value + set table [lrange $table 0 end-1] + incr size [expr {-([strlen $name] + [strlen $value] + 32)}] + } + } + return $table + } + + method ChangeSettings {request} { + my variable settings waitack + my SendFrame 0 4 0b0 [http2 settings $request $settings] + set waitack $request + } + + method ResizeWindow {stream size} { + my variable space + set incr [expr {$size - $space($stream)}] + if {$incr > 0} { + my SendFrame $stream 8 0b0 [binary format I $incr] + set space($stream) $size + } + } + + method Trap {args} { + try $args trap {WWW HTTP2 CONNECTIONERROR} {msg info} { + my ConnectionError [lindex [dict get $info -errorcode] 3] $msg + return 0 + } on error {msg info} { + log "Trap: $msg\ + ([dict get $info -errorcode])\n[dict get $info -errorinfo]" + my ConnectionError INTERNAL_ERROR $msg + return 0 + } + return 1 + } + + method Frame {} { + my variable fd stream data continuation + if {[eof $fd]} { + my destroy + return + } + append data [read $fd] + while {[string length $data] >= 9} { + binary scan $data IuXcub8Iu len type flags sid + set len [expr {$len >> 8}] + if {[string length $data] < 9 + $len} return + set payload [string range $data 9 [expr {9 + $len - 1}]] + if {$type} { + binary scan $payload H* hex + log [format {< (%s %d) %d %s %s} \ + [self] $sid $type [string reverse $flags] $hex] + } elseif {[binary scan $payload H40 hex]} { + log [format {< (%s %d) %d %s %s... <%d bytes>} [self] $sid \ + $type [string reverse $flags] $hex [string length $payload]] + } else { + binary scan $payload H* hex + log [format {< (%s %d) %d %s %s} \ + [self] $sid $type [string reverse $flags] $hex] + } + set data [string range $data [expr {9 + $len}] end] + + if {$continuation} { + # A receiver MUST treat the receipt of any other type of frame + # or a frame on a different stream as a connection error of + # type PROTOCOL_ERROR. (RFC7540 6.2) + if {$type != 9 || $sid != $continuation} { + throw {WWW HTTP2 CONNECTIONERROR PROTOCOL_ERROR} \ + "unexpected non-CONTINUATION frame or stream_id is invalid" + } + } + if {$sid} { + if {[dict exists $stream $sid coro]} { + [dict get $stream $sid coro] message $type $flags $payload + } else { + log "Message for closed stream $sid" + } + } else { + # Stream 0: connection + switch $type { + 4 { + # Settings + my Settings $flags $payload + } + 6 { + # Ping + my Ping $flags $payload + } + 7 { + # GoAway + my GoAway $flags $payload + } + 8 { + # WindowUpdate + my WindowUpdate 0 $payload + } + } + } + } + } + + method ClientStream {} { + my variable laststream + # Clients only use odd numbered streams + return [my StartStream [incr laststream 2]] + } + + method StartStream {sid {state idle}} { + my variable stream + set coro stream$sid + dict set stream $sid coro $coro + dict set stream $sid weight 16 + dict set stream $sid parent 0 + dict set stream $sid deps {} + dict set stream $sid state idle + coroutine $coro my Stream $sid $state + return $coro + } + + method Stream {sid state} { + my variable stream settings remote space limit backlog + set space($sid) [dict get $settings windowsize] + set limit($sid) [dict get $remote windowsize] + set result {} + set id {} + set promise 0 + set cmd list + my StateTransition $state + try { + while {[dict get $stream $sid state] ne "closed"} { + set args [lassign [yieldto {*}$cmd] event] + set cmd list + switch $event { + message { + my Message {*}$args + if {$promise} {set flags [lindex $args 1]} + } + promise { + my StateTransition reserved_remote + my Continuation {*}$args + set promise 1 + set flags [lindex $args 0] + } + request { + set tags [lassign $args request] + dict set result Request $request + if {"upgrade" ni $tags} {my Transmit $sid $request} + } + failed { + throw {*}$args + } + close { + break + } + } + if {$promise && [string index $flags 2]} { + # Push promise headers complete + # The headers received until now belong to the request + dict set result Request headers [dict get result headers] + dict unset result headers + # Check for some mandatory parts + foreach key {method scheme host resource} { + if {![dict exists result $key]} { + throw {WWW HTTP2 STREAMERROR PROTOCOL_ERROR} \ + "missing mandatory request header: $key" + } + } + + } + } + my Return $result + } trap {WWW DATA TIMEOUT} {msg info} { + my StreamError $sid CANCEL $msg + my Failed [dict get $info -errorcode] $msg $sid + } trap {WWW HTTP2 STREAMERROR} {msg info} { + set type [lindex [dict get $info -errorcode] 3] + my StreamError $sid $type $msg + my Failed [dict get $info -errorcode] $msg $sid + } on error {msg info} { + my StreamError $sid INTERNAL_ERROR $msg + my Failed [dict get $info -errorcode] $msg $sid + } finally { + # Cleanup + unset space($sid) limit($sid) + dict unset backlog $sid + dict unset stream $sid coro + my StateTransition closed + # Keep streams that have dependencies for load sharing purposes + for { + set num $sid + } { + [dict get $stream $sid state] eq "closed" \ + && [llength [dict get $stream $num deps]] == 0 + } { + set num $parent + } { + set parent [dict get $stream $num parent] + dict unset stream $num + if {$parent == 0} break + dict update stream $parent ref { + dict set ref deps \ + [lsearch -all -inline -exact -not [dict get $ref deps] $num] + } + } + } + } + + method StreamId {} { + upvar #1 sid sid + return $sid + } + + method Result {args} { + upvar #1 result result + if {[llength $args] > 1} { + dict set result {*}$args + } elseif {[llength $args] == 0} { + return $result + } elseif {[dict exists $result {*}$args]} { + return [dict get $result {*}$args] + } + return + } + + method Timeout {} { + my variable timeout + upvar #1 request request + if {[dict exists $request timeout]} { + return [dict get $request timeout] + } else { + return $timeout + } + } + + method Timedout {sid} { + my variable stream + if {[dict exists $stream $sid coro]} { + set coro [dict get $stream $sid coro] + $coro failed {WWW DATA TIMEOUT} "timeout waiting for a response" + } + } + + method Failed {code msg {sid 0}} { + if {$sid} { + set callback [dict get [my Result Request] callback] + set opts [dict create -code 1 -level 1 -errorcode $code] + $callback -options $opts $msg + } else { + my variable stream + set type INTERNAL_ERROR + foreach n1 $code n2 {WWW HTTP2 CONNECTIONERROR} { + if {$n1 eq $n2} continue + if {$n2 eq ""} {set type $n1} + break + } + my ConnectionError $type $msg + dict for {sid dict} $stream { + if {[dict exists $dict coro]} { + [dict get $dict coro] failed $code $msg + } + } + } + } + + method Message {type flags payload} { + switch $type { + 0 { + # Data + my Data $flags $payload + } + 1 { + # Headers + my Headers $flags $payload + } + 2 { + # Priority + my Priority $flags $payload + } + 3 { + # ResetStream + my ResetStream $flags $payload + } + 5 { + # PushPromise + my PushPromise $flags $payload + } + 8 { + # WindowUpdate + my WindowUpdate [my StreamId] $payload + } + 9 { + # Continuation + my Continuation $flags $payload + } + 4 - 6 - 7 { + # Settings + # Ping + # GoAway + throw {WWW HTTP2 CONNECTIONERROR PROTOCOL_ERROR} \ + "message may not be associated with an individual stream" + } + } + } + + method Data {flags data} { + set sid [my StreamId] + my ValidStates STREAM_CLOSED open half_closed_local + my variable space settings + if {[string index $flags 3]} { + binary scan $data cu padding + set data [string range $data 1 [expr {$len - $padding - 1}]] + } + my Progress $data + set diff [expr {-[string length $data]}] + if {[incr space($sid) $diff] < [dict get $settings windowsize] / 2} { + my ResizeWindow $sid [dict get $settings windowsize] + } + if {[incr space(0) $diff] < 1048576} { + my ResizeWindow 0 16777216 + } + if {[string index $flags 0]} { + # Check content-length header, if present? + # The body may have a different length due to encoding + # throw {WWW HTTP2 STREAMERROR PROTOCOL_ERROR} \ + # "content-length mismatch" + my EndStream + } + } + + method Headers {flags data} { + my ValidStates PROTOCOL_ERROR \ + idle reserved_remote open half_closed_local + my StateTransition idle open reserved_remote half_closed_local + if {[string index $flags 3]} { + # Padded + set len [string length $data] + if {[string index $flags 5]} { + # Priority + binary scan $data cuBXIucu padding excl dep weight + set data [string range $data 6 [expr {$len - $padding - 1}]] + my Prioritize [my StreamId] \ + [expr {$dep & 0x7fffffff}] $excl $weight + } else { + binary scan $data cu padding + set data [string range $data 1 [expr {$len - $padding - 1}]] + } + } elseif {[string index $flags 5]} { + # Priority + binary scan $data Iucu dep weight + set data [string range $data 5 end] + } + if {[string index $flags 0]} {my EndStream} + my Continuation $flags $data + } + + method Priority {flags data} { + binary scan $data BXIucu excl dep weight + my Prioritize [my StreamId] [expr {$dep & 0x7fffffff}] $excl $weight + } + + method ResetStream {flags data} { + my StateTransition closed + binary scan $data Iu code + log "Reset stream: Code = $code" + } + + method Settings {flags data} { + my variable settings remote waitack space limit + if {[string index $flags 0]} { + if {![info exists waitack]} { + # ERROR: There is no settings update pending + return + } + # Our settings update has been accepted + if {[dict exists $waitack windowsize]} { + # Adjust the window sizes for all existing streams + set diff [expr {[dict get $waitack windowsize] \ + - [dict get $settings windowsize]}] + foreach n [array names space] { + if {$n} {incr space($n) $diff} + } + } + set settings [dict merge $settings $waitack] + unset waitack + return + } + while {[binary scan $data SuIu id value] == 2} { + switch $id { + 1 { + # SETTINGS_HEADER_TABLE_SIZE + dict set remote tablesize $value + } + 2 { + # SETTINGS_ENABLE_PUSH + if {$value <= 1} { + dict set remote pushenable $value + } else { + throw {WWW HTTP2 CONNECTIONERROR PROTOCOL_ERROR} \ + "invalid value for SETTINGS_ENABLE_PUSH: $value" + } + } + 3 { + # SETTINGS_MAX_CONCURRENT_STREAMS + dict set remote maxstreams $value + } + 4 { + # SETTINGS_INITIAL_WINDOW_SIZE + set diff [expr {$value - [dict get $remote windowsize]}] + # Adjust all existing streams + foreach n [array names limit] { + if {$n} {incr limit($n) $diff} + } + dict set remote windowsize $value + } + 5 { + # SETTINGS_MAX_FRAME_SIZE + dict set remote maxframesize $value + } + 6 { + # SETTINGS_MAX_HEADER_LIST_SIZE + dict set remote maxtablesize $value + } + } + set data [string range $data 6 end] + } + if {$data ne ""} { + throw {WWW HTTP2 CONNECTIONERROR FRAME_SIZE_ERROR} \ + "frame length must be a multiple of 6 octets" + } + # Acknowledge the received settings + my SendFrame 0 4 0b1 + } + + method PushPromise {flags data} { + my variable lastreceived + my ValidStates PROTOCOL_ERROR open half_closed_local + if {[string index $flags 3]} { + set len [string length $data] + binary scan $data cuIu padding new + set data [string range $data 5 [expr {$len - $padding - 1}]] + } else { + binary scan $data Iu new + set data [string range $data 4 end] + } + # Streams initiated by the server MUST use even-numbered stream + # identifiers. The identifier of a newly established stream MUST be + # numerically greater than all streams that the initiating endpoint + # has opened or reserved. An endpoint that receives an unexpected + # stream identifier MUST respond with a connection error of type + # PROTOCOL_ERROR. (RFC7540 5.1.1) + if {$new % 2 || $new <= $lastreceived} { + throw {WWW HTTP2 CONNECTIONERROR PROTOCOL_ERROR} \ + "unexpected stream identifier: $new" + } + set lastreceived $new + set coro [my StartStream $new] + coro promise $flags $data + } + + method Ping {flags data} { + if {[string index $flags 0]} { + # Received ping ACK + } else { + # Received ping, send ACK + my SendFrame 0 6 0b1 $data + } + } + + method GoAway {flags data} { + binary scan $data IuIua* last code msg + log "GoAway: Code = [errormessage $code], Last stream = $last, $msg" + my SendFrame 0 7 0b0 [binary format II $last 0] + } + + method WindowUpdate {sid data} { + my variable limit backlog + # A WINDOW_UPDATE frame with a length other than 4 octets MUST be + # treated as a connection error of type FRAME_SIZE_ERROR (RFC7540 6.9) + if {[string length $data] != 4} { + throw {WWW HTTP2 CONNECTIONERROR FRAME_SIZE_ERROR} \ + "WINDOW_UPDATE frame must have a length of 4" + } + binary scan $data Iu incr + # A receiver MUST treat the receipt of a WINDOW_UPDATE frame with + # an flow-control window increment of 0 as a stream error of type + # PROTOCOL_ERROR ((RFC7540 6.9) + if {$incr == 0} { + if {$sid} { + throw {WWW HTTP2 STREAMERROR PROTOCOL_ERROR} \ + "flow-control window increment may not be 0" + } else { + throw {WWW HTTP2 CONNECTIONERROR PROTOCOL_ERROR} \ + "flow-control window increment may not be 0" + } + } + incr limit($sid) $incr + if {$sid} { + if {![dict exists $backlog $sid]} return + if {min($limit(0), $limit($sid)) == 0} return + } else { + if {[dict size $backlog] == 0} return + } + # Resume sending data, if necessary + fileevent $fd writable [callback Flow] + } + + method Continuation {flags data} { + my variable context continuation stream + # header block fragment (RFC7540 4.3) + set table [dict get $context decompress table] + set headers [my Result headers] + while {[string length $data]} { + binary scan $data B4 rep + if {[string index $rep 0]} { + # Indexed Header Field Representation (RFC7541 6.1) + set type HH + set int [integer data 7] + lassign [lindex $table $int] name value + } elseif {[string index $rep 1]} { + # Literal Header Field with Incremental Indexing (RFC7541 6.2) + set int [integer data 6] + if {$int == 0} { + # New name + set type MM + set name [my PackString data] + } else { + set type HM + set name [lindex $table $int 0] + } + set value [my PackString data] + # Unshare the table to prevent copy on write + set table {} + set table [my Index decompress $name $value] + } elseif {[string index $rep 2]} { + # Dynamic Table Size Update (RFC7541 6.3) + set maxsize [integer data 5] + dict set context decompress maxsize $maxsize + log "New max table size: $maxsize" + # Evict entries that cause the table to exceed the maximum size + my Evict decompress + continue + } elseif {[string index $rep 3]} { + # Literal Header Field Never Indexed (RFC7541 6.2.3) + set int [integer data 4] + if {$int == 0} { + # New name + set type xx + set name [my PackString data] + } else { + set type Hx + set name [lindex $table $int 0] + } + set value [my PackString data] + } else { + # Literal Header Field without Indexing (RFC7541 6.2.2) + set int [integer data 4] + if {$int == 0} { + # New name + set type -- + set name [my PackString data] + } else { + set type H- + set name [lindex $table $int 0] + } + set value [my PackString data] + } + log "$type $name: $value" + if {$name eq ":status"} { + # Any request or response that contains a pseudo-header field + # that appears in a header block after a regular header field + # MUST be treated as malformed. (RFC7540 8.1.2.1) + if {[llength $headers]} { + throw {WWW HTTP2 STREAMERROR PROTOCOL_ERROR} \ + "pseudo-header after a regular header: $name" + } + # HTTP/2.0 doesn't provide a version or reason + set dict {line "" version HTTP/2.0 reason ""} + dict set dict code $value + my Result status $dict + } elseif {[string match :* $name]} { + switch $name { + :authority {my Result host $value} + :method {my Result method $value} + :path {my Result resource $value} + :scheme {my Result scheme $value} + default { + # Endpoints MUST treat a request or response that + # contains undefined or invalid pseudo-header fields + # as malformed (RFC7540 8.1.2.1) + throw {WWW HTTP2 STREAMERROR PROTOCOL_ERROR} \ + "undefined pseudo-header field: $name" + } + } + # These pseudo-header fields are only allowed in a PushPromise + if {$sid % 2} { + throw {WWW HTTP2 STREAMERROR PROTOCOL_ERROR} \ + "invalid pseudo-header field: $name" + } + # Any request or response that contains a pseudo-header field + # that appears in a header block after a regular header field + # MUST be treated as malformed. (RFC7540 8.1.2.1) + if {[llength $headers]} { + throw {WWW HTTP2 STREAMERROR PROTOCOL_ERROR} \ + "pseudo-header after a regular header: $name" + } + } else { + lappend headers $name $value + } + } + my Result headers $headers + # Check END_HEADERS flag + if {[string index $flags 2] == 0} { + set continuation [my StreamId] + return + } + set continuation 0 + set enc [header get $headers content-encoding all -lowercase] + my Result Encoding [lmap name [lreverse $enc] { + set coro encodingcoro_$name + coroutine $coro {*}[encodingcmd $name] + set coro + }] + } + + method ValidStates {code args} { + set state [my StateTransition] + if {$state ni $args} { + throw [list WWW HTTP2 STREAMERROR $code] \ + "illegal frame type for the current state: $state" + } + } + + method StateTransition {args} { + my variable stream concurrent + set sid [my StreamId] + set state [dict get $stream $sid state] + set from $state + if {[llength $args] == 1} { + set state [lindex $args 0] + } elseif {[dict exists $args $state]} { + set state [dict get $args $state] + } + if {$state ne $from} { + # Update the number of concurrently active streams + set open {open half_closed_local half_closed_remote} + incr concurrent [expr {($state in $open) - ($from in $open)}] + log "State ($sid): $from -> $state\nActive streams = $concurrent" + dict set stream $sid state $state + } + return $state + } + + method EndStream {} { + upvar #1 id id + # Cancel the response timeout + after cancel $id + my StateTransition open half_closed_remote half_closed_local closed + } + + method Prioritize {sid dep excl weight} { + my variable stream + if {$dep == $sid} { + throw {WWW HTTP2 STREAMERROR PROTOCOL_ERROR} \ + "a stream cannot depend on itself" + # my StreamError $sid PROTOCOL_ERROR + return + } + set s [dict get $stream $dep parent] + while {$s} { + if {$s == $sid} { + # Prevent imminent dependency loop: "The formerly dependent + # stream is first moved to be dependent on the reprioritized + # stream's previous parent. The moved dependency retains its + # weight." (RFC7540 5.3.3) + my Prioritize $dep [dict get $stream $sid parent] 0 \ + [dict get $stream $dep weight] + break + } + set s [dict get $stream $s parent] + } + set parent [dict get $stream $sid parent] + if {$parent && $dep != $parent} { + dict update stream $parent ref { + # Remove the stream from the depency list of the old parent + dict set ref deps \ + [lsearch -all -inline -exact -not [dict get $ref deps] $sid] + } + } + if {$dep} { + if {$excl} { + set deps [dict get $stream $dep deps] + # This stream is the sole dependent stream of its parent + dict set stream $dep deps [list $sid] + # Add the old dependencies to this stream + dict update stream $sid ref { + foreach n $deps { + if {$n ni [dict get $ref deps]} { + dict lappend ref deps $n + } + } + } + } else { + dict update stream $dep ref { + if {$sid ni [dict get $ref deps]} { + dict lappend ref deps $sid + } + } + } + } elseif {$excl} { + set deps {} + dict for {ref data} $stream { + if {$ref != sid && [dict get $data parent] == 0} { + lappend deps $ref + dict set stream $ref parent $sid + } + } + dict set stream $sid deps $deps + } + dict set stream $sid parent $dep + dict set stream $sid weight $weight + } + + method Transmit {sid request} { + my variable fd remote + upvar #1 id id + set method [string toupper [dict get $request method]] + my StateTransition idle open reserved_local half_closed_remote + set rc [my Header :method $method] + if {$method ni {CONNECT}} { + # Don't expect repeated request for the same path; don't index it + append rc [my Header :path [dict get $request resource] 0] + append rc [my Header :scheme [dict get $request scheme]] + } + append rc [my Header :authority [dict get $request host]] + set headers [dict get $request headers] + # Do not include connection-specific header fields + set skip \ + {connection keep-alive proxy-connection transfer-encoding upgrade} + foreach n [header get $headers connection all] { + if {$n ni $skip} {lappend skip $n} + } + set size [string length $rc] + set end [expr {![dict exists $request body]}] + if {$end} { + my StateTransition \ + open half_closed_local half_closed_remote closed + } + # Don't index headers that likely have a different value every time + set dynamic {date if-none-match} + set type 1 + foreach {name value} $headers { + set name [string tolower $name] + if {$name in $skip} continue + if {$name eq "cookie"} { + # Compressing the Cookie Header Field (RFC7540 8.1.2.5) + set str "" + foreach val [split $value {;}] { + append str [my Header $name [string trim $val]] + } + } else { + set str [my Header $name $value [expr {$name ni $dynamic}]] + } + # Keep frame size below limits + set add [string length $str] + if {$size + $add > [dict get $remote maxframesize]} { + # Send the partial headers + my SendFrame $sid $type $end $rc + # Additional parts will be in a CONTINUATION frames + set type 9 + set end 0 + set rc "" + set size 0 + } + append rc $str + incr size $add + } + my SendFrame $sid $type [expr {$end | 0b100}] $rc + set id [after [my Timeout] [callback Timedout $sid]] + if {[dict exists $request body]} { + my Push $sid [dict get $request body] + } + } + + method Push {sid data} { + my variable backlog fd + dict update backlog $sid dict { + dict append dict data $data + dict incr dict done 0 + } + fileevent $fd writable [callback Flow] + } + + method Flow {} { + my variable fd backlog limit + set sid [my Balance] + if {$sid == 0} { + # No data to send, or no bandwidth left + fileevent $fd writable {} + return + } + dict with backlog $sid { + # Calculate the amount of data left to be sent + set len [expr {[string length $data] - $done}] + # Determine how much data to actually send + # Limit to 8k for load balancing + set max [expr {min($len, $limit(0), $limit($sid), 8192)}] + set end [expr {$max == $len}] + # Send the data frame + my SendFrame $sid 0 $end \ + [string range $data $done [expr {$done + $max - 1}]] + # Keep track of what has already been sent + incr done $max + } + # Update the flow-control window administration + incr limit(0) [expr {-$max}] + incr limit($sid) [expr {-$max}] + # Clean up when all data for the current stream has been sent + if {$end} { + dict unset backlog $sid + my StateTransition open half_closed_local half_closed_remote closed + } + } + + method Balance {} { + # Select a stream based on dependencies and weighting + my variable backlog limit stream + if {$limit(0) == 0} { + # All streams are blocked + return 0 + } + # Create a list of streams with data waiting and available bandwidth + set list [lmap n [dict keys $backlog] { + if {$limit($n)} {set n} else continue + }] + # Build a tree of streams and their weight + set weight {} + foreach n $list { + while {$n != 0} { + set parent [dict get $stream $n parent] + dict set weight $parent $n [dict get $stream $n weight] + set n $parent + } + } + # Walk down the tree and pick a branch based on their weight + set sid 0 + # Stop when a stream is found that has data to send + while {[dict exists $weight $sid] && $sid ni $list} { + set w 0 + set weights {} + dict for {num value} [dict get $weight $sid] { + lappend weights [list $num $w] + incr w $value + } + set v [expr {int(rand() * $w)}] + set index [lsearch -integer -index 1 -bisect $weights $v] + set sid [lindex $weights $index 0] + } + return $sid + } + + method Header {name value {add 1}} { + my variable context + set entry 0 + set table [dict get $context compress table] + set list [lsearch -all -exact -index 0 $table $name] + foreach n $list { + if {[lindex $table $n 1] eq $value} { + set entry $n + } + } + if {$entry} { + log "HH $name: $value" + return [makeint $entry 7 1] + } else { + if {[llength $list]} {set entry [lindex $list 0]} + if {$add} { + set type MM + set rc [makeint $entry 6 1] + my Index compress $name $value + } else { + set type -- + set rc [makeint $entry 4] + } + if {$entry == 0} { + append rc [makestr $name] + } else { + set type [string replace $type 0 0 H] + } + append rc [makestr $value] + log "$type $name: $value" + return $rc + } + } + + method SendFrame {sid type flags {data ""}} { + my variable fd + set flags [format %08b $flags] + binary scan $data H* hex + log [format {> (%s %d) %d %s %s} [self] $sid $type $flags $hex] + set len [string length $data] + set frame \ + [string range [binary format IcB8I $len $type $flags $sid] 1 end] + append frame $data + puts -nonewline $fd $frame + } + + method PushRequest {} { + # The fact that the http2 class is already mixed into the object means + # that no upgrade has to be requested for http requests + # Skip www::http2helper and go straight to www::connection + nextto www::connection + } + + # Override methods from www library + method Process {} { + my variable fd waiting pending concurrent settings + if {[llength $waiting] == 0} return + if {$concurrent >= [dict get $settings maxstreams]} return + # Process the next request + set waiting [lassign $waiting request] + lappend pending [dict create Request $request Attempt 0] + if {$fd eq ""} { + my Connect + } else { + my Request + } + } + + method Request {} { + my variable fd pending timeout id + if {[eof $fd]} { + my Connect + } + set pending [lassign $pending transaction] + set coro [my ClientStream] + $coro request [dict get $transaction Request] + my Process + } + + method request {data} { + nextto ::www::connection $data + } +} + +oo::objdefine www::http2 { + method settings {new old} { + set data "" + dict for {key val} $old { + incr parameter + if {[dict exists $new $key] && [dict get $new $key] != $val} { + append data [binary format SI $parameter [dict get $new $key]] + } + } + return $data + } + + method headers {} { + namespace upvar ::www::http2 \ + defaultsettings defs preferredsettings prefs + set settings [binary encode base64 [my settings $prefs $defs]] + return [list Connection HTTP2-Settings HTTP2-Settings $settings] + } +} diff --git a/src/vendormodules/www/license.terms b/src/vendormodules/www/license.terms new file mode 100644 index 00000000..10cf6885 --- /dev/null +++ b/src/vendormodules/www/license.terms @@ -0,0 +1,13 @@ +Copyright (c) 2021, Schelte Bron + +Permission to use, copy, modify, and/or distribute this software for any +purpose with or without fee is hereby granted, provided that the above +copyright notice and this permission notice appear in all copies. + +THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES +WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF +MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR +ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES +WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN +ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF +OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. diff --git a/src/vendormodules/www/proxypac-2.1.tm b/src/vendormodules/www/proxypac-2.1.tm new file mode 100644 index 00000000..64a87c58 --- /dev/null +++ b/src/vendormodules/www/proxypac-2.1.tm @@ -0,0 +1,826 @@ +#!/usr/bin/tclsh + +# This library can be used together with www 2.0+ to use a proxy based on a +# Proxy Auto Configure (pac) file: +# package require proxypac +# www configure -proxyfilter {proxypac } +# Example: http://pac.webdefence.global.blackspider.com:8082/proxy.pac + +package require www + +namespace eval www::proxypac { + variable oldpac {} + namespace export proxypac + + proc proxypac {pacurl url host} { + variable oldpac + if {[string equal -length [string length $url] $pacurl $url]} { + # The pac url itself must be reachable directly + return DIRECT + } + try { + if {$pacurl ne $oldpac} { + set data [www get $pacurl] + set oldpac $pacurl + parse $data + } + set proxies [execute FindProxyForURL $url $host] + return [lmap proxy [split $proxies {;}] { + if {[string is space $proxy]} continue + string trim $proxy + }] + } on error {err opts} { + www::log "Failed to auto-configure proxy: $err" + # In case of any error, use a direct connection + return [list DIRECT] + } + } + + proc validip {ipchars} { + set valid [lmap n [split $ipchars .] { + expr {[string is digit -strict $n] && $n < 256} + }] + return [expr {[join $valid ""] eq "1111"}] + } + + proc resolve {host} { + if {[catch {package require dns}]} return + set tok [dns::resolve $host] + dns::wait $tok + set result [lindex [dns::address $tok] 0] + dns::cleanup $tok + return $result + } +} + +if {[catch {package require duktape::oo 0.11}]} { + proc www::proxypac::parse {data} { + set code [convert [string map [list \r\n \n] $data]] + proxypacrun eval $code + } + + proc www::proxypac::execute {args} { + proxypacrun eval $args + } + + proc www::proxypac::convert {data} { + variable tokenlist + set p 0 + set re {/[/=*]?|[*]/|[+][+=]?|[*][*]?=?|-=?|<[<=]?|>>>|>[>=]?|%=?|&&?|[|][|]?|!=?=?|={1,3}|[][(),.{}"';\n?~^]|[ \t]+} + + set tokenlist [lmap n [regexp -all -indices -inline $re $data] { + lassign $n x1 x2 + set str [string range $data $p [expr {$x1 - 1}]] + set sep [string range $data $x1 $x2] + set p [expr {$x2 + 1}] + list $str $sep + }] + + set code [lmap line [block] { + set tabs [string length [lindex [regexp -inline ^\t* $line] 0]] + set indent [string repeat \t [expr {$tabs / 2}]] + append indent [string repeat " " [expr {$tabs % 2}]] + regsub ^\t* $line $indent + }] + return [join $code \n] + } + + proc www::proxypac::peek {{trim 1}} { + variable tokenlist + variable count + if {[incr count] > 20} { + fail "endless loop" + } + if {[llength $tokenlist] == 0} return + lassign [lindex $tokenlist 0] str tag + if {![string is space $tag] || !$trim} { + return [lindex $tokenlist 0] + } elseif {$str ne ""} { + if {[lindex $tokenlist 1 0] ne ""} { + return [lindex $tokenlist 0] + } + lset tokenlist 1 0 $str + } + set tokenlist [lrange $tokenlist 1 end] + tailcall peek + } + + proc www::proxypac::poke {str tag} { + variable tokenlist + lset tokenlist 0 [list $str $tag] + } + + proc www::proxypac::next {{trim 1}} { + variable tokenlist + variable count 0 + set tokenlist [lrange $tokenlist 1 end] + tailcall peek $trim + } + + proc www::proxypac::end {} { + variable tokenlist + return [expr {[llength $tokenlist] == 0}] + } + + proc www::proxypac::code {} { + lassign [peek] str tag + if {$str eq "" && $tag eq "\{"} { + next + lappend rc {*}[block] + lassign [peek] str tag + if {$tag ne "\}"} { + fail "expected \}" + } + next + } else { + lappend rc {*}[statement] + } + return $rc + } + + proc www::proxypac::block {} { + while {![end]} { + lassign [peek] str tag + switch $str { + {} { + if {$tag in {// /*}} { + comment + } + } + default { + set block [statement] + lappend rc {*}$block + } + } + lassign [peek] str tag + if {$tag eq "\}"} { + break + } + } + return $rc + } + + proc www::proxypac::comment {} { + variable tokenlist + variable count 0 + lassign [peek] str tag + if {$tag eq "//"} { + set end \n + } else { + set end "*/" + } + set nl [lsearch -exact -index 1 $tokenlist $end] + if {$nl < 0} {set nl end} + set tokenlist [lreplace $tokenlist 0 $nl] + } + + proc www::proxypac::statement {} { + lassign [peek] str tag + switch $str { + function { + if {![string is space $tag]} { + fail "expected white space" + } + set rc [function] + } + if { + set rc [ifelse] + } + return { + set rc [jsreturn] + } + var { + if {![string is space $tag]} { + fail "expected white space" + } + set rc [var] + } + for { + if {$tag ne "("} { + fail "expected (" + } + set rc [forloop] + } + default { + if {![regexp {^[\w$]+$} $str]} { + fail "unsupported JavaScript command: $str" + } elseif {$tag eq "="} { + set rc [assignment $str] + } elseif {$tag eq "("} { + set rc [list [funccall $str]] + } else { + fail "unsupported JavaScript command: $str (tag = $tag)" + } + } + } + lassign [peek] str tag + if {$tag eq ";"} { + lassign [next] str tag + } + return $rc + } + + proc www::proxypac::jsreturn {} { + lassign [peek] str tag + if {$str eq "" && $tag in {; \n}} { + return [list return] + } else { + poke "" $tag + return [list "return [expression]"] + } + } + + proc www::proxypac::expression {{top 1}} { + lassign [peek] str tag + set rc {} + set unary {} + set strcat 0 + while 1 { + if {$str eq "" && $tag in {+ - ! ~}} { + append unary $tag + lassign [next] str tag + continue + } + switch -regexp $str { + {^$} { + set op [lindex $rc end] + if {$op eq "=="} { + lset rc end eq + } elseif {$op eq "!="} { + lset rc end ne + } + if {$tag in {\" '}} { + set quote $tag + set strvar "" + while 1 { + lassign [next 0] str tag + if {$tag eq $quote} { + append strvar $str + break + } else { + append strvar $str $tag + } + } + lappend rc [format {{%s}} $strvar] + lassign [next] str tag + if {$str ne ""} { + fail "invalid expression" + } + set strcat 1 + } elseif {$tag in "("} { + next + lappend rc [format (%s) [expression 0]] + lassign [peek] str tag + if {$tag ne ")"} { + fail "expected )" + } + next + } + } + {^[\w$]+$} { + if {$tag eq "("} { + lappend rc [format {[%s]} [funccall $str]] + } elseif {$tag eq "\["} { + lappend rc [arrayelem $str] + } elseif {[string is double $str]} { + lappend rc $str + } elseif {[string tolower $str] in {true false}} { + lappend rc $str + } else { + lappend rc [format {$%s} $str] + } + } + default { + fail "expected expression" + } + } + lassign [peek] str tag + while {$tag eq "."} { + lset rc end [method [lindex $rc end]] + lassign [peek] str tag + } + if {$unary ne ""} { + lset rc end $unary[lindex $rc end] + set unary {} + } + switch $tag { + + - - - * - ** - / - % - + == - != - > - < - >= - <= - ? - : - + & - | - ^ - << - >> - && - || { + lappend rc $tag + } + === { + lappend rc == + } + !== { + lappend rc != + } + >>> { + lappend rc >> + } + default { + break + } + } + lassign [next] str tag + } + if {!$top} { + return [join $rc " "] + } elseif {[llength $rc] == 1} { + set rc [lindex $rc 0] + if {[string match {{*}} $rc]} { + return [list [string range $rc 1 end-1]] + } else { + return $rc + } + } elseif {!$strcat} { + return [format {[expr {%s}]} [join $rc " "]] + } + set cat {} + set expr {} + set rest [lassign $rc arg] + set strcat [string match {{*}} $arg] + if {$strcat} { + lappend cat $arg + } else { + lappend expr $arg + } + foreach {op arg} $rest { + if {$op ne "+" || !$strcat && ![string match {{*}} $arg]} { + lappend expr $op $arg + } else { + if {[llength $expr]} { + if {[llength $expr] > 1} { + lappend cat [format {[expr {%s}]} [join $expr]] + } else { + lappend cat [lindex $expr 0] + } + } + set expr {} + if {[string match {{*}} $arg]} { + set strcat 1 + lappend cat $arg + } else { + lappend expr $arg + } + } + } + if {[llength $expr]} { + if {[llength $expr] > 1} { + lappend cat [format {[expr {%s}]} [join $expr]] + } else { + lappend cat [lindex $expr 0] + } + } + return [format {[string cat %s]} [join $cat]] + } + + proc www::proxypac::function {} { + lassign [next] name tag + if {$tag ne "("} { + fail "expected open parenthesis" + } + set arglist {} + lassign [next] str tag + if {$str ne ""} { + while 1 { + lappend arglist $str + if {$tag eq ")"} break + if {$tag ne ","} { + fail "expected , or )" + } + lassign [next] str tag + } + } elseif {$tag ne ")"} { + fail "expected )" + } + lappend rc "proc $name [list $arglist] \{" + lassign [next] str tag + lappend rc {*}[indent [code]] + lappend rc "\}" + return $rc + } + + proc www::proxypac::funccall {name} { + set cmd $name + lassign [next] str tag + if {$str ne "" || $tag ne ")"} { + while 1 { + append cmd " " [expression] + lassign [peek] str tag + if {$tag eq ")"} break + if {$tag ne ","} { + fail "expected , or )" + } + next + } + } + next + return $cmd + } + + proc www::proxypac::ifelse {} { + lassign [peek] str tag + if {$tag ne "("} { + fail "expected (" + } + next + lappend rc [format "if {%s} \{" [expression 0]] + lassign [next] str tag + lappend rc {*}[indent [code]] + lassign [peek] str tag + if {$str eq "else"} { + lappend rc {\} else \{} + lassign [next] str tag + lappend rc {*}[indent [code]] + } + lappend rc "\}" + return $rc + } + + proc www::proxypac::forloop {} { + lassign [peek] str tag + if {$tag ne "("} { + fail "expected (" + } + lassign [next] name tag + if {$name eq "var" && [string is space $tag]} { + lassign [next] name tag + } + if {![regexp {^[\w$]+$} $name]} { + fail "expected identifier" + } + if {$tag eq "="} { + } elseif {[string is space $tag]} { + lassign [next] str tag + if {$str ni {in of} || ![string is space $tag]} { + fail "expected 'in' or 'of'" + } + if {$str eq "in"} { + set op keys + } else { + set op values + } + lassign [next] str tag + lappend rc [format "foreach %s \[dict %s $%s\] \{" $name $op $str] + if {$tag ne ")"} { + fail "expected )" + } + next + lappend rc {*}[indent [code]] + lappend rc "\}" + } + return $rc + } + + proc www::proxypac::method {obj} { + lassign [next] method tag + set cmd [format {%s %s} $method $obj] + if {$tag eq "("} { + lassign [next] str tag + if {$str ne "" || $tag ne ")"} { + while 1 { + append cmd " " [expression] + lassign [peek] str tag + if {$tag eq ")"} break + if {$tag ne ","} { + fail "expected , or )" + } + next + } + } + next + } + return [format {[%s]} $cmd] + } + + proc www::proxypac::assignment {name} { + lassign [next] str tag + switch $str { + new { + if {![string is space $tag]} { + fail "expected white space" + } + lassign [next] str tag + switch $str { + Array { + if {$tag ne "("} { + fail "expected (" + } + set cmd "dict create" + lassign [next] str tag + set index 0 + if {$str ne "" || $tag ne ")"} { + while 1 { + append cmd " " $index " " [expression] + incr index + lassign [peek] str tag + next + if {$tag eq ","} continue + if {$tag eq ")"} break + fail "expected , or )" + } + } else { + next + } + return [list [format {set %s [%s]} $name $cmd]] + } + default { + fail "$str objects are not supported" + } + } + } + {} { + if {$tag eq "\["} { + set cmd list + lassign [next] str tag + if {$str ne "" || $tag ne "]"} { + while 1 { + append cmd " " [expression] + lassign [peek] str tag + next + if {$tag eq ","} continue + if {$tag eq "\]"} break + fail "expected , or \]" + } + } + return [list [format {set %s [%s]} $name $cmd]] + } + } + } + return [list [format {set %s %s} $name [expression]]] + } + + proc www::proxypac::var {} { + lassign [next] str tag + if {![regexp {^[\w$]+$} $str]} { + fail "expected identifier" + } + if {$tag in {; \n}} return + return [assignment $str] + } + + proc www::proxypac::arrayelem {name} { + next + set sub [expression] + lassign [peek] str tag + if {$tag ne "\]"} { + fail "expected \]" + } + next + return [format {[dict get $%s %s]} $name $sub] + } + + proc www::proxypac::indent {list} { + return [lmap line $list {format \t%s $line}] + } + + proc www::proxypac::fail {str} { + error $str + } + + namespace eval www::proxypac { + interp create [namespace current]::proxypacrun + proxypacrun alias resolve [namespace which resolve] + proxypacrun alias validip [namespace which validip] + + proxypacrun eval { + proc substring {str start {end 0}} { + if {[llength [info level 0]] < 4} { + set end [string length $str] + } + if {$start < $end} { + return [string range $str $start [expr {$end - 1}]] + } else { + return [string range $str $end [expr {$start - 1}]] + } + } + + proc toLowerCase {str} { + return [string tolower $str] + } + + rename split tclsplit + proc split {str {separator ""} {limit 2147483647}} { + if {[llength [info level 0]] == 1} { + set list [list $str] + } elseif {$separator eq ""} { + set list [tclsplit $str ""] + } else { + set list {} + set p 0 + while {[set x [string first $separator $str $p]] >= 0} { + lappend list [string range $str $p [expr {$x - 1}]] + set p [expr {$x + [string length $separator]}] + } + lappend list [string range $str $p end] + } + set rc {} + set num 0 + foreach n $list { + if {$num >= $limit} break + dict set rc $num $n + incr num + } + return $rc + } + } + + proc jsfunction {name type args body} { + proxypacrun alias $name \ + apply [list $args $body [namespace current]] + # proxypacrun eval [list proc $name $args $body] + } + } +} else { + namespace eval www::proxypac { + duktape::oo::Duktape create js + + proc parse {data} { + js eval $data + } + + proc execute {args} { + js call {*}$args + } + + proc jsfunction {name type args body} { + js tcl-function $name $type $args $body + } + } +} + +namespace eval www::proxypac { + variable ipaddress "" + + jsfunction isPlainHostName boolean {host} { + return [expr {[string first . $host] < 0}] + } + + jsfunction dnsDomainIs boolean {host domain} { + set x [string first . $host] + return [expr {$x >= 0 && [string range $host $x end] eq $domain}] + } + + jsfunction localHostOrDomainIs boolean {host hostdom} { + return \ + [expr {$host eq $hostdom || $host eq [lindex [split $host .] 0]}] + } + + jsfunction isValidIpAddress boolean {ipchars} { + return [validip $ipchars] + } + + jsfunction isResolvable boolean {host} { + return [expr {[resolve $host] ne ""}] + } + + jsfunction isInNet boolean {host pattern mask} { + if {![validip $host]} { + set host [resolve $host] + if {$host eq ""} {return 0} + } + foreach ip1 [split $host .] ip2 [split $pattern .] m [split $mask .] { + if {($ip1 & $m) != ($ip2 & $m)} {return 0} + } + return 1 + } + + jsfunction dnsResolve string {host} { + return [resolve $host] + } + + jsfunction convert_addr integer {ipaddr} { + binary scan [binary format c4 [split $ipaddr .]] Iu addr + return $addr + } + + jsfunction myIpAddress string {} { + variable ipaddress + if {$ipaddress eq ""} { + try { + set fd "" + set fd [socket -server dummy -myaddr [info hostname] 0] + set ipaddress [lindex [fconfigure $fd -sockname] 0] + } on error {} { + set ipaddress 127.0.0.1 + } finally { + if {$fd ne ""} {close $fd} + } + } + return $ipaddress + } + + jsfunction dnsDomainLevels integer {host} { + return [regexp {[.]} $host] + } + + jsfunction shExpMatch boolean {str shexp} { + return [string match $shexp $str] + } + + jsfunction weekdayRange boolean {wd1 {wd2 ""} {gmt ""}} { + set weekdays {SUN MON TUE WED THU FRI SAT} + if {$wd2 eq "GMT"} { + set gmt 1 + set match [list $wd1] + } else { + set gmt [expr {$gmt eq "GMT"}] + set d1 [lsearch -exact $weekdays $wd1] + set d2 [lsearch -exact $weekdays $wd2] + if {$d1 < $d2} { + set match [lrange $weekdays $d1 $d2] + } else { + set match [list $wd1 $wd2] + } + } + set wd0 [clock format [clock seconds] -gmt $gmt -format %a] + return [expr {[string toupper $wd0] in $match}] + } + + jsfunction dateRange boolean {args} { + set gmt [expr {[lindex $args end] eq "GMT"}] + set len [expr {[llength $args] - $gmt}] + if {$len < 1} {return 0} + set now [clock seconds] + if {$len == 1} { + set arg [lindex $args 0] + if {![string is integer -strict $arg]} { + set mon [clock format $now -format %b -gmt $gmt] + return [expr {$arg eq [string toupper $mon]}] + } elseif {$arg < 32} { + set day [clock format $now -format %e -gmt $gmt] + return [expr {$arg == $day}] + } else { + set year [clock format $now -format %Y -gmt $gmt] + return [expr {$arg == $year}] + } + } + lassign [clock format $now -format {%Y %b} -gmt $gmt] year month + set d1 [list $year JAN 1 0 0 0] + set d2 [list $year DEC 31 23 59 59] + set middle [expr {$len / 2}] + for {set i 0} {$i < $middle} {incr i} { + set arg [lindex $args $i] + if {![string is integer -strict $arg]} { + lset d1 1 $arg + } elseif {$arg < 32} { + lset d1 2 $arg + if {$len <= 2} { + lset d1 1 $month + lset d2 1 $month + } + } else { + lset d1 0 $arg + } + } + for {set i $middle} {$i < $len} {incr i} { + set arg [lindex $args $i] + if {![string is integer -strict $arg]} { + lset d2 1 $arg + } elseif {$arg < 32} { + lset d2 2 $arg + } else { + lset d2 0 $arg + } + } + set time1 [clock scan [join $d1 :] -format %Y:%b:%d:%T -gmt $gmt] + set time2 [clock scan [join $d2 :] -format %Y:%b:%d:%T -gmt $gmt] + if {$time1 < $time2} { + return [expr {$now >= $time1 && $now <= $time2}] + } else { + return [expr {$now >= $time2 && $now <= $time1}] + } + } + + jsfunction timeRange boolean {args} { + set gmt [expr {[lindex $args end] eq "GMT"}] + set len [expr {[llength $args] - $gmt}] + if {$len < 1} { + return 0 + } elseif {$len > 6 || $len == 3 || $len == 5} { + return -code error "timeRange: bad number of arguments" + } + set t1 {0 0 0} + set t2 {23 59 59} + set n [expr {($len + 1) / 2}] + for {set i1 0; set i2 [expr {$len / 2}]} {$i1 < $n} {incr i1; incr i2} { + lset t1 $i1 [lindex $args $i1] + if {$i2 < $len} { + lset t2 $i1 [lindex $args $i2] + } + } + set time1 [clock scan [join $t1 :] -format %T -gmt $gmt] + set time2 [clock scan [join $t2 :] -format %T -gmt $gmt] + set now [clock seconds] + if {$time1 < $time2} { + return [expr {$now >= $time1 && $now <= $time2}] + } else { + return [expr {$now >= $time2 && $now <= $time1}] + } + } + + jsfunction alert undefined {} {} +} + +namespace import www::proxypac::* diff --git a/src/vendormodules/www/socks-1.0.tm b/src/vendormodules/www/socks-1.0.tm new file mode 100644 index 00000000..42a214e9 --- /dev/null +++ b/src/vendormodules/www/socks-1.0.tm @@ -0,0 +1,156 @@ +# SOCKS V4a: http://ftp.icm.edu.pl/packages/socks/socks4/SOCKS4.protocol +# SOCKS V5: RFC 1928 + +namespace eval www::socks { + variable username guest password guest + namespace ensemble create -map {socks4 {init socks4} socks5 {init socks5}} +} + +proc www::socks::command {sock data {count 2} {timeout 2000}} { + if {$data ne ""} { + puts -nonewline $sock $data + flush $sock + } + set coro [info coroutine] + if {[llength $coro]} { + set id [after $timeout [list $coro timeout]] + fileevent $sock readable [list $coro data] + } else { + fconfigure $sock -blocking 1 + set id {} + } + set resp {} + set len 0 + while {![eof $sock]} { + append resp [read $sock [expr {$count - $len}]] + set len [string length $resp] + if {$len >= $count} { + after cancel $id + return $resp + } + if {[llength $coro] == 0} continue + set event [yield] + if {$event eq "data"} continue + if {$event eq "timeout"} break + } + throw {SOCKS PROTOCOL ERROR} "did not get expected response from proxy" +} + +proc www::socks::init {version sock host port} { + # Make sure this is running in a coroutine + if {[llength [info coroutine]] == 0} { + return [coroutine $sock init $version $sock $host $port] + } + dict set cfg -translation [fconfigure $sock -translation] + dict set cfg -blocking [fconfigure $sock -blocking] + dict set event readable [fileevent $sock readable] + dict set event writable [fileevent $sock writable] + fileevent $sock writable {} + fconfigure $sock -translation binary -blocking 0 + if {[catch {$version $sock $host $port} result opts]} { + variable lasterror $result + } + fconfigure $sock {*}$cfg + dict for {ev cmd} $event { + fileevent $sock $ev $cmd + } + return -options [dict incr opts -level] $result +} + +proc www::socks::socks4 {sock host port} { + variable username + set ip4 [split $host .] + if {[llength $ip4] == 4 && [string is digit -strict [lindex $ip4 end]]} { + set data [binary format ccSc4a*x 4 1 $port $ip4 $username] + } else { + # SOCKS4a + set data [binary format ccSx3ca*xa*x 4 1 $port 1 $username $host] + } + binary scan [command $sock $data 8] cucuSc4 vn cd dstport dstip + if {$vn != 0} { + throw {SOCKS CONNECT VERSION} \ + "unsupported socks connection version: $vn" + } + if {$cd != 90} { + throw [list SOCKS CONNECT [format ERROR%02X $cd]] \ + "socks connection failed with error code $cd" + } + return [join $dstip .]:$dstport +} + +proc www::socks::socks5 {sock host port} { + fconfigure $sock -translation binary -blocking 0 + # Authenticate + set methods [list 0 2] + set data [binary format ccc* 5 [llength $methods] $methods] + binary scan [command $sock $data 2] cucu version method + + if {$method == 0} { + # No authentication required + } elseif {$method == 1} { + # GSS-API RFC 1961 + # Not implemented + throw {SOCKS AUTH UNKNOWN} "unsupported authentication method: $method" + } elseif {$method == 2} { + # Username/password RFC 1929 + authenticate $sock + } else { + throw {SOCKS AUTH NOTACCEPTED} "no acceptable authentication methods" + } + + # Connect + set data [binary format ccc 5 1 0] + set ip4 [split $host .] + if {[llength $ip4] == 1 && [llength [set ip6 [split $host :]]] >= 3} { + # IPv6 address + set x [lsearch -exact $ip6 {}] + if {$x >= 0} { + set ip6 [lsearch -inline -exact -all -not $ip6 {}] + set insert [lrepeat [expr {8 - [llength $ip6]}] 0] + set ip6 [linsert $ip6 $x {*}$insert] + } + append data [binary format cS8S 4 $ip6 $port] + } elseif {[llength $ip4] == 4 && [string is digit -strict [lindex $ip4 end]]} { + # IPv4 address + append data [binary format cc4S 1 $ip4 $port] + } else { + # hostname + append data [binary format cca*S 3 [string length $host] $host $port] + } + binary scan [command $sock $data 4 10000] ccxc version reply atyp + if {$reply != 0} { + throw [list SOCKS CONNECT [format ERROR%02X $reply]] \ + "socks connection failed with error code $reply" + } + switch $atyp { + 1 { + binary scan [command $sock {} 6] c4S dstip dstport + return [join $dstip .]:$dstport + } + 3 { + binary scan [command $sock {} 1] c len + binary scan [command $sock {} [expr {$len + 2}]] a${len}S dsthost dstport + return $dsthost:$dstport + } + 4 { + binary scan [command $sock {} 18] S8S dstip dstport + return format {[%s]:$d} [join $dstip :] $dstport + } + } +} + +proc www::socks::authenticate {sock} { + variable username + variable password + set data [binary format cca*ca* 1 \ + [string length $username] $username [string length $password] $password] + binary scan [command $sock 2] cucu version status + if {$version != 1} { + throw {SOCKS AUTH RFC1929 VERSION} \ + "unsupported username/password authentication version: $version" + } + if {$status != 0} { + throw {SOCKS AUTH RFC1929 STATUS} \ + "username/password authentication failed: $status" + } +} diff --git a/src/vendormodules/www/websocket-1.1.tm b/src/vendormodules/www/websocket-1.1.tm new file mode 100644 index 00000000..ef964048 --- /dev/null +++ b/src/vendormodules/www/websocket-1.1.tm @@ -0,0 +1,306 @@ +# Helper library for adding websocket support to www + +package require www 2.7 + +proc www::websocket {args} { + set opts {-upgrade {WebSocket www::WebSocket}} + set args [getopt arg $args { + -timeout:milliseconds {dict set opts -timeout $arg} + -auth:data {dict set opts -auth $arg} + -digest:cred {dict set opts -digest $arg} + -maxredir:cnt {dict set opts -maxredir $arg} + }] + if {[llength $args] < 1 || [llength $args] > 3} { + throw {WWW WEBSOCKET ARGS} {wrong # args:\ + should be "www::websocket url ?protocols? ?extensions?"} + } + lassign $args url protocols extensions + try { + set hdrs [WebSocket headers] + if {[llength $protocols]} { + lappend hdrs Sec-WebSocket-Protocol [join $protocols {, }] + } + if {[dict size $extensions]} { + set ext [join [lmap name [dict keys $extensions] { + set list [list $name] + if {[dict exists $extensions $name parameters]} { + lappend $list [dict get $extensions $name parameters] + } + join $list {; } + }] {, }] + lappend hdrs Sec-WebSocket-Extensions $ext + } + www get {*}$opts -headers $hdrs $url + } on ok {result info} { + if {[dict get $info status code] != 101} { + # The only correct response for a successful websocket connection + # is 101 Switching Protocols. Even 200 OK is not good. + set code [dict get $info status code] + set codegrp [string replace $code 1 2 XX] + set reason [dict get $info status reason] + dict set info -code 1 + dict set info -errorcode [list WWW CODE $codegrp $code $reason] + return -options [dict incr info -level] $result + } + set websock [dict get $info websocket] + set hdrs [dict get $info headers] + set protocol [if {[dict exists $hdrs sec-websocket-protocol]} { + dict get $hdrs sec-websocket-protocol + }] + if {[dict exists $hdrs sec-websocket-extensions]} { + set ext [header [$hdrs sec-websocket-extensions] *] + set mixins [lmap value [lreverse $ext] { + set list [lmap n [split $value {;}] {string trim $n}] + set params [lassign $list name] + dict set parameters $name $params + dict get $extensions $name implementation + }] + oo::objdefine $websock \ + mixin www::WSExtension {*}$mixins www::WebSocket + # Inform the extensions of their parameters, if any + $websock parameters $parameters + } + # Return the websocket object command (and the negotiated protocol) + return protocol $protocol [dict get $info websocket] + } +} + +namespace ensemble configure www \ + -subcommands [linsert [namespace ensemble configure www -subcommands] end websocket] + +oo::class create www::WebSocket { + method Startup {headers} { + my variable fd + variable callback {} + # This socket cannot be used for future connections + release [self] + fconfigure $fd -translation binary -buffering none -blocking 0 + # Return the websocket object to the caller + my Result websocket [self] + my Return [my PopRequest] + } + + method Read {} { + my variable fd + return [read $fd] + } + + method Write {data} { + my variable fd + puts -nonewline $fd $data + } + + method Handler {} { + my variable fd callback + fileevent $fd readable [list [info coroutine] data] + set data "" + set payload "" + while {![eof $fd]} { + yield + append data [my Read] + if {[binary scan $data B4Xcucu flags code len] != 3} continue + if {$len < 126} { + set pos 2 + } elseif {$len == 126} { + if {[binary scan $data x2Su len] != 1} continue + set pos 4 + } elseif {$len == 127} { + if {[binary scan $data x2Wu len] != 1} continue + set pos 10 + } else { + # Error: Messages from server to client should not be masked + my close 1002 + } + if {[string length $data] < $pos + $len} continue + set code [expr {$code & 0xf}] + set payload [string range $data $pos [expr {$pos + $len - 1}]] + set data [string range $data [expr {$pos + $len}] end] + if {$code == 0} { + append message $payload + } else { + set opcode $code + # Control frames MAY be injected in the middle of a + # fragmented message. (RFC6455 5.4) + # Control frames are identified by opcodes where the most + # significant bit of the opcode is 1. (RFC6455 5.5) + if {$code < 8} {set message $payload} + } + if {![string index $flags 0]} continue + if {$opcode < 8} { + my Receive $opcode $message $flags + } else { + my Receive $opcode $payload $flags + } + } + if {[dict exists $callback close]} { + # 1006 is designated for use in applications expecting a status + # code to indicate that the connection was closed abnormally, + # e.g., without sending or receiving a Close control frame. + {*}[dict get $callback close] close 1006 "eof on connection" + } + my destroy + } + + # Methods that can be overridden by extensions + + method Read {} { + my variable fd + return [read $fd] + } + + method Write {data} { + my variable fd + puts -nonewline $fd $data + } + + method Receive {opcode data flags} { + my variable callback + switch $opcode { + 1 { + if {[dict exists $callback text]} { + set str [encoding convertfrom utf-8 $data] + {*}[dict get $callback text] text $str + } else { + my close 1003 + } + } + 2 { + if {[dict exists $callback binary]} { + {*}[dict get $callback binary] binary $data + } else { + my close 1003 + } + } + 8 { + if {[dict exists $callback close]} { + if {[binary scan $data Sua* code reason] != 2} { + set code 1005 + set reason "" + } + {*}[dict get $callback close] close $code $reason + set callback {} + } + } + 9 { + if {[dict exists $callback ping]} { + {*}[dict get $callback ping] ping $data + } else { + my pong $data + } + } + 10 { + if {[dict exists $callback pong]} { + {*}[dict get $callback pong] pong $data + } + } + } + } + + method Transmit {opcode data {flags 1}} { + binary scan $data cu* bytes + # The requirement to use a strong source of entropy makes no sense + # So we'll just use Tcl's simple linear congruential generator + set key [expr {int(rand() * 0x100000000)}] + binary scan [binary format I $key] cu* mask + set length [llength $bytes] + # Apply the mask + set i 0 + set bytes [lmap n $bytes { + set m [lindex $mask [expr {$i & 3}]] + incr i + expr {$n ^ $m} + }] + set type \ + [expr {$opcode | "0b[string reverse [format %04s $flags]]0000"}] + set data [binary format c $type] + if {$length < 126} { + append data [binary format c [expr {$length | 0x80}]] + } elseif {$length < 65536} { + append data [binary format cS [expr {126 | 0x80}] $length] + } else { + append data [binary format cW [expr {127 | 0x80}] $length] + } + append data [binary format c*c* $mask $bytes] + my Write $data + } + + # Public methods + + method callback {types prefix} { + variable callback + set running [dict size $callback] + if {$prefix ne ""} { + foreach type $types { + dict set callback $type $prefix + } + } elseif {[llength $types]} { + set callback [dict remove $callback {*}$types] + } else { + set callback {} + } + if {[dict size $callback]} { + if {!$running} {coroutine websockcoro my Handler} + } else { + if {$running} {rename websockcoro ""} + } + } + + method text {str} { + my Transmit 1 [encoding convertto utf-8 $str] + } + + method binary {data} { + my Transmit 2 $data + } + + method close {{code 1005} {reason ""}} { + # 1005 is designated for use in applications expecting a status code + # to indicate that no status code was actually present. + set payload [if {$code != 1005} { + binary format Sa* $code [encoding convertto utf-8 $reason] + }] + my Transmit 8 $payload + # The client SHOULD wait for the server to close the connection but + # MAY close the connection at any time after sending and receiving + # a Close message, e.g., if it has not received a TCP Close from + # the server in a reasonable time period. + # my destroy + } + + method ping {{data ""}} { + my Transmit 9 $data + } + + method pong {{data ""}} { + my Transmit 10 $data + } +} + +oo::class create www::WSExtension { + method parameters {parameters} { + dict for {mixin params} $parameters { + nextto $mixin $params + } + } +} + +oo::objdefine www::WebSocket { + method key {} { + # Generate a websocket key containing base64-encoded random bytes + # This key is only intended to prevent a caching proxy from + # re-sending a previous WebSocket conversation, and does not + # provide any authentication, privacy or integrity. + # It is therefor not necessary to check the returned hash. + for {set i 0} {$i < 12} {incr i} { + lappend bytes [expr {int(rand() * 256)}] + } + return [binary encode base64 [binary format c* $bytes]] + } + + method headers {} { + return [list Sec-WebSocket-Key [my key] Sec-WebSocket-Version 13] + } +} + +www register ws 80 +www register wss 443 www::encrypt 1 diff --git a/src/vfs/_config/punk_main.tcl b/src/vfs/_config/punk_main.tcl index f068cfeb..504ac490 100644 --- a/src/vfs/_config/punk_main.tcl +++ b/src/vfs/_config/punk_main.tcl @@ -876,11 +876,12 @@ apply { args { } set ::tcl_interactive 1 set ::tclsh(dorepl) 1 - - } elseif {[llength $arglist]} { + } elseif {[lindex $arglist 0] eq "shellspy"} { #pass through to shellspy commandline processor #puts stdout "main.tcl launching app-shellspy" package require app-shellspy + } elseif {[llength $arglist]} { + package require app-punkshell } else { #punk shell #todo logger ? diff --git a/src/vfs/_vfscommon.vfs/doc/bogus.tcl b/src/vfs/_vfscommon.vfs/doc/bogus.tcl index 603f0a63..6c0e7805 100644 --- a/src/vfs/_vfscommon.vfs/doc/bogus.tcl +++ b/src/vfs/_vfscommon.vfs/doc/bogus.tcl @@ -8,9 +8,17 @@ package require Tcl 8.5- # # ## ### ##### ######## ############# ##################### namespace eval ::bogus { - proc test {args} { - puts stderr "bogus-should-not-load-$args" - } + proc test {args} { + puts stderr "bogus-should-not-load-$args" + } + proc about {} { + set msg "" + append msg "tclkits do not scan all directories in the base of their vfs for pkgIndex.tcl files" + append msg "This is because the base of the vfs is not in the ::auto_path by default." + append msg "zipfs based tcl will add the root of the vfs (mountpoint //zipfs:/app) to the ::auto_path," + append msg "not just //zipfs:/app/lib. This means every directory in the root of the zipfs vfs is scanned" + append msg "for pkgIndex.tcl files." + } } # # ## ### ##### ######## ############# ##################### diff --git a/src/vfs/_vfscommon.vfs/lib/app-punk/pkgIndex.tcl b/src/vfs/_vfscommon.vfs/lib/app-punk/pkgIndex.tcl index 6ace9792..ac1128f5 100644 --- a/src/vfs/_vfscommon.vfs/lib/app-punk/pkgIndex.tcl +++ b/src/vfs/_vfscommon.vfs/lib/app-punk/pkgIndex.tcl @@ -1,3 +1 @@ - - package ifneeded app-punk 1.0 [list source [file join $dir repl.tcl]] - +package ifneeded app-punk 1.0 [list source [file join $dir repl.tcl]] \ No newline at end of file diff --git a/src/vfs/_vfscommon.vfs/lib/app-punkshell/pkgIndex.tcl b/src/vfs/_vfscommon.vfs/lib/app-punkshell/pkgIndex.tcl new file mode 100644 index 00000000..1286773f --- /dev/null +++ b/src/vfs/_vfscommon.vfs/lib/app-punkshell/pkgIndex.tcl @@ -0,0 +1,2 @@ +package ifneeded app-punkshell 1.0 [list source [file join $dir punkshell.tcl]] + diff --git a/src/vfs/_vfscommon.vfs/lib/app-punkshell/punkshell.tcl b/src/vfs/_vfscommon.vfs/lib/app-punkshell/punkshell.tcl new file mode 100644 index 00000000..1559f0ec --- /dev/null +++ b/src/vfs/_vfscommon.vfs/lib/app-punkshell/punkshell.tcl @@ -0,0 +1,296 @@ +package provide app-punkshell 1.0 + +package require Thread +package require punk::args +package require shellfilter +package require punk::ansi +package require punk::packagepreference +punk::packagepreference::install + +namespace eval punkshell { + variable chanstack_stderr_redir + variable chanstack_stdout_redir + proc clock_sec {} { + return [expr {[clock millis]/1000.0}] + } + set do_log 0 + if {$do_log} { + set debug_syslog_server 127.0.0.1:514 + #set debug_syslog_server 172.16.6.42:51500 + set error_syslog_server 127.0.0.1:514 + set data_syslog_server 127.0.0.1:514 + } else { + set debug_syslog_server "" + set error_syslog_server "" + set data_syslog_server "" + } + #------------------------------------------------------------------------- + ##don't write to stdout/stderr before you've redirected them to a log using shellfilter functions + ## puts to stdout/stderr will comingle with command's output if performed before the channel stacks are configured. + + #chan configure stdin -buffering line + #chan configure stdout -buffering none + #chan configure stderr -buffering none + + #redir on the shellfilter stack with no log or syslog specified acts to suppress output of stdout & stderr. + #todo - fix shellfilter code to make this noop more efficient (avoid creating corresponding logging thread and filter?) + #JMN + #set redirconfig {-settings {-syslog 127.0.0.1:514 -file ""}} + set redirconfig {} + #lassign [shellfilter::redir_output_to_log "SUPPRESS" {*}$redirconfig] chanstack_stdout_redir chanstack_stderr_redir + #shellfilter::log::write $punkshell_status_log "shellfilter::redir_output_to_log SUPPRESS DONE [clock_sec]" + + set stdout_log "" + set stderr_log "" + #set stdout_log [file normalize ~]/punkshell-stdout.txt + #set stderr_log [file normalize ~]/punkshell-stderr.txt + set stdout_log "[pwd]/punkshell_out.log" + set stderr_log "[pwd]/punkshell_err.log" + + set errdeviceinfo [shellfilter::stack::new punkshellerr -settings [list -tag "punkshellerr" -buffering none -raw 1 -syslog $data_syslog_server -file $stderr_log]] + set outdeviceinfo [shellfilter::stack::new punkshellout -settings [list -tag "punkshellout" -buffering none -raw 1 -syslog $data_syslog_server -file $stdout_log]] + #set commandlog [dict get $outdeviceinfo localchan] + #puts $commandlog "HELLO $commandlog" + #flush $commandlog + + proc do_script {scriptname args} { + #ideally we don't want to launch an external process to run the script + #variable punkshell_status_log + #shellfilter::log::write $punkshell_status_log "do_script got scriptname:'$scriptname' replwhen:$replwhen args:'$args'" + set exepath [file dirname [file join [info nameofexecutable] __dummy__]] + set exedir [file dirname $exepath] + set scriptpath [file normalize $scriptname] + if {![file exists $scriptpath]} { + puts stderr "Failed to find script: '$scriptpath'" + error "bad scriptpath '$scriptpath'" + } + + set script [string map [list %a% $args %s% $scriptpath] { +set normscript %s% +#save values +set prevscript [info script] +set prevglobal [dict create] +foreach g [list ::argv ::argc ::argv0] { + if {[info exists $g]} { + dict set prevglobal $g [set $g] + } +} +#setup and run +set ::argv [list %a%] +set ::argc [llength $::argv] +set ::argv0 $normscript +info script $normscript +source $normscript +#restore values +info script $prevscript +dict with prevglobal {} + }] + + dict set params -tclscript 1 ;#don't give callback a chance to omit/break this + dict set params -teehandle punkshell + #dict set params -teehandle punksh + dict set params -inbuffering none + dict set params -outbuffering none + dict set params -readprocesstranslation crlf + dict set params -outtranslation lf + + set id_err [shellfilter::stack::add stderr ansiwrap -action sink-locked -settings {-colour {red bold}}] + + set exitinfo [shellfilter::run $script {*}$params] + + shellfilter::stack::remove stderr $id_err + + if {[dict exists $exitinfo errorInfo]} { + #strip out the irrelevant info from the errorInfo - we don't want info beyond 'invoked from within' as this is just plumbing related to the script sourcing + set stacktrace [string map [list \r\n \n] [dict get $exitinfo errorInfo]] + set output "" + set tracelines [split $stacktrace \n] + foreach ln $tracelines { + if {[string match "*invoked from within*" $ln]} { + break + } + append output $ln \n + } + set output [string trimright $output \n] + dict set exitinfo errorInfo $output + } + return $exitinfo + } + + proc do_tclkit {kitname replwhen args} { + + set script [string map [list %a% $args %k% $kitname] { +#::tcl::tm::add %m% +set kit %k% +set kitpath [file normalize $kit] +set kitmount $kitpath.0 + +#save values +set prevscript [info script] +set prevglobal [dict create] +foreach g [list ::argv ::argc ::argv0] { + if {[info exists $g]} { + dict set prevglobal $g [set $g] + } +} + +#setup and run +set ::argv [list %a%] +set ::argc [llength $::argv] + +set ::argv0 $kitmount +#puts stderr "setting 'info script' $kitmount/main.tcl" +info script $kitmount/main.tcl +#info script dir must match argv0 for kit main.tcl to return 'starkit' from 'starkit::startup' + +if {![catch { + package require vfs + package require vfs::mk4 + } errMsg]} { + + vfs::mk4::Mount $kitpath $kitmount + lappend ::auto_path $kitmount/lib + if {[file exists "$kitmount/modules"]} { + tcl::tm::add "$kitmount/modules" + } + + #puts stderr "sourcing $kitmount/main.tcl" + #puts stderr "$kitmount/main.tcl exists: [file exists $kitmount/main.tcl]" + #puts stderr "argv : $::argv" + #puts stderr "argv0: $::argv0" + #puts stderr "autopath: $::auto_path" + #puts stdout "starkit::startup [starkit::startup]" + + #usually main.tcl will just be something like: package require app-XXX + #it will usually do nothing if starkit::startup returned 'sourced' + + source $kitmount/main.tcl + +} else { + puts stderr "Unable to load vfs::mk4 for tclkit mounting" +} +#restore values +info script $prevscript +dict with prevglobal {} + }] + + set repl_lines "" + append repl_lines {package require punk::repl} \n + append repl_lines {repl::init -safe 0} \n + append repl_lines {repl::start stdin} \n + + #test + #set replwhen "repl_last" + + if {$replwhen eq "repl_first"} { + #we need to cooperate with the repl to get the script to run on exit + namespace eval ::repl {} + set ::repl::post_script $script + set script "$repl_lines" + } elseif {$replwhen eq "repl_last"} { + append script $repl_lines + } else { + #just the script + } + + dict set params -tclscript 1 ;#don't give callback a chance to omit/break this + dict set params -teehandle punkshell + dict set params -inbuffering none + dict set params -outbuffering none + dict set params -readprocesstranslation crlf + dict set params -outtranslation lf + + set id_err [shellfilter::stack::add stderr ansiwrap -action sink-locked -settings {-colour {red bold}}] + + set exitinfo [shellfilter::run $script {*}$params] + + shellfilter::stack::remove stderr $id_err + + if {[dict exists $exitinfo errorInfo]} { + #strip out the irrelevant info from the errorInfo - we don't want info beyond 'invoked from within' as this is just plumbing related to the script sourcing + set stacktrace [string map [list \r\n \n] [dict get $exitinfo errorInfo]] + set output "" + set tracelines [split $stacktrace \n] + foreach ln $tracelines { + if {[string match "*invoked from within*" $ln]} { + break + } + append output $ln \n + } + set output [string trimright $output \n] + dict set exitinfo errorInfo $output + } + return $exitinfo + } + + + punk::args::define { + @id -id ::punkshell + @cmd -name punkshell + @leaders -min 0 -max 0 + @opts + -debug -type none + @values -min 1 -max -1 + script_or_kit -type string + arg -type any -optional 1 -multiple 1 + } + set argd [punk::args::parse $::argv withid ::punkshell] + lassign [dict values $argd] leaders opts values received + + set script_or_kit [dict get $values script_or_kit] + if {[dict exists $received arg]} { + set arglist [dict get $values arg] + } else { + set arglist [list] + } + + set exitinfo [dict create] + switch -glob -nocase -- $script_or_kit { + lib:* { + #scriptlib + puts stderr "lib:* todo" + } + *.tcl { + set exitinfo [punkshell::do_script $script_or_kit {*}$arglist] + } + *.kit { + set exitinfo [punkshell::do_tclkit $script_or_kit "no_repl" {*}$arglist] + } + default { + puts stderr "unrecognised script extension" + } + } + + catch { + shellfilter::stack::remove stderr $chanstack_stderr_redir + shellfilter::stack::remove stdout $chanstack_stdout_redir + } + shellfilter::stack::delete punkshellout + shellfilter::stack::delete punkshellerr + set free_info [shellthread::manager::shutdown_free_threads] + foreach tid [thread::names] { + thread::release $tid + } + + if {[dict size $exitinfo] == 0} { + puts stderr "No result" + exit 2 + } + + if {[dict exists $exitinfo errorInfo]} { + set einf [dict get $exitinfo errorInfo] + puts stderr "errorCode: [dict get $exitinfo errorCode]" + if {[catch { + punk::ansi::ansiwrap yellow bold $einf + } msg]} { + set msg $einf + } + puts stderr $msg + flush stderr + exit 1 + } else { + puts -nonewline stdout [dict get $exitinfo result] + exit 0 + } +} + diff --git a/src/vfs/_vfscommon.vfs/lib/app-shellspy/pkgIndex.tcl b/src/vfs/_vfscommon.vfs/lib/app-shellspy/pkgIndex.tcl index 4e20e141..e15ce417 100644 --- a/src/vfs/_vfscommon.vfs/lib/app-shellspy/pkgIndex.tcl +++ b/src/vfs/_vfscommon.vfs/lib/app-shellspy/pkgIndex.tcl @@ -1,3 +1,2 @@ - - package ifneeded app-shellspy 1.0 [list source [file join $dir shellspy.tcl]] - +package ifneeded app-shellspy 1.0 [list source [file join $dir shellspy.tcl]] + diff --git a/src/vfs/_vfscommon.vfs/lib/app-shellspy/shellspy.tcl b/src/vfs/_vfscommon.vfs/lib/app-shellspy/shellspy.tcl index 654b5c40..2994077e 100644 --- a/src/vfs/_vfscommon.vfs/lib/app-shellspy/shellspy.tcl +++ b/src/vfs/_vfscommon.vfs/lib/app-shellspy/shellspy.tcl @@ -1,1168 +1,1281 @@ -#! /usr/bin/env tclsh -# -#copyright 2023 Julian Marcel Noble -#license: BSD (revised 3-clause) -# -#see notes at beginning of shellspy namespace re stdout/stderr -# -#SHELLSPY - provides commandline flag information and stdout/stderr logging/mirroring without output/pipeline interference, -# or modified output if modifying filters explicitly configured. -# -#shellspy uses the shellfilter and flagfilter libraries to run a commandline with tee-diversions of stdout/stderr to configured syslog/file logs -#Because it is a tee, the command's stdout/stderr are still available as direct output from this script. -#Various filters/modifiers/redirections can be placed on the channel stacks for stdin/stderr using the shellfilter::stack api -# and other shellfilter:: helpers such as shellfilter::redir_output_to_log -# Redirecting stderr/stdout in this way prior to the actual command run will not interfere with the command/pipeline output due to the way -# shellfilter temporarily inserts it's own tee into the stack at the point of the highest existing redirection it encounters. -# -#A note on input/output convention regarding channels/pipes -# we write to an output, read from an input. -# e.g when creating a pipe with 'lassign [chan pipe] in out' we write to out and read from in. -# This is potentially confusing from an OO-like perspective thinking of a pipe object as a sort of object. -# Don't think of it from the perspective of the pipe - but from the program using it. -# This is not a convention invented here for shellspy - but it seems to match documentation and common use e.g for 'chan pending input|output chanid' -# This matches the way we write to stdout read from stdin. -# Possibly using read/write related naming for pipe ends is clearer. eg 'lassign [chan pipe] rd_pipe1 wr_pipe1' -# -package provide app-shellspy 1.0 - - -#experiment - todo make a flag for it if it's useful -#Middle cap for direct dispatch without flagcheck arg processing or redirections or REPL. -set arg1 [lindex $::argv 0] -if {[file extension $arg1] in [list .tCl]} { - set ::argv [lrange $::argv 1 end] - set ::argc [llength $::argv] - - set exedir [file dirname [info nameofexecutable]] - set binscripts [file join $exedir scriptlib] - if {[file exists $binscripts]} { - set libdir $binscripts - } else { - set libdir [file join [file dirname $exedir] scriptlib]] - } - set scriptname $arg1 - if {[string match lib:* $scriptname]} { - set scriptname [string range $scriptname 4 end] - set scriptname [string trimleft $scriptname :] ;#incase specified as lib:: - set scriptpath $libdir/$scriptname - } else { - set scriptpath $scriptname - } - set scriptpath [file normalize $scriptpath] - - if {![file exists $scriptpath]} { - #try the lowercase version (extension lowercased only) so that file doesn't have to be renamed to use alternate dispatch - set scriptpath [file rootname $scriptpath][string tolower [file extension $scriptpath]] - } - source $scriptpath - - #package require app-punk - -} else { - - - -#set m_dir [file join $starkit::topdir modules] - - -#catch {package require tcllibc} - -#review. we need thread for when configured to pump info to syslog etc - but it is overhead for simple script calls. -#todo - see if we can avoid loading in certain cases (based on punk::config?) -package require Thread - -package require flagfilter -package require shellfilter -package require punk::ansi -package require punk::packagepreference -punk::packagepreference::install - -#The whole punk infrastructure is overkill for calling arbitrary scripts -#package require punk - -#testing -#package require packageTrace - -set ::testconfig 5 - -namespace eval shellspy { - variable chanstack_stderr_redir - variable chanstack_stdout_redir - - variable commands - proc clock_sec {} { - return [expr {[clock millis]/1000.0}] - } - variable shellspy_status_log "shellspy-[clock micros]" - - #todo - default to no logging not even to local syslog - #load a .toml config which can configure logging as desired - set do_log 0 - if {$do_log} { - set debug_syslog_server 127.0.0.1:514 - #set debug_syslog_server 172.16.6.42:51500 - #set debug_syslog_server "" - set error_syslog_server 127.0.0.1:514 - set data_syslog_server 127.0.0.1:514 - } else { - set debug_syslog_server "" - set error_syslog_server "" - set data_syslog_server "" - } - - - - - shellfilter::log::open $shellspy_status_log [list -tag $shellspy_status_log -syslog $debug_syslog_server -file ""] - shellfilter::log::write $shellspy_status_log "shellspy launch with args '$::argv'" - shellfilter::log::write $shellspy_status_log "stdout/stderr encoding: [chan configure stdout -encoding]/[chan configure stderr -encoding]" - - #------------------------------------------------------------------------- - ##don't write to stdout/stderr before you've redirected them to a log using shellfilter functions - ## puts to stdout/stderr will comingle with command's output if performed before the channel stacks are configured. - - chan configure stdin -buffering line - chan configure stdout -buffering none - chan configure stderr -buffering none - - #set id_ansistrip [shellfilter::stack::add stderr ansistrip -settings {}] - #set id_ansistrip [shellfilter::stack::add stdout ansistrip -settings {}] - - #redir on the shellfilter stack with no log or syslog specified acts to suppress output of stdout & stderr. - #todo - fix shellfilter code to make this noop more efficient (avoid creating corresponding logging thread and filter?) - #JMN - #set redirconfig {-settings {-syslog 127.0.0.1:514 -file ""}} - set redirconfig {} - lassign [shellfilter::redir_output_to_log "SUPPRESS" {*}$redirconfig] chanstack_stdout_redir chanstack_stderr_redir - shellfilter::log::write $shellspy_status_log "shellfilter::redir_output_to_log SUPPRESS DONE [clock_sec]" - - - ### - #we can now safely write to stderr/stdout and it will not interfere with stderr/stdout from the dispatched command. - #This is because when shellfilter::run is called it temporarily adds it's own filter in place of the redirection we just added. - # shellfilter::run installs tee_to_pipe on stdout & stderr with -action sink-aside. - # sink-aside means to sink down the filter stack to the topmost filter that is diversionary, and replace it. - # when the command finishes running, the redirecting filter that it displaced is reinstalled in the stack. - ### - - ### - #Note that futher filters installed here will sit 'above' any of the redirecting filters - # so apply to both the shellfilter::run commandline, - # as well as writes to stderr/stdout from here or other libraries operating in this process. - # To bypass the the filter-stack and still emit to syslog etc - - # you can use shellfilter::log::open and shellfilter::log::write e.g - # shellfilter::log::open "mystatuslog" [list -tag "mystatuslog" -syslog 172.16.6.42:51500 -file ""] - # shellfilter::log::write "mystatuslog" "shellspy launch" - # - #### - #set id_ansistrip [shellfilter::stack::add stderr ansistrip -action float -settings {}] - #set id_ansistrip [shellfilter::stack::add stdout ansistrip -action float -settings {}] - - - ##stdin stack operates in reverse compared to stdout/stderr in that first added to stack is first to see the data - ##for stdin: first added to stack is 'upstream' as it will always encounter the data before later ones added to the stack. - ##for stdout: first added to stack is 'downstream' as it will alays encounter the data after others on the stack - #shellfilter::stack::add stdin ansistrip -action {} -settings {} - #shellfilter::stack::add stdin tee_to_log -settings {-tag "input" -raw 1 -syslog 172.16.6.42:51500 -file ""} - - #------------------------------------------------------------------------- - ##note - to use shellfilter::stack::new - the fifo2 end at the local side requires the event loop to be running - ## for interactive testing a relatively simple repl.tcl can be used. - - #todo - default to no logging.. add special flag in checkflags to indicate end of options for matched command only e.g --- ? - # then prioritize these results from checkflags to configure pre-dispatch behaviour by running a predispatch script(?) - # - # we can log flag-processing info coming from checkflags.. but we don't want to do two opt scans and emit it twice. - # configuration of the logging for flag/opt parsing should come from a config file and default to none. - #set stdout_log [file normalize ~]/shellspy-stdout.txt - #set stderr_log [file normalize ~]/shellspy-stderr.txt - set stdout_log "" - set stderr_log "" - - shellfilter::log::write $shellspy_status_log "shellfilter::stack::new shellspyerr ABOUTTO [clock_sec]" - set errdeviceinfo [shellfilter::stack::new shellspyerr -settings [list -tag "shellspyerr" -buffering none -raw 1 -syslog $data_syslog_server -file $stderr_log]] - shellfilter::log::write $shellspy_status_log "shellfilter::stack::new shellspyerr DONE [clock_sec]" - - - shellfilter::log::write $shellspy_status_log "shellfilter::stack::new shellspyout ABOUTTO [clock_sec]" - set outdeviceinfo [shellfilter::stack::new shellspyout -settings [list -tag "shellspyout" -buffering none -raw 1 -syslog $data_syslog_server -file $stdout_log]] - set commandlog [dict get $outdeviceinfo localchan] - #puts $commandlog "HELLO $commandlog" - #flush $commandlog - shellfilter::log::write $shellspy_status_log "shellfilter::stack::new shellspyout DONE [clock_sec]" - - - - #note that this filter is inline with the data teed off to the shellspyout log. - #To filter the main stdout an addition to the stdout stack can be made. specify -action float to have it affect both stdout and the tee'd off data. - set id_ansistrip [shellfilter::stack::add shellspyout ansistrip -settings {}] - shellfilter::log::write $shellspy_status_log "shellfilter::stack::add shellspyout ansistrip DONE [clock_sec]" - - - #set id_out [shellfilter::stack::add stdout rebuffer -settings {}] - - #an example filter to capture some output to a var for later use - this one is for ansible-playbook - #set ::recap "" - #set id_tee_grep [shellfilter::stack::add shellspyout tee_grep_to_var -settings {-grep ".*PLAY RECAP.*|.*fatal:.*|.*changed:.*" -varname ::recap -pre 1 -post 3}] - - namespace import ::flagfilter::check_flags - - namespace eval shellspy::callbacks {} - namespace eval shellspy::parameters {} - - - proc do_callback {func args} { - variable shellspy_status_log - set exedir [file dirname [info nameofexecutable]] - set dispatchtcl [file join $exedir callbacks dispatch.tcl] - if {[file exists $dispatchtcl]} { - source $dispatchtcl - if {[llength [info commands shellspy::callbacks::$func]]} { - shellfilter::log::write $shellspy_status_log "found shellspy::callbacks::$func - calling" - if {[catch { - set args [shellspy::callbacks::$func {*}$args] - } errmsg]} { - shellfilter::log::write $shellspy_status_log "ERROR in shellspy::callbacks::$func\n errormsg:$errmsg" - error $errmsg - } - } - } - return $args - } - proc do_callback_parameters {func args} { - variable shellspy_status_log - set exedir [file dirname [info nameofexecutable]] - set paramtcl [file join $exedir callbacks parameters.tcl] - set params $args - if {[file exists $paramtcl]} { - source $paramtcl - if {[llength [info commands shellspy::parameters::$func]]} { - shellfilter::log::write $shellspy_status_log "found shellspy::parameters::$func - calling" - if {[catch { - set params [shellspy::parameters::$func $params] - } errmsg]} { - shellfilter::log::write $shellspy_status_log "ERROR in shellspy::parameters::$func\n errormsg:$errmsg" - } - } - } - return $params - } - - #some tested configs - proc get_channel_config {config} { - #note tcl script being called from wrong place.. configs don't affect: todo - move it. - set params [dict create] - switch -- $config { - 0 { - #bad for: everything. extra cr - dict set params -inbuffering line - dict set params -outbuffering line - dict set params -readprocesstranslation auto ;#default - dict set params -outtranslation auto - } - 1 { - #ok for: cmd, cmd/u/c,raw,pwsh, sh,raw, tcl script process - #not ok for: bash,wsl, tcl script - dict set params -inbuffering line - dict set params -outbuffering line - dict set params -readprocesstranslation auto ;#default - dict set params -outtranslation lf - } - 2 { - #ok for: cmd, cmd/uc,pwsh,sh , tcl script process - #not ok for: tcl script, bash, wsl - dict set params -inbuffering none ;#default - dict set params -outbuffering none ;#default - dict set params -readprocesstranslation auto ;#default - dict set params -outtranslation lf ;#default - } - 3 { - #ok for: cmd - dict set params -inbuffering line - dict set params -outbuffering line - dict set params -readprocesstranslation lf - dict set params -outtranslation lf - } - 4 { - #ok for: cmd,cmd/uc,raw,sh - #not ok for pwsh,bash,wsl, tcl script, tcl script process - dict set params -inbuffering none - dict set params -outbuffering none - dict set params -readprocesstranslation lf - dict set params -outtranslation lf - } - 5 { - #ok for: pwsh,cmd,cmd/u/c,raw,sh, tcl script process - #not ok for bash,wsl - #ok for vim cmd/u/c but only with to_unix filter on stdout (works in gvim and console) - dict set params -inbuffering none - dict set params -outbuffering none - dict set params -readprocesstranslation crlf - dict set params -outtranslation lf - } - 6 { - #ok for: cmd,cmd/u/c,pwsh,raw,sh,bash - #not ok for: vim with cmd /u/c (?) - dict set params -inbuffering line - dict set params -outbuffering line - dict set params -readprocesstranslation crlf - dict set params -outtranslation lf - } - 7 { - #ok for: sh,bash - #not ok for: wsl (display ok but extra cr), cmd,cmd/u/c,pwsh, tcl script, tcl script process, raw - dict set params -inbuffering none - dict set params -outbuffering none - dict set params -readprocesstranslation crlf - dict set params -outtranslation crlf - } - 8 { - #not ok for anything..all have extra cr - dict set params -inbuffering none - dict set params -outbuffering none - dict set params -readprocesstranslation lf - dict set params -outtranslation crlf - } - } - return $params - } - - proc do_help {args} { - #return [dict create result $::shellspy::commands] - set result "" - foreach cmd $::shellspy::commands { - lassign $cmd tag cmdinfo - if {[lindex $cmdinfo 0] eq "sub"} { - continue - } - if {[dict exists $cmdinfo match]} { - append result "$tag [dict get $cmdinfo match]" \n - } - } - return [dict create result $result] - } - - - #punk86 -tk example: - # punk86 -tk eval "button .tk.b -text doit -command {set ::punkapp::result(shell) guiresult;punkapp::close_window .tk}; pack .tk.b;return somedefaultvalue" - proc do_tclline {flavour args} { - variable chanstack_stderr_redir - variable chanstack_stdout_redir - - if {$flavour in [list "punk" "punkshell"]} { - namespace eval :: {package require punk;package require shellrun} - } elseif {$flavour in [list "tk" "tkshell"]} { - namespace eval :: { - package require Tk - package require punkapp - punkapp::hide_dot_window - toplevel .tk - if {[wm protocol . WM_DELETE_WINDOW] eq ""} { - wm protocol . WM_DELETE_WINDOW [list punkapp::close_window .] - } - wm protocol .tk WM_DELETE_WINDOW [list punkapp::close_window .tk] - } - } - #remove SUPPRESS redirection if it was in place so that shell output is visible - catch { - shellfilter::stack::remove stderr $chanstack_stderr_redir - shellfilter::stack::remove stdout $chanstack_stdout_redir - } - set result_is_error 0 - if {[catch {apply [list {arglist} {namespace eval :: $arglist} ::] $args} result]} { - set result_is_error 1 - } - if {$flavour in [list "punkshell" "tkshell"]} { - set result [namespace eval :: [string map [list %e% $chanstack_stderr_redir %o% $chanstack_stdout_redir %r% $result] { - package require punk - package require shellrun - package require punk::repl - puts stdout "quit to exit" - repl::init -safe 0 - repl::start stdin -defaultresult %r% - }]] - } - - #todo - better exit? - if {$result_is_error} { - if {$flavour eq "tk"} { - return [dict create error [namespace eval :: [list punkapp::wait -defaultresult $result]]] - #todo - better return value e.g from dialog? - } - return [dict create error $result] - } else { - if {$flavour eq "tk"} { - return [dict create result [namespace eval :: [list punkapp::wait -defaultresult $result]]] - #todo - better return value e.g from dialog? - } - return [dict create result $result] - } - } - proc set_punkd {args} { - variable shellspy_status_log - shellfilter::log::write $shellspy_status_log "set_punkd got '$args'" - - set punkd_status_log "set_punkd_log" - shellfilter::log::open $punkd_status_log [list -tag $punkd_status_log -syslog 127.0.0.1:514 -file ""] - shellfilter::log::write $punkd_status_log "set_punkd got '$args'" - return [dict create result ok] - } - - proc do_in_powershell {args} { - variable shellspy_status_log - shellfilter::log::write $shellspy_status_log "do_in_powershell got '$args'" - set args [do_callback powershell {*}$args] - set params [do_callback_parameters powershell] - dict set params -teehandle shellspy - - - #readprocesstranslation lf - doesn't work for buffering line or none - #readprocesstranslation crlf works for buffering line and none with outchantranslation lf - - set params [dict merge $params [get_channel_config $::testconfig]] ;#working: 5 unbuffered, 6 linebuffered - - - dict set params -debug 1 - dict set params -timeout 1000 - - #set exitinfo [shellfilter::run [list pwsh -nologo -noprofile -c {*}$args] -debug 1] - - - set id_err [shellfilter::stack::add stderr ansiwrap -action sink -settings {-colour {red bold}}] - set exitinfo [shellfilter::run [list pwsh -nologo -noprofile -c {*}$args] {*}$params] - shellfilter::stack::remove stderr $id_err - - #Passing args in as a single element will tend to make powershell treat the args as a 'script block' - # (powershell sees items in curly brackets {} as a scriptblock - when called from non-powershell, this tends to just echo back the contents) - #set exitinfo [shellfilter::run [list pwsh -nologo -noprofile -c $args] {*}$params] - if {[lindex $exitinfo 0] eq "exitcode"} { - shellfilter::log::write $shellspy_status_log "do_in_powershell returning $exitinfo" - #exit [lindex $exitinfo 1] - } - return $exitinfo - } - proc do_in_powershell_terminal {args} { - variable shellspy_status_log - shellfilter::log::write $shellspy_status_log "do_in_powershell_terminal got '$args'" - set args [do_callback powershell {*}$args] - set params [do_callback_parameters powershell] - dict set params -teehandle shellspy - set params [dict merge $params [get_channel_config $::testconfig]] ;#working: 5 unbuffered, 6 linebuffered - - #set cmdlist [list pwsh -nologo -noprofile -c {*}$args] - set cmdlist [list pwsh -nologo -c {*}$args] - #the big problem with using the 'script' command is that we get stderr/stdout mashed together. - - #set cmdlist [shellfilter::get_scriptrun_from_cmdlist_dquote_if_not $cmdlist] - shellfilter::log::write $shellspy_status_log "do_in_powershell_terminal as script: '$cmdlist'" - - set id_err [shellfilter::stack::add stderr ansiwrap -action sink -settings {-colour {red bold}}] - set exitinfo [shellfilter::run $cmdlist {*}$params] - shellfilter::stack::remove stderr $id_err - - if {[lindex $exitinfo 0] eq "exitcode"} { - shellfilter::log::write $shellspy_status_log "do_in_powershell_terminal returning $exitinfo" - } - return $exitinfo - } - - - proc do_in_cmdshell {args} { - variable shellspy_status_log - shellfilter::log::write $shellspy_status_log "do_in_cmdshell got '$args'" - set args [do_callback cmdshell {*}$args] - set params [do_callback_parameters cmdshell] - - - dict set params -teehandle shellspy - dict set params -copytempfile 1 - - set params [dict merge $params [get_channel_config $::testconfig]] - - #set id_out [shellfilter::stack::add stdout tounix -action sink-locked -settings {}] - set id_err [shellfilter::stack::add stderr ansiwrap -action sink-locked -settings {-colour {red bold}}] - - #set exitinfo [shellfilter::run "cmd /c $args" -debug 1] - set exitinfo [shellfilter::run [list cmd /c {*}$args] {*}$params] - #set exitinfo [shellfilter::run [list cmd /c {*}$args] -debug 1] - - shellfilter::stack::remove stderr $id_err - - #shellfilter::stack::remove stdout $id_out - - shellfilter::log::write $shellspy_status_log "do_in_cmdshell raw exitinfo: $exitinfo" - - - if {[lindex $exitinfo 0] eq "exitcode"} { - #exit [lindex $exitinfo 1] - #shellfilter::log::write $shellspy_status_log "do_in_cmdshell returning $exitinfo" - #puts stderr "do_in_cmdshell returning $exitinfo" - } - return $exitinfo - } - proc do_in_cmdshellb {args} { - - variable shellspy_status_log - shellfilter::log::write $shellspy_status_log "do_in_cmdshellb got '$args'" - - set args [do_callback cmdshellb {*}$args] - - - shellfilter::log::write $shellspy_status_log "do_in_cmdshellb post_callback args '$args'" - - set params [do_callback_parameters cmdshellb] - dict set params -teehandle shellspy - dict set params -copytempfile 1 - dict set params -debug 0 - - #----------------------------- - #channel config 6 and towindows sink-aside-locked {-junction 1} works with vim-flog - #----------------------------- - set params [dict merge $params [get_channel_config 6]] - #set id_out [shellfilter::stack::add stdout tounix -action sink-aside-locked -junction 1 -settings {}] - - - set exitinfo [shellfilter::run [list cmd /u/c {*}$args] {*}$params] - - #shellfilter::stack::remove stdout $id_out - - if {[lindex $exitinfo 0] eq "exitcode"} { - shellfilter::log::write $shellspy_status_log "do_in_cmdshellb returning with exitcode $exitinfo" - } else { - shellfilter::log::write $shellspy_status_log "do_in_cmdshellb returning WITHOUT exitcode $exitinfo" - } - return $exitinfo - } - proc do_in_cmdshelluc {args} { - variable shellspy_status_log - shellfilter::log::write $shellspy_status_log "do_in_cmdshelluc got '$args'" - set args [do_callback cmdshelluc {*}$args] - set params [do_callback_parameters cmdshell] - #set exitinfo [shellfilter::run "cmd /c $args" -debug 1] - dict set params -teehandle shellspy - dict set params -copytempfile 1 - dict set params -debug 0 - - #set params [dict merge $params [get_channel_config $::testconfig]] - - set params [dict merge $params [get_channel_config 1]] - #set id_out [shellfilter::stack::add stdout tounix -action sink-locked -settings {}] - - set id_out [shellfilter::stack::add stdout tounix -action sink-locked -settings {}] - - set exitinfo [shellfilter::run [list cmd /u/c {*}$args] {*}$params] - shellfilter::stack::remove stdout $id_out - #chan configure stdout -translation crlf - - if {[lindex $exitinfo 0] eq "exitcode"} { - #exit [lindex $exitinfo 1] - shellfilter::log::write $shellspy_status_log "do_in_cmdshelluc returning $exitinfo" - #puts stderr "do_in_cmdshell returning $exitinfo" - } - return $exitinfo - } - proc do_raw {args} { - variable shellspy_status_log - shellfilter::log::write $shellspy_status_log "do_raw got '$args'" - set args [do_callback raw {*}$args] - set params [do_callback_parameters raw] - #set params {} - dict set params -debug 0 - #dict set params -outprefix "_test_" - dict set params -teehandle shellspy - - - set params [dict merge $params [get_channel_config $::testconfig]] - - - if {[llength $params]} { - set exitinfo [shellfilter::run $args {*}$params] - } else { - set exitinfo [shellfilter::run $args -debug 1 -outprefix "j"] - } - if {[lindex $exitinfo 0] eq "exitcode"} { - shellfilter::log::write $shellspy_status_log "do_raw returning $exitinfo" - } - return $exitinfo - } - - proc do_script_process {scriptbin scriptname args} { - variable shellspy_status_log - if {$scriptbin eq "withinterp.word0"} { - set scriptbin $scriptname - set scriptname [lindex $args 0] - set args [lrange $args 1 end] - } - shellfilter::log::write $shellspy_status_log "do_script_process got scriptname:'$scriptname' args:'$args'" - #no script_process callbacks - #set args [do_callback script_process {*}$args] - #set params [do_callback_parameters script_process] - dict set params -teehandle shellspy - - set params [dict merge $params [get_channel_config $::testconfig]] - - set exedir [file dirname [info nameofexecutable]] - if {[file exists $exedir/scriptlib]} { - set libroot $exedir/scriptlib - } else { - set libroot [file dirname $exedir]/scriptlib - } - if {[string match lib:* $scriptname]} { - set scriptname [string range $scriptname 4 end] - set scriptname [string trimleft $scriptname :] ;#incase specified as lib:: - set scriptpath $libroot/$scriptname - } else { - set scriptpath $scriptname - } - set scriptpath [file normalize $scriptpath] - if {![file exists $scriptpath]} { - if {[file extension $scriptpath] eq ""} { - set scriptpath $scriptpath.tcl - } else { - set scriptpath [file rootname $scriptpath][string tolower [file extension $scriptpath]] - } - if {![file exists $scriptpath]} { - puts stderr "Failed to find script: '$scriptpath'" - error "bad scriptpath '$scriptpath' arguments: $scriptbin $scriptname $args" - } - } - - - - #set id_err [shellfilter::stack::add stderr ansiwrap -action sink-locked -settings {-colour {red bold}}] - - - - #todo - use glob to check capitalisation of file tail (.TCL vs .tcl .Tcl etc) - set exitinfo [shellfilter::run [concat [auto_execok $scriptbin] $scriptpath $args] {*}$params] - shellfilter::log::write $shellspy_status_log "do_script_process exitinfo: $exitinfo" - - #shellfilter::stack::remove stderr $id_err - - #if {[lindex $exitinfo 0] eq "exitcode"} { - # shellfilter::log::write $shellspy_status_log "do_script_process returning $exitinfo" - #} - #if {[dict exists $exitinfo errorCode]} { - # exit [dict get $exitinfo $errorCode] - #} - return $exitinfo - } - proc do_script {scriptname replwhen args} { - #ideally we don't want to launch an external process to run the script - variable shellspy_status_log - #shellfilter::log::write $shellspy_status_log "do_script got scriptname:'$scriptname' replwhen:$replwhen args:'$args'" - set exepath [file dirname [file join [info nameofexecutable] __dummy__]] - set exedir [file dirname $exepath] - - if {[file tail $exedir] eq "bin"} { - set basedir [file dirname $exedir] - } else { - set basedir $exedir - } - set libroot [file join $basedir scriptlib] - if {[string match lib:* $scriptname]} { - set scriptname [string range $scriptname 4 end] - set scriptname [string trimleft $scriptname :] ;#incase specified as lib:: - set scriptpath $libroot/$scriptname - } else { - set scriptpath $scriptname - } - set scriptpath [file normalize $scriptpath] - if {![file exists $scriptpath]} { - if {[file extension $scriptpath] eq ""} { - set scriptpath $scriptpath.tcl - } else { - set scriptpath [file rootname $scriptpath][string tolower [file extension $scriptpath]] - } - if {![file exists $scriptpath]} { - puts stderr "Failed to find script: '$scriptpath'" - error "bad scriptpath '$scriptpath'" - } - } - set modulesdir $basedir/modules - - set script [string map [list %a% $args %s% $scriptpath %m% $modulesdir] { -#::tcl::tm::add %m% -set scriptname %s% -set normscript [file normalize $scriptname] - -#save values -set prevscript [info script] -set prevglobal [dict create] -foreach g [list ::argv ::argc ::argv0] { - if {[info exists $g]} { - dict set prevglobal $g [set $g] - } -} - -#setup and run -set ::argv [list %a%] -set ::argc [llength $::argv] -set ::argv0 $normscript -info script $normscript -source $normscript - -#restore values -info script $prevscript -dict with prevglobal {} - }] - - set repl_lines "" - #append repl_lines {puts stderr "starting repl [chan names]"} \n - #append repl_lines {puts stderr "stdin [chan configure stdin]"} \n - append repl_lines {package require punk::repl} \n - append repl_lines {repl::init -safe 0} \n - append repl_lines {repl::start stdin} \n - - #append repl_lines {puts stdout "shutdown message"} \n - - if {$replwhen eq "repl_first"} { - #we need to cooperate with the repl to get the script to run on exit - namespace eval ::repl {} - set ::repl::post_script $script - set script "$repl_lines" - } elseif {$replwhen eq "repl_last"} { - append script $repl_lines - } else { - #just the script - } - - #no script callbacks - #set args [do_callback script {*}$args] - #set params [do_callback_parameters script] - - dict set params -tclscript 1 ;#don't give callback a chance to omit/break this - dict set params -teehandle shellspy - #dict set params -teehandle punksh - - - set params [dict merge $params [get_channel_config $::testconfig]] - - set id_err [shellfilter::stack::add stderr ansiwrap -action sink-locked -settings {-colour {red bold}}] - - set exitinfo [shellfilter::run $script {*}$params] - - shellfilter::stack::remove stderr $id_err - - #if {[lindex $exitinfo 0] eq "exitcode"} { - # shellfilter::log::write $shellspy_status_log "do_script returning $exitinfo" - #} - - #jjj - #shellfilter::log::write $shellspy_status_log "do_script raw exitinfo: $exitinfo" - if {[dict exists $exitinfo errorInfo]} { - #strip out the irrelevant info from the errorInfo - we don't want info beyond 'invoked from within' as this is just plumbing related to the script sourcing - set stacktrace [string map [list \r\n \n] [dict get $exitinfo errorInfo]] - set output "" - set tracelines [split $stacktrace \n] - foreach ln $tracelines { - if {[string match "*invoked from within*" $ln]} { - break - } - append output $ln \n - } - set output [string trimright $output \n] - dict set exitinfo errorInfo $output - #jjj - #shellfilter::log::write $shellspy_status_log "do_script simplified exitinfo: $exitinfo" - } - return $exitinfo - } - - proc shellescape {arglist} { - set out [list] - foreach a $arglist { - set a [string map [list \\ \\\\ ] $a] - lappend out $a - } - return $out - } - proc do_shell {shell args} { - variable shellspy_status_log - shellfilter::log::write $shellspy_status_log "do_shell $shell got '$args' [llength $args]" - set args [do_callback $shell {*}$args] - shellfilter::log::write $shellspy_status_log "do_shell $shell xgot '$args'" - set params [do_callback_parameters $shell] - dict set params -teehandle shellspy - - - set params [dict merge $params [get_channel_config $::testconfig]] - - set id_out [shellfilter::stack::add stdout towindows -action sink-aside-locked -junction 1 -settings {}] - - #shells that take -c and need all args passed together as a string - - set exitinfo [shellfilter::run [concat $shell -c [shellescape $args]] {*}$params] - - shellfilter::stack::remove stdout $id_out - - - if {[lindex $exitinfo 0] eq "exitcode"} { - shellfilter::log::write $shellspy_status_log "do_shell $shell returning $exitinfo" - } - return $exitinfo - } - proc do_wsl {distdefault args} { - variable shellspy_status_log - shellfilter::log::write $shellspy_status_log "do_wsl $distdefault got '$args' [llength $args]" - set args [do_callback wsl {*}$args] ;#use dist? - shellfilter::log::write $shellspy_status_log "do_wsl $distdefault xgot '$args'" - set params [do_callback_parameters wsl] - - dict set params -debug 0 - - set params [dict merge $params [get_channel_config $::testconfig]] - - set id_out [shellfilter::stack::add stdout towindows -action sink-aside-locked -junction 1 -settings {}] - - dict set params -teehandle shellspy ;#shellspyout shellspyerr must exist - set exitinfo [shellfilter::run [concat wsl -d $distdefault -e [shellescape $args]] {*}$params] - - - shellfilter::stack::remove stdout $id_out - - - if {[lindex $exitinfo 0] eq "exitcode"} { - shellfilter::log::write $shellspy_status_log "do_wsl $distdefault returning $exitinfo" - } - return $exitinfo - } - - #todo - load these from a callback - set commands [list] - lappend commands [list punkd [list match [list punkd] dispatch [list shellspy::set_punkd] dispatchtype raw dispatchglobal 1 singleopts {any}]] - lappend commands [list punkd [list sub punkdict singleopts {any}]] - - - #'shout' extension (all uppercase) to force use of tclsh as a separate process - #todo - detect various extensions - and use all script-preceding unmatched args as interpreter+options - #e.g perl,php,python etc. - #For tcl will make it easy to test different interpreter output from tclkitsh, tclsh8.6, tclsh8.7 etc - #for now we have a hardcoded default interpreter for tcl as 'tclsh' - todo: get default interps from config - #(or just attempt launch in case there is shebang line in script) - #we may get ambiguity with existing shell match-specs such as -c /c -r. todo - only match those in first slot? - lappend commands [list tclscriptprocess [list match [list {.*\.TCL$} {.*\.TM$} {.*\.TK$}] dispatch [list shellspy::do_script_process [info nameofexecutable] %matched%] dispatchtype raw dispatchglobal 1 singleopts {any}]] - for {set i 0} {$i < 25} {incr i} { - lappend commands [list tclscriptprocess [list sub word$i singleopts {any}]] - } - - #camelcase convention .Tcl script before repl - lappend commands [list tclscriptbeforerepl [list match [list {.*\.Tcl$} {.*\.Tm$} {.*\.Tk$} ] dispatch [list shellspy::do_script %matched% "repl_last"] dispatchtype raw dispatchglobal 1 singleopts {any}]] - for {set i 0} {$i < 25} {incr i} { - lappend commands [list tclscriptbeforerepl [list sub word$i singleopts {any}]] - } - - - #Backwards Camelcase convention .tcL - means repl first, script last - lappend commands [list tclscriptafterrepl [list match [list {.*\.tcL$} {.*\.tM$} {.*\.tK$} ] dispatch [list shellspy::do_script %matched% "repl_first"] dispatchtype raw dispatchglobal 1 singleopts {any}]] - for {set i 0} {$i < 25} {incr i} { - lappend commands [list tclscriptafterrepl [list sub word$i singleopts {any}]] - } - - - #we've already handled .Tcl .tcL, .tCl, .TCL - handle any other capitalisations as a script in this process - lappend commands [list tclscript [list match [list {.*\.tcl$} {.*\.tCL$} {.*\.TCl$} {.*\.tm$} {.*\.tk$} ] dispatch [list shellspy::do_script %matched% "no_repl"] dispatchtype raw dispatchglobal 1 singleopts {any}]] - for {set i 0} {$i < 25} {incr i} { - lappend commands [list tclscript [list sub word$i singleopts {any}]] - } - #%argN% and %argtakeN% can be used as well as %matched% - %argtakeN% will remove from raw and arguments elements of dispatchrecord - lappend commands [list withinterp [list match {^withinterp$} dispatch [list shellspy::do_script_process %argtake0% %argtake1%] dispatchtype raw dispatchglobal 1 singleopts {any} longopts {any} pairopts {any}]] - for {set i 0} {$i < 25} {incr i} { - lappend commands [list withinterp [list sub word$i singleopts {any} longopts {any} pairopts {any}]] - } - - lappend commands [list runcmdfile [list match [list {.*\.cmd$} {.*\.bat$} ] dispatch [list shellspy::do_in_cmdshell %matched%] dispatchtype raw dispatchglobal 1 singleopts {any} longopts {any}]] - for {set i 0} {$i < 25} {incr i} { - lappend commands [list runcmdfile [list sub word$i singleopts {any}]] - } - - lappend commands [list libscript [list match [list {lib:.*$} ] dispatch [list shellspy::do_script %matched% "no_repl"] dispatchtype raw dispatchglobal 1 singleopts {any}]] - for {set i 0} {$i < 25} {incr i} { - lappend commands [list libscript [list sub word$i singleopts {any}]] - } - - lappend commands [list luascriptprocess [list match [list {.*\.lua|Lua|LUA$}] dispatch [list shellspy::do_script_process lua %matched% "no_repl"] dispatchtype raw dispatchglobal 1 singleopts {any}]] - for {set i 0} {$i < 25} {incr i} { - lappend commands [list luascriptprocess [list sub word$i singleopts {any}]] - } - - lappend commands [list phpscriptprocess [list match [list {.*\.php|Php|PHP$}] dispatch [list shellspy::do_script_process php %matched% "no_repl"] dispatchtype raw dispatchglobal 1 singleopts {any}]] - for {set i 0} {$i < 25} {incr i} { - lappend commands [list phpscriptprocess [list sub word$i singleopts {any}]] - } - - lappend commands [list bashraw [list match {^bash$} dispatch [list shellspy::do_shell bash] dispatchtype raw dispatchglobal 1 singleopts {any}]] - for {set i 0} {$i < 25} {incr i} { - lappend commands [list bashraw [list sub word$i singleopts {any}]] - } - lappend commands [list runbash [list match {^shellbash$} dispatch [list shellspy::do_shell bash] dispatchtype shell dispatchglobal 1 singleopts {any}]] - for {set i 0} {$i < 25} {incr i} { - lappend commands [list runbash [list sub word$i singleopts {any}]] - } - - lappend commands {shraw {match {^sh$} dispatch {shellspy::do_shell sh} dispatchtype raw dispatchglobal 1 singleopts {any}}} - for {set i 0} {$i < 25} {incr i} { - lappend commands [list shraw [list sub word$i singleopts {any}]] - } - - lappend commands {runsh {match {^s$} dispatch {shellspy::do_shell sh} dispatchtype shell dispatchglobal 1 singleopts {any}}} - for {set i 0} {$i < 25} {incr i} { - lappend commands [list runsh [list sub word$i singleopts {any}]] - } - - lappend commands {runraw {match {^-r$} dispatch shellspy::do_raw dispatchtype raw dispatchglobal 1 singleopts {any}}} - for {set i 0} {$i < 25} {incr i} { - lappend commands [list runraw [list sub word$i singleopts {any}]] - } - lappend commands {runpwsh {match {^-c$} dispatch shellspy::do_in_powershell dispatchtype raw dispatchglobal 1 singleopts {any}}} - for {set i 0} {$i < 25} {incr i} { - lappend commands [list runpwsh [list sub word$i singleopts {any}]] - } - lappend commands {runpwsht {match {^pwsh$} dispatch shellspy::do_in_powershell_terminal dispatchtype raw dispatchglobal 1 singleopts {any}}} - for {set i 0} {$i < 25} {incr i} { - lappend commands [list runpwsht [list sub word$i singleopts {any}]] - } - - - lappend commands {runcmd {match {^/c$} dispatch shellspy::do_in_cmdshell dispatchtype raw dispatchglobal 1 singleopts {any} longopts {any}}} - for {set i 0} {$i < 25} {incr i} { - lappend commands [list runcmd [list sub word$i singleopts {any}]] - } - lappend commands {runcmduc {match {^/u/c$} dispatch shellspy::do_in_cmdshelluc dispatchtype raw dispatchglobal 1 singleopts {any} longopts {any}}} - for {set i 0} {$i < 25} {incr i} { - lappend commands [list runcmduc [list sub word$i singleopts {any}]] - } - #cmd with bracketed args () e.g with vim shellxquote set to "(" - lappend commands [list runcmdb [list match {^cmdb$} dispatch [list shellspy::do_in_cmdshellb] dispatchtype raw dispatchglobal 1 singleopts {any} longopts {any} pairopts {any}]] - for {set i 0} {$i < 25} {incr i} { - lappend commands [list runcmdb [list sub word$i singleopts {any} longopts {any} pairopts {any}]] - } - - lappend commands [list wslraw [list match {^wsl$} dispatch [list shellspy::do_wsl AlmaLinux9] dispatchtype raw dispatchglobal 1 singleopts {any} longopts {any}]] - for {set i 0} {$i < 25} {incr i} { - lappend commands [list wslraw [list sub word$i singleopts {any}]] - } - - #e.g - # punk -tcl info patch - # punk -tcl eval "package require punk::char;punk::char::charset_page dingbats" - - lappend commands [list tclline [list match [list {^-tcl$}] dispatch [list shellspy::do_tclline tcl] dispatchtype raw dispatchglobal 1 singleopts {any} longopts {any}]] - for {set i 0} {$i < 25} {incr i} { - lappend commands [list tclline [list sub word$i singleopts {any}]] - } - lappend commands [list punkline [list match {^-punk$} dispatch [list shellspy::do_tclline punk] dispatchtype raw dispatchglobal 1 singleopts {any} longopts {any}]] - for {set i 0} {$i < 25} {incr i} { - lappend commands [list punkline [list sub word$i singleopts {any}]] - } - lappend commands [list tkline [list match {^-tk$} dispatch [list shellspy::do_tclline tk] dispatchtype raw dispatchglobal 1 singleopts {any} longopts {any}]] - for {set i 0} {$i < 25} {incr i} { - lappend commands [list tkline [list sub word$i singleopts {any}]] - } - lappend commands [list tkshellline [list match {^-tkshell$} dispatch [list shellspy::do_tclline tkshell] dispatchtype raw dispatchglobal 1 singleopts {any} longopts {any}]] - for {set i 0} {$i < 25} {incr i} { - lappend commands [list tkshellline [list sub word$i singleopts {any}]] - } - lappend commands [list punkshellline [list match {^-punkshell$} dispatch [list shellspy::do_tclline punkshell] dispatchtype raw dispatchglobal 1 singleopts {any} longopts {any}]] - for {set i 0} {$i < 25} {incr i} { - lappend commands [list punkshellline [list sub word$i singleopts {any}]] - } - - - lappend commands [list help [list match [list {^-help$} {^--help$} {^help$} {^/\?}] dispatch [list shellspy::do_help] dispatchtype raw dispatchglobal 1 singleopts {any} longopts {any}]] - for {set i 0} {$i < 25} {incr i} { - lappend commands [list help [list sub word$i singleopts {any}]] - } - ############################################################################################ - - #todo -noexit flag - - - #echo raw args to diverted stderr before running the argument analysis - puts -nonewline stderr "exe:[info nameofexecutable] script:[info script] shellspy-rawargs: $::argv\n" - set i 1 - foreach a $::argv { - puts -nonewline stderr "arg$i: '$a'\n" - incr i - } - - - set argdefinitions [list \ - -caller punkshell_dispatcher \ - -debugargs 0 \ - -debugargsonerror 2 \ - -return all \ - -soloflags {} \ - -defaults [list] \ - -required {none} \ - -extras {all} \ - -commandprocessors $commands \ - -values $::argv ] - - - set is_call_error 0 - set arglist [list] ;#processed args result - contains dispatch info etc. - if {[catch { - set arglist [check_flags {*}$argdefinitions] - } callError]} { - puts -nonewline stderr "|shellspy-stderr> ERROR during command dispatch\n" - puts -nonewline stderr "|shellspy-stderr> $callError\n" - puts -nonewline stderr "|shellspy-stderr> [set ::errorInfo]\n" - - shellfilter::log::write $shellspy_status_log "check_flags error: $callError" - set is_call_error 1 - } else { - shellfilter::log::write $shellspy_status_log "check_flags result: $arglist" - } - - shellfilter::log::write $shellspy_status_log "check_flags dispatch -done- [clock_sec]" - - #puts stdout "sp2. $::argv" - - if {[catch { - set tidyinfo [shellfilter::logtidyup] - } errMsg]} { - - shellfilter::log::open shellspy-error {-tag shellspy-error -syslog $error_syslog_server} - shellfilter::log::write shellspy-error "logtidyup error $errMsg\n [set ::errorInfo]" - after 200 - } - #don't open more logs.. - #puts stdout ">$tidyinfo" - - #lassign [shellfilter::redir_output_to_log "SUPPRESS"] id_stdout_redir id_stderr_redir - catch { - shellfilter::stack::remove stderr $chanstack_stderr_redir - shellfilter::stack::remove stdout $chanstack_stdout_redir - } - - #shellfilter::log::write $shellspy_status_log "logtidyup -done- $tidyinfo" - - catch { - set errorlist [dict get $tidyinfo errors] - if {[llength $errorlist]} { - foreach err $errorlist { - puts -nonewline stderr "|shellspy-final> worker-error-set $err\n" - } - } - } - - #puts stdout "shellspy -done1-" - #flush stdout - - #shellfilter::log::write $shellspy_status_log "shellspy -done-" - - if {[catch { - shellfilter::logtidyup $shellspy_status_log - #puts stdout "shellspy logtidyup done" - #flush stdout - } errMsg]} { - puts stdout "shellspy logtidyup error $errMsg" - flush stdout - shellfilter::log::open shellspy-final {-tag shellspy-final -syslog $error_syslog_server} - shellfilter::log::write shellspy-final "FINAL logtidyup error $errMsg\n [set ::errorInfo]" - after 100 - } - #puts [shellfilter::stack::status shellspyout] - #puts [shellfilter::stack::status shellspyerr] - - #sample dispatch member of $arglist - #dispatch { - # tclscript { - # command {shellspy::do_script %matched% no_repl} - # matched stdout.tcl arguments {} raw {} dispatchtype raw - # asdispatched {shellspy::do_script stdout.tcl no_repl} - # result {result {}} - # error {} - # } - #} - # or - #dispatch { - # tclscript { - # command xxx - # matched error.tcl arguments {} raw {} dispatchtype raw - # asdispatched {shellspy::do_script error.tcl no_repl} - # result { - # error {This is the error} - # errorCode NONE - # errorInfo This\ is\ the\ error\n\ etc - # } - # error {} - # } - #} - - - shellfilter::stack::delete shellspyout - shellfilter::stack::delete shellspyerr - set free_info [shellthread::manager::shutdown_free_threads] - #puts stdout $free_info - #flush stdout - if {[package provide zzzload] ne ""} { - #if zzzload used and not shutdown - we can get deadlock - #puts "zzzload::loader_tid [set ::zzzload::loader_tid]" - #zzzload::shutdown - } - #puts stdout "threads: [thread::names]" - #flush stdout - #puts stdout "calling release on remaining threads" - foreach tid [thread::names] { - thread::release $tid - } - #puts stdout "threads: [thread::names]" - #flush stdout - - - set colour ""; set reset "" - if {$is_call_error} { - catch { - set colour [punk::ansi::a+ yellow bold underline]; set reset [punk::ansi::a] - } - puts stderr $colour$callError$reset - flush stderr - exit 1 - } else { - if {[dict exists $arglist dispatch tclscript result errorInfo]} { - catch { - set colour [punk::ansi::a+ yellow bold]; set reset [punk::ansi::a] - } - set err [dict get $arglist dispatch tclscript result errorInfo] - if {$err ne ""} { - puts stderr $colour$err$reset - flush stderr - exit 1 - } - } - - foreach tclscript_flavour [list tclline punkline punkshellline tkline tkshellline libscript help] { - if {[dict exists $arglist dispatch $tclscript_flavour result error]} { - catch { - set colour [punk::ansi::a+ yellow bold]; set reset [punk::ansi::a] - } - set err [dict get $arglist dispatch $tclscript_flavour result error] - if {$err ne ""} { - puts stderr $colour$err$reset - flush stderr - exit 1 - } - } - } - } - - - if {[dict exists $arglist errorCode]} { - exit [dict get $arglist errorCode] - } - foreach tclscript_flavour [list tclline punkline punkshellline tkline tkshellline libscript help] { - if {[dict exists $arglist dispatch $tclscript_flavour result result]} { - puts -nonewline stdout [dict get $arglist dispatch $tclscript_flavour result result] - exit 0 - } - } - - #if we call exit - package require Tk script files will exit prematurely - #review - #exit 0 -} - -} +#! /usr/bin/env tclsh +# +#copyright 2023 Julian Marcel Noble +#license: BSD (revised 3-clause) +# +#see notes at beginning of shellspy namespace re stdout/stderr +# +#SHELLSPY - provides commandline flag information and stdout/stderr logging/mirroring without output/pipeline interference, +# or modified output if modifying filters explicitly configured. +# +#shellspy uses the shellfilter and flagfilter libraries to run a commandline with tee-diversions of stdout/stderr to configured syslog/file logs +#Because it is a tee, the command's stdout/stderr are still available as direct output from this script. +#Various filters/modifiers/redirections can be placed on the channel stacks for stdin/stderr using the shellfilter::stack api +# and other shellfilter:: helpers such as shellfilter::redir_output_to_log +# Redirecting stderr/stdout in this way prior to the actual command run will not interfere with the command/pipeline output due to the way +# shellfilter temporarily inserts it's own tee into the stack at the point of the highest existing redirection it encounters. +# +#A note on input/output convention regarding channels/pipes +# we write to an output, read from an input. +# e.g when creating a pipe with 'lassign [chan pipe] in out' we write to out and read from in. +# This is potentially confusing from an OO-like perspective thinking of a pipe object as a sort of object. +# Don't think of it from the perspective of the pipe - but from the program using it. +# This is not a convention invented here for shellspy - but it seems to match documentation and common use e.g for 'chan pending input|output chanid' +# This matches the way we write to stdout read from stdin. +# Possibly using read/write related naming for pipe ends is clearer. eg 'lassign [chan pipe] rd_pipe1 wr_pipe1' +# +package provide app-shellspy 1.0 + + +#experiment - todo make a flag for it if it's useful +#Middle cap for direct dispatch without flagcheck arg processing or redirections or REPL. +set arg1 [lindex $::argv 0] +if {[file extension $arg1] in [list .tCl]} { + set ::argv [lrange $::argv 1 end] + set ::argc [llength $::argv] + + set exedir [file dirname [info nameofexecutable]] + set binscripts [file join $exedir scriptlib] + if {[file exists $binscripts]} { + set libdir $binscripts + } else { + set libdir [file join [file dirname $exedir] scriptlib]] + } + set scriptname $arg1 + if {[string match lib:* $scriptname]} { + set scriptname [string range $scriptname 4 end] + set scriptname [string trimleft $scriptname :] ;#incase specified as lib:: + set scriptpath $libdir/$scriptname + } else { + set scriptpath $scriptname + } + set scriptpath [file normalize $scriptpath] + + if {![file exists $scriptpath]} { + #try the lowercase version (extension lowercased only) so that file doesn't have to be renamed to use alternate dispatch + set scriptpath [file rootname $scriptpath][string tolower [file extension $scriptpath]] + } + source $scriptpath + + #package require app-punk + +} else { + + + +#set m_dir [file join $starkit::topdir modules] + + +#catch {package require tcllibc} + +#review. we need thread for when configured to pump info to syslog etc - but it is overhead for simple script calls. +#todo - see if we can avoid loading in certain cases (based on punk::config?) +package require Thread + +package require flagfilter +package require shellfilter +package require punk::ansi +package require punk::packagepreference +punk::packagepreference::install + +#The whole punk infrastructure is overkill for calling arbitrary scripts +#package require punk + +#testing +#package require packageTrace + +set ::testconfig 5 + +namespace eval shellspy { + variable chanstack_stderr_redir + variable chanstack_stdout_redir + + variable commands + proc clock_sec {} { + return [expr {[clock millis]/1000.0}] + } + variable shellspy_status_log "shellspy-[clock micros]" + + #todo - default to no logging not even to local syslog + #load a .toml config which can configure logging as desired + set do_log 0 + if {$do_log} { + set debug_syslog_server 127.0.0.1:514 + #set debug_syslog_server 172.16.6.42:51500 + set error_syslog_server 127.0.0.1:514 + set data_syslog_server 127.0.0.1:514 + } else { + set debug_syslog_server "" + set error_syslog_server "" + set data_syslog_server "" + } + + + + + shellfilter::log::open $shellspy_status_log [list -tag $shellspy_status_log -syslog $debug_syslog_server -file ""] + shellfilter::log::write $shellspy_status_log "shellspy launch with args '$::argv'" + shellfilter::log::write $shellspy_status_log "stdout/stderr encoding: [chan configure stdout -encoding]/[chan configure stderr -encoding]" + + #------------------------------------------------------------------------- + ##don't write to stdout/stderr before you've redirected them to a log using shellfilter functions + ## puts to stdout/stderr will comingle with command's output if performed before the channel stacks are configured. + + chan configure stdin -buffering line + chan configure stdout -buffering none + chan configure stderr -buffering none + + #set id_ansistrip [shellfilter::stack::add stderr ansistrip -settings {}] + #set id_ansistrip [shellfilter::stack::add stdout ansistrip -settings {}] + + #redir on the shellfilter stack with no log or syslog specified acts to suppress output of stdout & stderr. + #todo - fix shellfilter code to make this noop more efficient (avoid creating corresponding logging thread and filter?) + #JMN + #set redirconfig {-settings {-syslog 127.0.0.1:514 -file ""}} + set redirconfig {} + lassign [shellfilter::redir_output_to_log "SUPPRESS" {*}$redirconfig] chanstack_stdout_redir chanstack_stderr_redir + shellfilter::log::write $shellspy_status_log "shellfilter::redir_output_to_log SUPPRESS DONE [clock_sec]" + + + ### + #we can now safely write to stderr/stdout and it will not interfere with stderr/stdout from the dispatched command. + #This is because when shellfilter::run is called it temporarily adds it's own filter in place of the redirection we just added. + # shellfilter::run installs tee_to_pipe on stdout & stderr with -action sink-aside. + # sink-aside means to sink down the filter stack to the topmost filter that is diversionary, and replace it. + # when the command finishes running, the redirecting filter that it displaced is reinstalled in the stack. + ### + + ### + #Note that futher filters installed here will sit 'above' any of the redirecting filters + # so apply to both the shellfilter::run commandline, + # as well as writes to stderr/stdout from here or other libraries operating in this process. + # To bypass the the filter-stack and still emit to syslog etc - + # you can use shellfilter::log::open and shellfilter::log::write e.g + # shellfilter::log::open "mystatuslog" [list -tag "mystatuslog" -syslog 172.16.6.42:51500 -file ""] + # shellfilter::log::write "mystatuslog" "shellspy launch" + # + #### + #set id_ansistrip [shellfilter::stack::add stderr ansistrip -action float -settings {}] + #set id_ansistrip [shellfilter::stack::add stdout ansistrip -action float -settings {}] + + + ##stdin stack operates in reverse compared to stdout/stderr in that first added to stack is first to see the data + ##for stdin: first added to stack is 'upstream' as it will always encounter the data before later ones added to the stack. + ##for stdout: first added to stack is 'downstream' as it will alays encounter the data after others on the stack + #shellfilter::stack::add stdin ansistrip -action {} -settings {} + #shellfilter::stack::add stdin tee_to_log -settings {-tag "input" -raw 1 -syslog 172.16.6.42:51500 -file ""} + + #------------------------------------------------------------------------- + ##note - to use shellfilter::stack::new - the fifo2 end at the local side requires the event loop to be running + ## for interactive testing a relatively simple repl.tcl can be used. + + #todo - default to no logging.. add special flag in checkflags to indicate end of options for matched command only e.g --- ? + # then prioritize these results from checkflags to configure pre-dispatch behaviour by running a predispatch script(?) + # + # we can log flag-processing info coming from checkflags.. but we don't want to do two opt scans and emit it twice. + # configuration of the logging for flag/opt parsing should come from a config file and default to none. + #set stdout_log [file normalize ~]/shellspy-stdout.txt + #set stderr_log [file normalize ~]/shellspy-stderr.txt + set stdout_log "" + set stderr_log "" + + shellfilter::log::write $shellspy_status_log "shellfilter::stack::new shellspyerr ABOUTTO [clock_sec]" + set errdeviceinfo [shellfilter::stack::new shellspyerr -settings [list -tag "shellspyerr" -buffering none -raw 1 -syslog $data_syslog_server -file $stderr_log]] + shellfilter::log::write $shellspy_status_log "shellfilter::stack::new shellspyerr DONE [clock_sec]" + + + shellfilter::log::write $shellspy_status_log "shellfilter::stack::new shellspyout ABOUTTO [clock_sec]" + set outdeviceinfo [shellfilter::stack::new shellspyout -settings [list -tag "shellspyout" -buffering none -raw 1 -syslog $data_syslog_server -file $stdout_log]] + set commandlog [dict get $outdeviceinfo localchan] + #puts $commandlog "HELLO $commandlog" + #flush $commandlog + shellfilter::log::write $shellspy_status_log "shellfilter::stack::new shellspyout DONE [clock_sec]" + + + + #note that this filter is inline with the data teed off to the shellspyout log. + #To filter the main stdout an addition to the stdout stack can be made. specify -action float to have it affect both stdout and the tee'd off data. + set id_ansistrip [shellfilter::stack::add shellspyout ansistrip -settings {}] + shellfilter::log::write $shellspy_status_log "shellfilter::stack::add shellspyout ansistrip DONE [clock_sec]" + + + #set id_out [shellfilter::stack::add stdout rebuffer -settings {}] + + #an example filter to capture some output to a var for later use - this one is for ansible-playbook + #set ::recap "" + #set id_tee_grep [shellfilter::stack::add shellspyout tee_grep_to_var -settings {-grep ".*PLAY RECAP.*|.*fatal:.*|.*changed:.*" -varname ::recap -pre 1 -post 3}] + + namespace import ::flagfilter::check_flags + + namespace eval shellspy::callbacks {} + namespace eval shellspy::parameters {} + + + proc do_callback {func args} { + variable shellspy_status_log + set exedir [file dirname [info nameofexecutable]] + set dispatchtcl [file join $exedir callbacks dispatch.tcl] + if {[file exists $dispatchtcl]} { + source $dispatchtcl + if {[llength [info commands shellspy::callbacks::$func]]} { + shellfilter::log::write $shellspy_status_log "found shellspy::callbacks::$func - calling" + if {[catch { + set args [shellspy::callbacks::$func {*}$args] + } errmsg]} { + shellfilter::log::write $shellspy_status_log "ERROR in shellspy::callbacks::$func\n errormsg:$errmsg" + error $errmsg + } + } + } + return $args + } + proc do_callback_parameters {func args} { + variable shellspy_status_log + set exedir [file dirname [info nameofexecutable]] + set paramtcl [file join $exedir callbacks parameters.tcl] + set params $args + if {[file exists $paramtcl]} { + source $paramtcl + if {[llength [info commands shellspy::parameters::$func]]} { + shellfilter::log::write $shellspy_status_log "found shellspy::parameters::$func - calling" + if {[catch { + set params [shellspy::parameters::$func $params] + } errmsg]} { + shellfilter::log::write $shellspy_status_log "ERROR in shellspy::parameters::$func\n errormsg:$errmsg" + } + } + } + return $params + } + + #some tested configs + proc get_channel_config {config} { + #note tcl script being called from wrong place.. configs don't affect: todo - move it. + set params [dict create] + switch -- $config { + 0 { + #bad for: everything. extra cr + dict set params -inbuffering line + dict set params -outbuffering line + dict set params -readprocesstranslation auto ;#default + dict set params -outtranslation auto + } + 1 { + #ok for: cmd, cmd/u/c,raw,pwsh, sh,raw, tcl script process + #not ok for: bash,wsl, tcl script + dict set params -inbuffering line + dict set params -outbuffering line + dict set params -readprocesstranslation auto ;#default + dict set params -outtranslation lf + } + 2 { + #ok for: cmd, cmd/uc,pwsh,sh , tcl script process + #not ok for: tcl script, bash, wsl + dict set params -inbuffering none ;#default + dict set params -outbuffering none ;#default + dict set params -readprocesstranslation auto ;#default + dict set params -outtranslation lf ;#default + } + 3 { + #ok for: cmd + dict set params -inbuffering line + dict set params -outbuffering line + dict set params -readprocesstranslation lf + dict set params -outtranslation lf + } + 4 { + #ok for: cmd,cmd/uc,raw,sh + #not ok for pwsh,bash,wsl, tcl script, tcl script process + dict set params -inbuffering none + dict set params -outbuffering none + dict set params -readprocesstranslation lf + dict set params -outtranslation lf + } + 5 { + #ok for: pwsh,cmd,cmd/u/c,raw,sh, tcl script process + #not ok for bash,wsl + #ok for vim cmd/u/c but only with to_unix filter on stdout (works in gvim and console) + dict set params -inbuffering none + dict set params -outbuffering none + dict set params -readprocesstranslation crlf + dict set params -outtranslation lf + } + 6 { + #ok for: cmd,cmd/u/c,pwsh,raw,sh,bash + #not ok for: vim with cmd /u/c (?) + dict set params -inbuffering line + dict set params -outbuffering line + dict set params -readprocesstranslation crlf + dict set params -outtranslation lf + } + 7 { + #ok for: sh,bash + #not ok for: wsl (display ok but extra cr), cmd,cmd/u/c,pwsh, tcl script, tcl script process, raw + dict set params -inbuffering none + dict set params -outbuffering none + dict set params -readprocesstranslation crlf + dict set params -outtranslation crlf + } + 8 { + #not ok for anything..all have extra cr + dict set params -inbuffering none + dict set params -outbuffering none + dict set params -readprocesstranslation lf + dict set params -outtranslation crlf + } + } + return $params + } + + proc do_help {args} { + #return [dict create result $::shellspy::commands] + set result "" + foreach cmd $::shellspy::commands { + lassign $cmd tag cmdinfo + if {[lindex $cmdinfo 0] eq "sub"} { + continue + } + if {[dict exists $cmdinfo match]} { + append result "$tag [dict get $cmdinfo match]" \n + } + } + return [dict create result $result] + } + + + #punk86 -tk example: + # punk86 -tk eval "button .tk.b -text doit -command {set ::punkapp::result(shell) guiresult;punkapp::close_window .tk}; pack .tk.b;return somedefaultvalue" + proc do_tclline {flavour args} { + variable chanstack_stderr_redir + variable chanstack_stdout_redir + + if {$flavour in [list "punk" "punkshell"]} { + namespace eval :: {package require punk;package require shellrun} + } elseif {$flavour in [list "tk" "tkshell"]} { + namespace eval :: { + package require Tk + package require punkapp + punkapp::hide_dot_window + toplevel .tk + if {[wm protocol . WM_DELETE_WINDOW] eq ""} { + wm protocol . WM_DELETE_WINDOW [list punkapp::close_window .] + } + wm protocol .tk WM_DELETE_WINDOW [list punkapp::close_window .tk] + } + } + #remove SUPPRESS redirection if it was in place so that shell output is visible + catch { + shellfilter::stack::remove stderr $chanstack_stderr_redir + shellfilter::stack::remove stdout $chanstack_stdout_redir + } + set result_is_error 0 + if {[catch {apply [list {arglist} {namespace eval :: $arglist} ::] $args} result]} { + set result_is_error 1 + } + if {$flavour in [list "punkshell" "tkshell"]} { + set result [namespace eval :: [string map [list %e% $chanstack_stderr_redir %o% $chanstack_stdout_redir %r% $result] { + package require punk + package require shellrun + package require punk::repl + puts stdout "quit to exit" + repl::init -safe 0 + repl::start stdin -defaultresult %r% + }]] + } + + #todo - better exit? + if {$result_is_error} { + if {$flavour eq "tk"} { + return [dict create error [namespace eval :: [list punkapp::wait -defaultresult $result]]] + #todo - better return value e.g from dialog? + } + return [dict create error $result] + } else { + if {$flavour eq "tk"} { + return [dict create result [namespace eval :: [list punkapp::wait -defaultresult $result]]] + #todo - better return value e.g from dialog? + } + return [dict create result $result] + } + } + proc set_punkd {args} { + variable shellspy_status_log + shellfilter::log::write $shellspy_status_log "set_punkd got '$args'" + + set punkd_status_log "set_punkd_log" + shellfilter::log::open $punkd_status_log [list -tag $punkd_status_log -syslog 127.0.0.1:514 -file ""] + shellfilter::log::write $punkd_status_log "set_punkd got '$args'" + return [dict create result ok] + } + + proc do_in_powershell {args} { + variable shellspy_status_log + shellfilter::log::write $shellspy_status_log "do_in_powershell got '$args'" + set args [do_callback powershell {*}$args] + set params [do_callback_parameters powershell] + dict set params -teehandle shellspy + + + #readprocesstranslation lf - doesn't work for buffering line or none + #readprocesstranslation crlf works for buffering line and none with outchantranslation lf + + set params [dict merge $params [get_channel_config $::testconfig]] ;#working: 5 unbuffered, 6 linebuffered + + + dict set params -debug 1 + dict set params -timeout 1000 + + #set exitinfo [shellfilter::run [list pwsh -nologo -noprofile -c {*}$args] -debug 1] + + + set id_err [shellfilter::stack::add stderr ansiwrap -action sink -settings {-colour {red bold}}] + set exitinfo [shellfilter::run [list pwsh -nologo -noprofile -c {*}$args] {*}$params] + shellfilter::stack::remove stderr $id_err + + #Passing args in as a single element will tend to make powershell treat the args as a 'script block' + # (powershell sees items in curly brackets {} as a scriptblock - when called from non-powershell, this tends to just echo back the contents) + #set exitinfo [shellfilter::run [list pwsh -nologo -noprofile -c $args] {*}$params] + if {[lindex $exitinfo 0] eq "exitcode"} { + shellfilter::log::write $shellspy_status_log "do_in_powershell returning $exitinfo" + #exit [lindex $exitinfo 1] + } + return $exitinfo + } + proc do_in_powershell_terminal {args} { + variable shellspy_status_log + shellfilter::log::write $shellspy_status_log "do_in_powershell_terminal got '$args'" + set args [do_callback powershell {*}$args] + set params [do_callback_parameters powershell] + dict set params -teehandle shellspy + set params [dict merge $params [get_channel_config $::testconfig]] ;#working: 5 unbuffered, 6 linebuffered + + #set cmdlist [list pwsh -nologo -noprofile -c {*}$args] + set cmdlist [list pwsh -nologo -c {*}$args] + #the big problem with using the 'script' command is that we get stderr/stdout mashed together. + + #set cmdlist [shellfilter::get_scriptrun_from_cmdlist_dquote_if_not $cmdlist] + shellfilter::log::write $shellspy_status_log "do_in_powershell_terminal as script: '$cmdlist'" + + set id_err [shellfilter::stack::add stderr ansiwrap -action sink -settings {-colour {red bold}}] + set exitinfo [shellfilter::run $cmdlist {*}$params] + shellfilter::stack::remove stderr $id_err + + if {[lindex $exitinfo 0] eq "exitcode"} { + shellfilter::log::write $shellspy_status_log "do_in_powershell_terminal returning $exitinfo" + } + return $exitinfo + } + + + proc do_in_cmdshell {args} { + variable shellspy_status_log + shellfilter::log::write $shellspy_status_log "do_in_cmdshell got '$args'" + set args [do_callback cmdshell {*}$args] + set params [do_callback_parameters cmdshell] + + + dict set params -teehandle shellspy + dict set params -copytempfile 1 + + set params [dict merge $params [get_channel_config $::testconfig]] + + #set id_out [shellfilter::stack::add stdout tounix -action sink-locked -settings {}] + set id_err [shellfilter::stack::add stderr ansiwrap -action sink-locked -settings {-colour {red bold}}] + + #set exitinfo [shellfilter::run "cmd /c $args" -debug 1] + set exitinfo [shellfilter::run [list cmd /c {*}$args] {*}$params] + #set exitinfo [shellfilter::run [list cmd /c {*}$args] -debug 1] + + shellfilter::stack::remove stderr $id_err + + #shellfilter::stack::remove stdout $id_out + + shellfilter::log::write $shellspy_status_log "do_in_cmdshell raw exitinfo: $exitinfo" + + + if {[lindex $exitinfo 0] eq "exitcode"} { + #exit [lindex $exitinfo 1] + #shellfilter::log::write $shellspy_status_log "do_in_cmdshell returning $exitinfo" + #puts stderr "do_in_cmdshell returning $exitinfo" + } + return $exitinfo + } + proc do_in_cmdshellb {args} { + + variable shellspy_status_log + shellfilter::log::write $shellspy_status_log "do_in_cmdshellb got '$args'" + + set args [do_callback cmdshellb {*}$args] + + + shellfilter::log::write $shellspy_status_log "do_in_cmdshellb post_callback args '$args'" + + set params [do_callback_parameters cmdshellb] + dict set params -teehandle shellspy + dict set params -copytempfile 1 + dict set params -debug 0 + + #----------------------------- + #channel config 6 and towindows sink-aside-locked {-junction 1} works with vim-flog + #----------------------------- + set params [dict merge $params [get_channel_config 6]] + #set id_out [shellfilter::stack::add stdout tounix -action sink-aside-locked -junction 1 -settings {}] + + + set exitinfo [shellfilter::run [list cmd /u/c {*}$args] {*}$params] + + #shellfilter::stack::remove stdout $id_out + + if {[lindex $exitinfo 0] eq "exitcode"} { + shellfilter::log::write $shellspy_status_log "do_in_cmdshellb returning with exitcode $exitinfo" + } else { + shellfilter::log::write $shellspy_status_log "do_in_cmdshellb returning WITHOUT exitcode $exitinfo" + } + return $exitinfo + } + proc do_in_cmdshelluc {args} { + variable shellspy_status_log + shellfilter::log::write $shellspy_status_log "do_in_cmdshelluc got '$args'" + set args [do_callback cmdshelluc {*}$args] + set params [do_callback_parameters cmdshell] + #set exitinfo [shellfilter::run "cmd /c $args" -debug 1] + dict set params -teehandle shellspy + dict set params -copytempfile 1 + dict set params -debug 0 + + #set params [dict merge $params [get_channel_config $::testconfig]] + + set params [dict merge $params [get_channel_config 1]] + #set id_out [shellfilter::stack::add stdout tounix -action sink-locked -settings {}] + + set id_out [shellfilter::stack::add stdout tounix -action sink-locked -settings {}] + + set exitinfo [shellfilter::run [list cmd /u/c {*}$args] {*}$params] + shellfilter::stack::remove stdout $id_out + #chan configure stdout -translation crlf + + if {[lindex $exitinfo 0] eq "exitcode"} { + #exit [lindex $exitinfo 1] + shellfilter::log::write $shellspy_status_log "do_in_cmdshelluc returning $exitinfo" + #puts stderr "do_in_cmdshell returning $exitinfo" + } + return $exitinfo + } + proc do_raw {args} { + variable shellspy_status_log + shellfilter::log::write $shellspy_status_log "do_raw got '$args'" + set args [do_callback raw {*}$args] + set params [do_callback_parameters raw] + #set params {} + dict set params -debug 0 + #dict set params -outprefix "_test_" + dict set params -teehandle shellspy + + + set params [dict merge $params [get_channel_config $::testconfig]] + + + if {[llength $params]} { + set exitinfo [shellfilter::run $args {*}$params] + } else { + set exitinfo [shellfilter::run $args -debug 1 -outprefix "j"] + } + if {[lindex $exitinfo 0] eq "exitcode"} { + shellfilter::log::write $shellspy_status_log "do_raw returning $exitinfo" + } + return $exitinfo + } + + proc do_script_process {scriptbin scriptname args} { + variable shellspy_status_log + if {$scriptbin eq "withinterp.word0"} { + set scriptbin $scriptname + set scriptname [lindex $args 0] + set args [lrange $args 1 end] + } + shellfilter::log::write $shellspy_status_log "do_script_process got scriptname:'$scriptname' args:'$args'" + #no script_process callbacks + #set args [do_callback script_process {*}$args] + #set params [do_callback_parameters script_process] + dict set params -teehandle shellspy + + set params [dict merge $params [get_channel_config $::testconfig]] + + set exedir [file dirname [info nameofexecutable]] + if {[file exists $exedir/scriptlib]} { + set libroot $exedir/scriptlib + } else { + set libroot [file dirname $exedir]/scriptlib + } + if {[string match lib:* $scriptname]} { + set scriptname [string range $scriptname 4 end] + set scriptname [string trimleft $scriptname :] ;#incase specified as lib:: + set scriptpath $libroot/$scriptname + } else { + set scriptpath $scriptname + } + set scriptpath [file normalize $scriptpath] + if {![file exists $scriptpath]} { + if {[file extension $scriptpath] eq ""} { + set scriptpath $scriptpath.tcl + } else { + set scriptpath [file rootname $scriptpath][string tolower [file extension $scriptpath]] + } + if {![file exists $scriptpath]} { + puts stderr "Failed to find script: '$scriptpath'" + error "bad scriptpath '$scriptpath' arguments: $scriptbin $scriptname $args" + } + } + + + + #set id_err [shellfilter::stack::add stderr ansiwrap -action sink-locked -settings {-colour {red bold}}] + + + + #todo - use glob to check capitalisation of file tail (.TCL vs .tcl .Tcl etc) + set exitinfo [shellfilter::run [concat [auto_execok $scriptbin] $scriptpath $args] {*}$params] + shellfilter::log::write $shellspy_status_log "do_script_process exitinfo: $exitinfo" + + #shellfilter::stack::remove stderr $id_err + + #if {[lindex $exitinfo 0] eq "exitcode"} { + # shellfilter::log::write $shellspy_status_log "do_script_process returning $exitinfo" + #} + #if {[dict exists $exitinfo errorCode]} { + # exit [dict get $exitinfo $errorCode] + #} + return $exitinfo + } + + proc do_tclkit {kitname replwhen args} { + puts stderr "app-shellspy: do_tclkit $kitname $replwhen $args" + flush stderr + + set script [string map [list %a% $args %k% $kitname] { +#::tcl::tm::add %m% +set kit %k% +set kitpath [file normalize $kit] +set kitmount $kitpath.0 + +#save values +set prevscript [info script] +set prevglobal [dict create] +foreach g [list ::argv ::argc ::argv0] { + if {[info exists $g]} { + dict set prevglobal $g [set $g] + } +} + +#setup and run +set ::argv [list %a%] +set ::argc [llength $::argv] + +set ::argv0 $kitmount +#puts stderr "setting 'info script' $kitmount/main.tcl" +info script $kitmount/main.tcl +#info script dir must match argv0 for kit main.tcl to return 'starkit' from 'starkit::startup' + +if {![catch { + package require vfs + package require vfs::mk4 + } errMsg]} { + + vfs::mk4::Mount $kitpath $kitmount + lappend ::auto_path $kitmount/lib + if {[file exists "$kitmount/modules"]} { + tcl::tm::add "$kitmount/modules" + } + + #puts stderr "sourcing $kitmount/main.tcl" + #puts stderr "$kitmount/main.tcl exists: [file exists $kitmount/main.tcl]" + #puts stderr "argv : $::argv" + #puts stderr "argv0: $::argv0" + #puts stderr "autopath: $::auto_path" + #puts stdout "starkit::startup [starkit::startup]" + + #usually main.tcl will just be something like: package require app-XXX + #it will usually do nothing if starkit::startup returned 'sourced' + + source $kitmount/main.tcl + +} else { + puts stderr "Unable to load vfs::mk4 for tclkit mounting" +} +#restore values +info script $prevscript +dict with prevglobal {} + }] + + set repl_lines "" + append repl_lines {package require punk::repl} \n + append repl_lines {repl::init -safe 0} \n + append repl_lines {repl::start stdin} \n + + #test + #set replwhen "repl_last" + + if {$replwhen eq "repl_first"} { + #we need to cooperate with the repl to get the script to run on exit + namespace eval ::repl {} + set ::repl::post_script $script + set script "$repl_lines" + } elseif {$replwhen eq "repl_last"} { + append script $repl_lines + } else { + #just the script + } + + dict set params -tclscript 1 ;#don't give callback a chance to omit/break this + dict set params -teehandle shellspy + + + set params [dict merge $params [get_channel_config $::testconfig]] + + set id_err [shellfilter::stack::add stderr ansiwrap -action sink-locked -settings {-colour {red bold}}] + + set exitinfo [shellfilter::run $script {*}$params] + + shellfilter::stack::remove stderr $id_err + + if {[dict exists $exitinfo errorInfo]} { + #strip out the irrelevant info from the errorInfo - we don't want info beyond 'invoked from within' as this is just plumbing related to the script sourcing + set stacktrace [string map [list \r\n \n] [dict get $exitinfo errorInfo]] + set output "" + set tracelines [split $stacktrace \n] + foreach ln $tracelines { + if {[string match "*invoked from within*" $ln]} { + break + } + append output $ln \n + } + set output [string trimright $output \n] + dict set exitinfo errorInfo $output + } + return $exitinfo + } + + proc do_script {scriptname replwhen args} { + #ideally we don't want to launch an external process to run the script + variable shellspy_status_log + #shellfilter::log::write $shellspy_status_log "do_script got scriptname:'$scriptname' replwhen:$replwhen args:'$args'" + set exepath [file dirname [file join [info nameofexecutable] __dummy__]] + set exedir [file dirname $exepath] + + if {[file tail $exedir] eq "bin"} { + set basedir [file dirname $exedir] + } else { + set basedir $exedir + } + set libroot [file join $basedir scriptlib] + if {[string match lib:* $scriptname]} { + set scriptname [string range $scriptname 4 end] + set scriptname [string trimleft $scriptname :] ;#incase specified as lib:: + set scriptpath $libroot/$scriptname + } else { + set scriptpath $scriptname + } + set scriptpath [file normalize $scriptpath] + if {![file exists $scriptpath]} { + if {[file extension $scriptpath] eq ""} { + set scriptpath $scriptpath.tcl + } else { + set scriptpath [file rootname $scriptpath][string tolower [file extension $scriptpath]] + } + if {![file exists $scriptpath]} { + puts stderr "Failed to find script: '$scriptpath'" + error "bad scriptpath '$scriptpath'" + } + } + set modulesdir $basedir/modules + + set script [string map [list %a% $args %s% $scriptpath %m% $modulesdir] { +#::tcl::tm::add %m% +set scriptname %s% +set normscript [file normalize $scriptname] + +#save values +set prevscript [info script] +set prevglobal [dict create] +foreach g [list ::argv ::argc ::argv0] { + if {[info exists $g]} { + dict set prevglobal $g [set $g] + } +} + +#setup and run +set ::argv [list %a%] +set ::argc [llength $::argv] +set ::argv0 $normscript +info script $normscript +source $normscript + +#restore values +info script $prevscript +dict with prevglobal {} + }] + + set repl_lines "" + #append repl_lines {puts stderr "starting repl [chan names]"} \n + #append repl_lines {puts stderr "stdin [chan configure stdin]"} \n + append repl_lines {package require punk::repl} \n + append repl_lines {repl::init -safe 0} \n + append repl_lines {repl::start stdin} \n + + #append repl_lines {puts stdout "shutdown message"} \n + + if {$replwhen eq "repl_first"} { + #we need to cooperate with the repl to get the script to run on exit + namespace eval ::repl {} + set ::repl::post_script $script + set script "$repl_lines" + } elseif {$replwhen eq "repl_last"} { + append script $repl_lines + } else { + #just the script + } + + #no script callbacks + #set args [do_callback script {*}$args] + #set params [do_callback_parameters script] + + dict set params -tclscript 1 ;#don't give callback a chance to omit/break this + dict set params -teehandle shellspy + #dict set params -teehandle punksh + + + set params [dict merge $params [get_channel_config $::testconfig]] + + set id_err [shellfilter::stack::add stderr ansiwrap -action sink-locked -settings {-colour {red bold}}] + + set exitinfo [shellfilter::run $script {*}$params] + + shellfilter::stack::remove stderr $id_err + + #if {[lindex $exitinfo 0] eq "exitcode"} { + # shellfilter::log::write $shellspy_status_log "do_script returning $exitinfo" + #} + + #jjj + #shellfilter::log::write $shellspy_status_log "do_script raw exitinfo: $exitinfo" + if {[dict exists $exitinfo errorInfo]} { + #strip out the irrelevant info from the errorInfo - we don't want info beyond 'invoked from within' as this is just plumbing related to the script sourcing + set stacktrace [string map [list \r\n \n] [dict get $exitinfo errorInfo]] + set output "" + set tracelines [split $stacktrace \n] + foreach ln $tracelines { + if {[string match "*invoked from within*" $ln]} { + break + } + append output $ln \n + } + set output [string trimright $output \n] + dict set exitinfo errorInfo $output + #jjj + #shellfilter::log::write $shellspy_status_log "do_script simplified exitinfo: $exitinfo" + } + return $exitinfo + } + + proc shellescape {arglist} { + set out [list] + foreach a $arglist { + set a [string map [list \\ \\\\ ] $a] + lappend out $a + } + return $out + } + proc do_shell {shell args} { + variable shellspy_status_log + shellfilter::log::write $shellspy_status_log "do_shell $shell got '$args' [llength $args]" + set args [do_callback $shell {*}$args] + shellfilter::log::write $shellspy_status_log "do_shell $shell xgot '$args'" + set params [do_callback_parameters $shell] + dict set params -teehandle shellspy + + + set params [dict merge $params [get_channel_config $::testconfig]] + + set id_out [shellfilter::stack::add stdout towindows -action sink-aside-locked -junction 1 -settings {}] + + #shells that take -c and need all args passed together as a string + + set exitinfo [shellfilter::run [concat $shell -c [shellescape $args]] {*}$params] + + shellfilter::stack::remove stdout $id_out + + + if {[lindex $exitinfo 0] eq "exitcode"} { + shellfilter::log::write $shellspy_status_log "do_shell $shell returning $exitinfo" + } + return $exitinfo + } + proc do_wsl {distdefault args} { + variable shellspy_status_log + shellfilter::log::write $shellspy_status_log "do_wsl $distdefault got '$args' [llength $args]" + set args [do_callback wsl {*}$args] ;#use dist? + shellfilter::log::write $shellspy_status_log "do_wsl $distdefault xgot '$args'" + set params [do_callback_parameters wsl] + + dict set params -debug 0 + + set params [dict merge $params [get_channel_config $::testconfig]] + + set id_out [shellfilter::stack::add stdout towindows -action sink-aside-locked -junction 1 -settings {}] + + dict set params -teehandle shellspy ;#shellspyout shellspyerr must exist + set exitinfo [shellfilter::run [concat wsl -d $distdefault -e [shellescape $args]] {*}$params] + + + shellfilter::stack::remove stdout $id_out + + + if {[lindex $exitinfo 0] eq "exitcode"} { + shellfilter::log::write $shellspy_status_log "do_wsl $distdefault returning $exitinfo" + } + return $exitinfo + } + + #todo - load these from a callback + set commands [list] + lappend commands [list punkd [list match [list punkd] dispatch [list shellspy::set_punkd] dispatchtype raw dispatchglobal 1 singleopts {any}]] + lappend commands [list punkd [list sub punkdict singleopts {any}]] + + + #'shout' extension (all uppercase) to force use of tclsh as a separate process + #todo - detect various extensions - and use all script-preceding unmatched args as interpreter+options + #e.g perl,php,python etc. + #For tcl will make it easy to test different interpreter output from tclkitsh, tclsh8.6, tclsh8.7 etc + #for now we have a hardcoded default interpreter for tcl as 'tclsh' - todo: get default interps from config + #(or just attempt launch in case there is shebang line in script) + #we may get ambiguity with existing shell match-specs such as -c /c -r. todo - only match those in first slot? + lappend commands [list tclscriptprocess [list match [list {.*\.TCL$} {.*\.TM$} {.*\.TK$}] dispatch [list shellspy::do_script_process [info nameofexecutable] %matched%] dispatchtype raw dispatchglobal 1 singleopts {any}]] + for {set i 0} {$i < 25} {incr i} { + lappend commands [list tclscriptprocess [list sub word$i singleopts {any}]] + } + + #camelcase convention .Tcl script before repl + lappend commands [list tclscriptbeforerepl [list match [list {.*\.Tcl$} {.*\.Tm$} {.*\.Tk$} ] dispatch [list shellspy::do_script %matched% "repl_last"] dispatchtype raw dispatchglobal 1 singleopts {any}]] + for {set i 0} {$i < 25} {incr i} { + lappend commands [list tclscriptbeforerepl [list sub word$i singleopts {any}]] + } + + + #Backwards Camelcase convention .tcL - means repl first, script last + lappend commands [list tclscriptafterrepl [list match [list {.*\.tcL$} {.*\.tM$} {.*\.tK$} ] dispatch [list shellspy::do_script %matched% "repl_first"] dispatchtype raw dispatchglobal 1 singleopts {any}]] + for {set i 0} {$i < 25} {incr i} { + lappend commands [list tclscriptafterrepl [list sub word$i singleopts {any}]] + } + + + #we've already handled .Tcl .tcL, .tCl, .TCL - handle any other capitalisations as a script in this process + lappend commands [list tclscript [list match [list {.*\.tcl$} {.*\.tCL$} {.*\.TCl$} {.*\.tm$} {.*\.tk$} ] dispatch [list shellspy::do_script %matched% "no_repl"] dispatchtype raw dispatchglobal 1 singleopts {any}]] + for {set i 0} {$i < 25} {incr i} { + lappend commands [list tclscript [list sub word$i singleopts {any}]] + } + + lappend commands [list tclkit [list match [list {.*\.kit$}] dispatch [list shellspy::do_tclkit %matched% "no_repl"] dispatchtype raw dispatchglobal 1 singleopts {any}]] + for {set i 0} {$i < 25} {incr i} { + lappend commands [list tclkit [list sub word$i singleopts {any}]] + } + + #%argN% and %argtakeN% can be used as well as %matched% - %argtakeN% will remove from raw and arguments elements of dispatchrecord + lappend commands [list withinterp [list match {^withinterp$} dispatch [list shellspy::do_script_process %argtake0% %argtake1%] dispatchtype raw dispatchglobal 1 singleopts {any} longopts {any} pairopts {any}]] + for {set i 0} {$i < 25} {incr i} { + lappend commands [list withinterp [list sub word$i singleopts {any} longopts {any} pairopts {any}]] + } + + lappend commands [list runcmdfile [list match [list {.*\.cmd$} {.*\.bat$} ] dispatch [list shellspy::do_in_cmdshell %matched%] dispatchtype raw dispatchglobal 1 singleopts {any} longopts {any}]] + for {set i 0} {$i < 25} {incr i} { + lappend commands [list runcmdfile [list sub word$i singleopts {any}]] + } + + lappend commands [list libscript [list match [list {lib:.*$} ] dispatch [list shellspy::do_script %matched% "no_repl"] dispatchtype raw dispatchglobal 1 singleopts {any}]] + for {set i 0} {$i < 25} {incr i} { + lappend commands [list libscript [list sub word$i singleopts {any}]] + } + + lappend commands [list luascriptprocess [list match [list {.*\.lua|Lua|LUA$}] dispatch [list shellspy::do_script_process lua %matched% "no_repl"] dispatchtype raw dispatchglobal 1 singleopts {any}]] + for {set i 0} {$i < 25} {incr i} { + lappend commands [list luascriptprocess [list sub word$i singleopts {any}]] + } + + lappend commands [list phpscriptprocess [list match [list {.*\.php|Php|PHP$}] dispatch [list shellspy::do_script_process php %matched% "no_repl"] dispatchtype raw dispatchglobal 1 singleopts {any}]] + for {set i 0} {$i < 25} {incr i} { + lappend commands [list phpscriptprocess [list sub word$i singleopts {any}]] + } + + lappend commands [list bashraw [list match {^bash$} dispatch [list shellspy::do_shell bash] dispatchtype raw dispatchglobal 1 singleopts {any}]] + for {set i 0} {$i < 25} {incr i} { + lappend commands [list bashraw [list sub word$i singleopts {any}]] + } + lappend commands [list runbash [list match {^shellbash$} dispatch [list shellspy::do_shell bash] dispatchtype shell dispatchglobal 1 singleopts {any}]] + for {set i 0} {$i < 25} {incr i} { + lappend commands [list runbash [list sub word$i singleopts {any}]] + } + + lappend commands {shraw {match {^sh$} dispatch {shellspy::do_shell sh} dispatchtype raw dispatchglobal 1 singleopts {any}}} + for {set i 0} {$i < 25} {incr i} { + lappend commands [list shraw [list sub word$i singleopts {any}]] + } + + lappend commands {runsh {match {^s$} dispatch {shellspy::do_shell sh} dispatchtype shell dispatchglobal 1 singleopts {any}}} + for {set i 0} {$i < 25} {incr i} { + lappend commands [list runsh [list sub word$i singleopts {any}]] + } + + lappend commands {runraw {match {^-r$} dispatch shellspy::do_raw dispatchtype raw dispatchglobal 1 singleopts {any}}} + for {set i 0} {$i < 25} {incr i} { + lappend commands [list runraw [list sub word$i singleopts {any}]] + } + lappend commands {runpwsh {match {^-c$} dispatch shellspy::do_in_powershell dispatchtype raw dispatchglobal 1 singleopts {any}}} + for {set i 0} {$i < 25} {incr i} { + lappend commands [list runpwsh [list sub word$i singleopts {any}]] + } + lappend commands {runpwsht {match {^pwsh$} dispatch shellspy::do_in_powershell_terminal dispatchtype raw dispatchglobal 1 singleopts {any}}} + for {set i 0} {$i < 25} {incr i} { + lappend commands [list runpwsht [list sub word$i singleopts {any}]] + } + + + lappend commands {runcmd {match {^/c$} dispatch shellspy::do_in_cmdshell dispatchtype raw dispatchglobal 1 singleopts {any} longopts {any}}} + for {set i 0} {$i < 25} {incr i} { + lappend commands [list runcmd [list sub word$i singleopts {any}]] + } + lappend commands {runcmduc {match {^/u/c$} dispatch shellspy::do_in_cmdshelluc dispatchtype raw dispatchglobal 1 singleopts {any} longopts {any}}} + for {set i 0} {$i < 25} {incr i} { + lappend commands [list runcmduc [list sub word$i singleopts {any}]] + } + #cmd with bracketed args () e.g with vim shellxquote set to "(" + lappend commands [list runcmdb [list match {^cmdb$} dispatch [list shellspy::do_in_cmdshellb] dispatchtype raw dispatchglobal 1 singleopts {any} longopts {any} pairopts {any}]] + for {set i 0} {$i < 25} {incr i} { + lappend commands [list runcmdb [list sub word$i singleopts {any} longopts {any} pairopts {any}]] + } + + lappend commands [list wslraw [list match {^wsl$} dispatch [list shellspy::do_wsl AlmaLinux9] dispatchtype raw dispatchglobal 1 singleopts {any} longopts {any}]] + for {set i 0} {$i < 25} {incr i} { + lappend commands [list wslraw [list sub word$i singleopts {any}]] + } + + #e.g + # punk -tcl info patch + # punk -tcl eval "package require punk::char;punk::char::charset_page dingbats" + + lappend commands [list tclline [list match [list {^-tcl$}] dispatch [list shellspy::do_tclline tcl] dispatchtype raw dispatchglobal 1 singleopts {any} longopts {any}]] + for {set i 0} {$i < 25} {incr i} { + lappend commands [list tclline [list sub word$i singleopts {any}]] + } + lappend commands [list punkline [list match {^-punk$} dispatch [list shellspy::do_tclline punk] dispatchtype raw dispatchglobal 1 singleopts {any} longopts {any}]] + for {set i 0} {$i < 25} {incr i} { + lappend commands [list punkline [list sub word$i singleopts {any}]] + } + lappend commands [list tkline [list match {^-tk$} dispatch [list shellspy::do_tclline tk] dispatchtype raw dispatchglobal 1 singleopts {any} longopts {any}]] + for {set i 0} {$i < 25} {incr i} { + lappend commands [list tkline [list sub word$i singleopts {any}]] + } + lappend commands [list tkshellline [list match {^-tkshell$} dispatch [list shellspy::do_tclline tkshell] dispatchtype raw dispatchglobal 1 singleopts {any} longopts {any}]] + for {set i 0} {$i < 25} {incr i} { + lappend commands [list tkshellline [list sub word$i singleopts {any}]] + } + lappend commands [list punkshellline [list match {^-punkshell$} dispatch [list shellspy::do_tclline punkshell] dispatchtype raw dispatchglobal 1 singleopts {any} longopts {any}]] + for {set i 0} {$i < 25} {incr i} { + lappend commands [list punkshellline [list sub word$i singleopts {any}]] + } + + + lappend commands [list help [list match [list {^-help$} {^--help$} {^help$} {^/\?}] dispatch [list shellspy::do_help] dispatchtype raw dispatchglobal 1 singleopts {any} longopts {any}]] + for {set i 0} {$i < 25} {incr i} { + lappend commands [list help [list sub word$i singleopts {any}]] + } + ############################################################################################ + + #todo -noexit flag + + + #echo raw args to diverted stderr before running the argument analysis + puts -nonewline stderr "exe:[info nameofexecutable] script:[info script] shellspy-rawargs: $::argv\n" + set i 1 + foreach a $::argv { + puts -nonewline stderr "arg$i: '$a'\n" + incr i + } + + + set argdefinitions [list \ + -caller punkshell_dispatcher \ + -debugargs 0 \ + -debugargsonerror 2 \ + -return all \ + -soloflags {} \ + -defaults [list] \ + -required {none} \ + -extras {all} \ + -commandprocessors $commands \ + -values $::argv ] + + + set is_call_error 0 + set arglist [list] ;#processed args result - contains dispatch info etc. + if {[catch { + set arglist [check_flags {*}$argdefinitions] + } callError]} { + puts -nonewline stderr "|shellspy-stderr> ERROR during command dispatch\n" + puts -nonewline stderr "|shellspy-stderr> $callError\n" + puts -nonewline stderr "|shellspy-stderr> [set ::errorInfo]\n" + + shellfilter::log::write $shellspy_status_log "check_flags error: $callError" + set is_call_error 1 + } else { + shellfilter::log::write $shellspy_status_log "check_flags result: $arglist" + } + + shellfilter::log::write $shellspy_status_log "check_flags dispatch -done- [clock_sec]" + + #puts stdout "sp2. $::argv" + + if {[catch { + set tidyinfo [shellfilter::logtidyup] + } errMsg]} { + + shellfilter::log::open shellspy-error {-tag shellspy-error -syslog $error_syslog_server} + shellfilter::log::write shellspy-error "logtidyup error $errMsg\n [set ::errorInfo]" + after 200 + } + #don't open more logs.. + #puts stdout ">$tidyinfo" + + #lassign [shellfilter::redir_output_to_log "SUPPRESS"] id_stdout_redir id_stderr_redir + catch { + shellfilter::stack::remove stderr $chanstack_stderr_redir + shellfilter::stack::remove stdout $chanstack_stdout_redir + } + + #shellfilter::log::write $shellspy_status_log "logtidyup -done- $tidyinfo" + + catch { + set errorlist [dict get $tidyinfo errors] + if {[llength $errorlist]} { + foreach err $errorlist { + puts -nonewline stderr "|shellspy-final> worker-error-set $err\n" + } + } + } + + #puts stdout "shellspy -done1-" + #flush stdout + + #shellfilter::log::write $shellspy_status_log "shellspy -done-" + + if {[catch { + shellfilter::logtidyup $shellspy_status_log + #puts stdout "shellspy logtidyup done" + #flush stdout + } errMsg]} { + puts stdout "shellspy logtidyup error $errMsg" + flush stdout + shellfilter::log::open shellspy-final {-tag shellspy-final -syslog $error_syslog_server} + shellfilter::log::write shellspy-final "FINAL logtidyup error $errMsg\n [set ::errorInfo]" + after 100 + } + #puts [shellfilter::stack::status shellspyout] + #puts [shellfilter::stack::status shellspyerr] + + #sample dispatch member of $arglist + #dispatch { + # tclscript { + # command {shellspy::do_script %matched% no_repl} + # matched stdout.tcl arguments {} raw {} dispatchtype raw + # asdispatched {shellspy::do_script stdout.tcl no_repl} + # result {result {}} + # error {} + # } + #} + # or + #dispatch { + # tclscript { + # command xxx + # matched error.tcl arguments {} raw {} dispatchtype raw + # asdispatched {shellspy::do_script error.tcl no_repl} + # result { + # error {This is the error} + # errorCode NONE + # errorInfo This\ is\ the\ error\n\ etc + # } + # error {} + # } + #} + + + shellfilter::stack::delete shellspyout + shellfilter::stack::delete shellspyerr + set free_info [shellthread::manager::shutdown_free_threads] + #puts stdout $free_info + #flush stdout + if {[package provide zzzload] ne ""} { + #if zzzload used and not shutdown - we can get deadlock + #puts "zzzload::loader_tid [set ::zzzload::loader_tid]" + #zzzload::shutdown + } + #puts stdout "threads: [thread::names]" + #flush stdout + #puts stdout "calling release on remaining threads" + foreach tid [thread::names] { + thread::release $tid + } + #puts stdout "threads: [thread::names]" + #flush stdout + + + set colour ""; set reset "" + if {$is_call_error} { + catch { + set colour [punk::ansi::a+ yellow bold underline]; set reset [punk::ansi::a] + } + puts stderr $colour$callError$reset + flush stderr + exit 1 + } else { + if {[dict exists $arglist dispatch tclscript result errorInfo]} { + catch { + set colour [punk::ansi::a+ yellow bold]; set reset [punk::ansi::a] + } + set err [dict get $arglist dispatch tclscript result errorInfo] + if {$err ne ""} { + puts stderr $colour$err$reset + flush stderr + exit 1 + } + } + + foreach tclscript_flavour [list tclline tclkit punkline punkshellline tkline tkshellline libscript help] { + if {[dict exists $arglist dispatch $tclscript_flavour result error]} { + catch { + set colour [punk::ansi::a+ yellow bold]; set reset [punk::ansi::a] + } + set err [dict get $arglist dispatch $tclscript_flavour result error] + if {$err ne ""} { + puts stderr $colour$err$reset + flush stderr + exit 1 + } + } + } + } + + + if {[dict exists $arglist errorCode]} { + exit [dict get $arglist errorCode] + } + foreach tclscript_flavour [list tclline tclkit punkline punkshellline tkline tkshellline libscript help] { + if {[dict exists $arglist dispatch $tclscript_flavour result result]} { + puts -nonewline stdout [dict get $arglist dispatch $tclscript_flavour result result] + exit 0 + } + } + + #if we call exit - package require Tk script files will exit prematurely + #review + #exit 0 +} + +} diff --git a/src/vfs/_vfscommon.vfs/modules/flagfilter-0.3.1.tm b/src/vfs/_vfscommon.vfs/modules/flagfilter-0.3.1.tm new file mode 100644 index 00000000..474ae8d3 --- /dev/null +++ b/src/vfs/_vfscommon.vfs/modules/flagfilter-0.3.1.tm @@ -0,0 +1,2718 @@ + +#Note: this is ugly.. particularly when trying to classify flags that are not fully specified i.e raw passthrough. +# - we can't know if a flag -x --x etc is expecting a parameter or not. +#0.2.2 2023-03 JN - added %match% placeholder support. Can be added to the dispatch command to tell it what command was actually matched. e.g tell xxx.tcl script that it was xxx.tcl when we matched on *.tcl + + +namespace eval flagfilter { + package require oolib ;# make 'oolib::collection new' available + + proc do_errorx {msg {code 1}} { + if {$::tcl_interactive} { + error $msg + } else { + puts stderr "|>err $msg" + exit $code + } + } + + proc do_error {msg {then error}} { + set levels [list debug info notice warn error critical alert emergency] + #note we exit or error out even if debug selected - as every do_error call is meant to interrupt code processing at the site of call + #this is not just a 'logging' call even though it has syslog-like level descriptors + lassign $then type code + if {$code eq ""} { + set code 1 + } + set type [string tolower $type] + if {$type in [concat $levels exit]} { + puts -nonewline stderr "|$type> $msg\n" + } else { + puts -nonewline stderr "|flagfilter> unable to interpret 2nd argument to do_error: '$then' should be one of '$levels' or 'exit '\n" + } + flush stderr + if {$::tcl_interactive} { + #may not always be desirable - but assumed to be more useful not to exit despite request, to aid in debugging + if {[string tolower $type] eq "exit"} { + puts -nonewline stderr " (exit suppressed due to tcl_interactive - raising error instead)\n" + if {![string is digit -strict $code]} { + puts -nonewline stderr "|flagfilter> unable to interpret 2nd argument to do_error: '$then' should be: 'exit '\n" + } + } + flush stderr + return -code error $msg + } else { + if {$type ne "exit"} { + return -code error $msg + } else { + if {[string is digit -strict $code]} { + exit $code + } else { + puts -nonewline stderr "|flagfilter> unable to interpret 2nd argument to do_error: '$then' should be 'error' or 'exit '\n" + flush stderr + return -code error $msg + } + } + } + } + proc scriptdir {} { + set possibly_linked_script [file dirname [file normalize [file join [info script] ...]]] + if {[file isdirectory $possibly_linked_script]} { + return $possibly_linked_script + } else { + return [file dirname $possibly_linked_script] + } + } + +} + +package require overtype + + +namespace eval flagfilter { + namespace export get_one_flag_value + #review. Tcl can handle args like: {-a -val1 -b -val2} as long as they pair up. + #this will ignore flag-like values if they follow a -flag + # positional values that happen to start with - can still cause issues + #get_flagged_only can return an unpaired list if there are solos, or if it finds no value for the last flaglike element + # e.g from input {something -x -y -z} we will get {-x -y -z} + # + # + + #flagfilter::get_flagged_only may not always get things right when looking at a values list with command processors + #Even if all solos from commands are supplied in solodict - a flag might be solo only in the context of a particualar commandset + #The proper way to get flagged values from an arglist is to run the full parser. + #This then should be restricted to use for a specific subset of args where the supplied solodict is known to apply + proc get_flagged_only {arglist solodict} { + #solodict - solo flags with defaults + set solo_accumulator [dict create] ;#if multiple instances of solo flag found - append defaults to the value to form a list as long as the number of occurrences + #puts ">>>get_flagged_only input $arglist solodict:'$solodict'" + set result [list] + set last_was_flag 0 + set result [list] + set a_idx 0 + set end_of_options 0 + foreach a $arglist { + if {$a eq "--"} { + break + } + if {[dict exists $solodict $a]} { + set last_was_flag 0 + if {[dict exists $solo_accumulator $a]} { + set soloval [concat [dict get $solo_accumulator $a] [dict get $solodict $a]] + } else { + set soloval [dict get $solodict $a] + } + dict set solo_accumulator $a $soloval + #we need to keep order of first appearance + set idx [lsearch $result $a] + if {$idx < 0} { + lappend result $a $soloval + } else { + lset result $idx+1 $soloval + } + } else { + if {!$last_was_flag} { + if {$a eq "--"} { + + } else { + if {[lindex $arglist $a_idx-1] eq "--"} { + #end of options processing - none of the remaining are considered flags/options no matter what they look like + set last_was_flag 0 + break + } else { + if {[string match -* $a]} { + set last_was_flag 1 + lappend result $a ;#flag + } else { + #last wasnt, this isn't - don't output + set last_was_flag 0 + } + } + } + } else { + #we only look for single leading - in the value if last wasn't a flag - but we give -- and soloflags special treatment. + if {$a eq "--"} { + #last was flag + set last_was_flag 0 + } else { + lappend result $a ;#value + set last_was_flag 0 + } + } + } + incr a_idx + } + if {([llength $result] % 2) != 0} { + set last [lindex $result end] + if {[string match -* $last] && ($last ni [dict keys $solodict])} { + lappend result 1 + } + } + #puts ">>>get_flagged_only returning $result" + return $result + } + + + ## get_one_paired_flag_value + #best called with 'catch' unless flag known to be in arglist + #raises an error if no position available after the flag to retrieve value + #raises an error if flag not like -something + #raises an error if flag not found in list + proc get_one_paired_flag_value {arglist flag} { + if {![regexp -- {-{1}[^-]+|-{2}[^-]+} $flag]} { + #regexp excludes plain - and -- + #if {![string match -* $flag]} {} + error "get_one_flag_value flag $flag does not look like a flag. Should be something like -$flag or --$flag" + } + set cindex [lsearch $arglist $flag] + if {$cindex >= 0} { + set valueindex [expr {$cindex + 1}] + if {$valueindex < [llength $arglist]} { + #puts stderr "++++++++++++++++++ get_one_flag_value flag '$flag' returning [lindex $arglist $valueindex]" + return [lindex $arglist $valueindex] + } else { + error "flagfilter::get_one_paired_flag_value no value corresponding to flag $flag (found flag, but reached end of list)" + } + } else { + error "flagfilter::get_one_paired_flag_value $flag not found in arglist: '$arglist'" + } + } +} + +namespace eval flagfilter::obj { + +} + + +namespace eval flagfilter { + variable run_counter 0 ;#Used by get_new_runid to form an id to represent run of main check_flags function. + #used as a basis for some object-instance names etc + proc get_new_runid {} { + variable run_counter + if {[catch {package require Thread}]} { + set tid 0 + } else { + set tid [thread::id] + } + return "ff-[pid]-${tid}-[incr run_counter]" + } + + namespace export check_flags + proc do_debug {lvl debugconfig msg} { + if {$lvl <= [dict get $debugconfig -debugargs]} { + foreach ln [split $msg \n] { + puts -nonewline stderr "|[dict get $debugconfig -source]> $ln\n" + flush stderr + } + } + } + + #---------------------------------------------------------------------- + # DO NOT RELY ON tcl::unsupported - it's named that for a reason and is not meant to be parsed + #wiki.tcl-lang.org/page/dict+tips+and+tricks + proc isdict {v} { + if {[string match "value is a list *" [::tcl::unsupported::representation $v]]} { + return [expr {!([llength $v] % 2)}] + } else { + return [string match "value is a dict *" [::tcl::unsupported::representation $v]] + } + } + + proc dict_format {dict} { + dictformat_rec $dict "" " " + } + proc dictformat_rec {dict indent indentstring} { + # unpack this dimension + set is_empty 1 + dict for {key value} $dict { + set is_empty 0 + if {[isdict $value]} { + append result "$indent[list $key]\n$indent\{\n" + append result "[dictformat_rec $value "$indentstring$indent" $indentstring]\n" + append result "$indent\}\n" + } else { + append result "$indent[list $key] [list $value]\n" + } + } + if {$is_empty} { + #experimental.. + append result "$indent\n" + #append result "" + } + return $result + } + #-------------------------------------------------------------------------- + + #solo 'category' includes longopts with value + #solo flags include the general list of -soloflags, and those specific to the current -commandprocessors spec (mashopts and singleopts) + proc is_this_flag_solo {f solos objp} { + if {![string match -* $f]} { + #not even flaglike + return 0 + } + + + if {$f in $solos} { + #review! - global -soloflags shouldn't override the requirements of a commandprocessor! + #but.. each commandprocessor needs to understand global solos occuring before our match so that we classify correctly.. + #todo - this may need to reference v_map and current position in scanlist to do properly + return 1 + } + if {$f eq "-"} { + #unless the caller declared it as a solo - treat this as a non flag element. (likely use is as a command match) + return 0 + } + if {$f eq "--"} { + #this is it's own type endofoptions + return 0 + } + + set p_opts [$objp get_combined_opts] + + set mashopts [dict get $p_opts mashopts] + set singleopts [dict get $p_opts singleopts] + set pairopts [dict get $p_opts pairopts] + set longopts [dict get $p_opts longopts] + + if {$f in $singleopts} { + return 1 + } + + #"any" keywords used by processors to consume anything - where we're not too worried about classifying a flagvalue vs an operand + #examine these last so that an explicit configuration of flags as pairopts,mashopts etc can still be classified correctly + if {"any" in $singleopts} { + return 1 + } + if {[string first "=" $f] >=1} { + if {"any" in $longopts} { + return 1 + } + #todo foreach longopt - split on = and search + } + + #Flag could still be part of a solo if it is in mashopts *and* has a value following it as part of the mash - but if it's a pairopt, but not mashable - we can rule it out now + if {($f in $pairopts) && ($f ni $mashopts)} { + return 0 + } + #todo - suport mashes where one of the mashed flags takes an arg - review: only valid if it's last in the mash? + #(presumably so - unless we there was some other value delimiter such as isnumeric or capitalised flags vs lowercase values - but that seems a step too far - would require some sort of mashspec/mash-strategy config) + #last part of mash may actually be the value too. which complicates things + #linux ls seems to do this for example: + # ls -w 0 + # ls -lw 0 + # ls -lw0 + # also man.. e.g + # man -Tdvi + # man -Hlynx + # man -H + # - note this last one. '-H lynx' doesn't work - so it's a mashable opt that can take a value, but is not in pairopts! (-H with no value uses env value for browser) + # see also comments in is_this_flag_mash + # + + set flagletters [split [string range $f 1 end] ""] + set posn 1 + set is_solo 1 ;#default assumption to disprove + #trailing letters may legitimately not be in mashopts if they are part of a mashed value + #we can return 0 if we hit a non-mash flag first.. but at each mashflag we need to test if we can classify as definitely solo or not, or else keep processing + foreach l $flagletters { + if {"-$l" ni $mashopts} { + #presumably an ordinary flag not-known to us + return 0 + } else { + if {"-$l" in $pairopts} { + if {$posn == [llength $flagletters]} { + #in pairopts and mash - but no value for it in the mash - thefore not a solo + return 0 + } else { + #entire tail is the value - this letter is effectively solo + return 1 + } + } elseif {"-$l" in $singleopts} { + #not allowed to take a value - keep processing letters + } else { + #can take a value! but not if at very end of mash. Either way This is a solo + return 1 + } + } + } + return $is_solo + } + #todo? support global (non-processor specific) mash list? -mashflags ? + proc is_this_flag_mash {f objp} { + if {![regexp -- {-{1}[^-]+|-{2}[^-]+} $f]} { + #not even flaglike + return 0 + } + set optinfo [$objp get_combined_opts];#also applies to tail_processor - *usually* empty values for mashopts etc + + #we look at singleopts because even if the flag is in mashopts - when it is alone we don't classify it as a mash + set singleopts pdict get $optinfo singleopts] + if {$f in $singleopts} { + return 0 + } + + set pairopts [dict get $optinfo pairopts] + if {$f in [dict keys $pairopts]} { + #here, the entire arg (f) we are testing is in pairopts - it could still however appear as part of a mash, with or without a trailing value, and with or without other flags before it in the mash (but if neither prefixed,nor tailed then obviously not a mash) + return 0 + } + set mashopts [dict get $optinfo mashopts] + set flagletters [split [string range $f 1 end] ""] + set is_mash 1 ;#to disprove - all letters must be in mashopts to consider it a mash.. unless trailing one also takes a value + # .. in which case value could be at the tail of the mash.. or be the next arg in the list + # We will take absense from singleopts and pairopts to indicate the mashflag *optionally* takes a value + # (ie such a mashopt is a solo that can take a value only as a mashtail) + # presence in pairopts indicates a mashflag must have a value + # presense in singleopts indicates mashflag takes no value ever. + # mashopt cannot be in both singleopts and pairopts. (NAND) + foreach l $flagletters { + if {-$l in $pairopts} { + if {"-$l" in $mashopts} { + #need to consider any remainder in the mash as this value .. if no remainder - then this is a mash, but not 'solo' because this flag needs to consume the following arg. + # We are only concerned with mashness here so just stop processing mash elements when we hit the first one that is a pairopt + break + } else { + #we require the pairopt to explicitly be listed in mashopts as well as pairopts if it is to be allowed to be part of a mash + set is_mash 0 + } + } elseif {"-$l" in $singleopts} { + #singleopt & mashopt - cannot take a value, mashed or otherwise + if {"-$l" ni $mashopts} { + set is_mash 0 + } + } else { + if {"-$l" ni $mashopts} { + set is_mash 0 + } else { + #present only in mashopts - can take a value, but only immediately following in the mash + break + } + } + } + return $is_mash + } + proc is_this_flag_for_me {f objp cf_args} { + set processorname [$objp name] + set optinfo [$objp get_combined_opts] ;#also applies to tail_processor - *usually* empty values for mashopts etc + + if {$processorname in [list "tail_processor"]} { + return 1 + } + if {$processorname in [list "global"]} { + #todo - mashflags for global? + set defaults [dict get $cf_args -defaults] + set extras [dict get $cf_args -extras] + set soloflags [dict get $cf_args -soloflags] + if {$f in [concat $extras $soloflags [dict keys $defaults]]} { + return 1 + } + } + + set singleopts [dict get $optinfo singleopts] + if {"any" in [string tolower $singleopts]} { + #review semantics of 'all' here. does it mean any -xxx.. will match, or only if also in global -soloflags? + return 1 + } + set pairopts [dict get $optinfo pairopts] + set allopts [concat $singleopts [dict keys $pairopts]] + if {$f in $allopts} { + return 1 + } + + #process mashopts last + set mashopts [dict get $optinfo mashopts] + if {"any" in [string tolower $mashopts]} { + #if 'all' in mashopts - it can eat anything - review - is this even useful? + return 1 + } else { + set flagletters [split [string range $f 1 end] ""] + set is_mash 1 ;#to disprove - all letters must be in mashopts to consider it a mash + foreach l $flagletters { + if {"-$l" ni $mashopts} { + set is_mash 0 + } + } + return $is_mash + } + + return 0 + } + + + + proc add_dispatch_raw {recordvar parentname v} { + upvar $recordvar drecord + if {[dict exists $drecord $parentname]} { + set dispatchinfo [dict get $drecord $parentname raw] + lappend dispatchinfo $v + dict set drecord $parentname raw $dispatchinfo + } + } + proc add_dispatch_argument {recordvar parentname k v} { + upvar $recordvar drecord + if {[dict exists $drecord $parentname]} { + set dispatchinfo [dict get $drecord $parentname arguments] + lappend dispatchinfo $k $v ;#e.g -opt 1 + dict set drecord $parentname arguments $dispatchinfo + } + } + proc lsearch-all-stride-2 {l search} { + set posns [lmap i [lsearch -all $l $search] {expr {($i % 2) == 0 ? $i : [list x]}}] + return [lsearch -all -inline -not $posns x] + } + proc update_dispatch_argument {recordvar parentname k v} { + upvar $recordvar drecord + if {[dict exists $drecord $parentname]} { + set dispatchinfo [dict get $drecord $parentname arguments] + #can't assume there aren't repeat values e.g -v -v + #dict set dispatchinfo $k $v + if {[package vcompare [info tclversion] 8.7a5] >= 0} { + set posns [lsearch -all -stride 2 $dispatchinfo $k] + } else { + set posns [lsearch-all-stride-2 $dispatchinfo $k] + } + set lastitem [lindex $posns end] + if {[string length $lastitem]} { + set val_idx [expr {$lastitem + 1}] + set dispatchinfo [lreplace $dispatchinfo[set dispatchinfo {}] $val_idx $val_idx $v] ;# inlineK + dict set drecord $parentname arguments $dispatchinfo + } else { + error "Unable to update dispatch argument $k with value $v in dispatch record for $parentname" + } + #dict set drecord $parentname $dispatchinfo + } + } + + #Note the difference between this and is_command_match. + #Lack of a 'match' element does not cause a commandspec to skip allocating an operand it encounters + #Note that this isn't a general test to be applied to the entire argument list. + # - an arg may get matched by an earlier processor making it unavailable to be allocated by another processor + # so this test only applies during the ordered examination of args + proc can_this_commandspec_allocate_this_arg {flag cspec cf_args} { + set cmdinfo [lindex $cspec 1] + if {$cmdinfo eq "tail_processor"} { + return 1 + } + if {$cmdinfo eq "global"} { + set defaults [dict get $cf_args -defaults] + set soloflags [dict get $cf_args -soloflags] + set extras [dict get $cf_args -extras] + if {$flag in [concat $soloflags $extras [dict keys $defaults]]} { + return 1 + } + } + if {![dict exists $cmdinfo match]} { + return 1 + } + set matchspeclist [dict get $cmdinfo match] + foreach matchspec $matchspeclist { + if {[regexp -- $matchspec $flag]} { + return 1 + } + } + #only block it if there was a match pattern specified but it didn't match + return 0 + } + #Note - returns false for a cspec that has no match specified. + #A command/subcommand with no match specification is allowed to allocate any value - so be careful with this + # - it should not be used to *stop* an arg being allocated if the processor has no 'match' specified, or if it is another type of processor like 'tail_handler'. + proc is_command_match {flag cspec} { + set pinfo [lindex $cspec 1] + if {[dict exists $pinfo match]} { + set matchspeclist [dict get $pinfo match] + foreach matchspec $matchspeclist { + if {[regexp -- $matchspec $flag]} { + return 1 + } + } + return 0 + } else { + return 0 + } + } + proc is_command_match_any {f commandprocessors} { + foreach comspec $commandprocessors { + lassign $comspec cmdname cmdinfo + if {[dict exists $cmdinfo match]} { + set matchlist [dict get $cmdinfo match] + foreach matchspec $matchlist { + if {[regexp -- $matchspec $f]} { + #actually a command + return true + } + } + } + } + return false + } + + #determine if f is potentially a flag that takes a parameter from the next argument. + #e.g --x=y (longopt) does not consume following arg but --something *might* + proc is_candidate_toplevel_param_flag {f solos commandprocessors} { + if {[is_command_match_any $f $commandprocessors]} { + return false + } + if {$f in $solos} { + return 0 + } + if {$f in {- --}} { + return 0 + } + #longopts (--x=blah) and alternative --x blah + #possibly also -x=blah + if {[string match -* $f]} { + if {[string first "=" $f]>1} { + return 0 + } + } + return [expr {[string match -* $f]}] + } + + + + + + + + + + + + + + + + + + + #review - should we be using control::assert here? + #It depends if this is intended to raise error at runtime - would using control::assert and disabling assertions cause problems? + #todo - show caller info + proc assert_equal {a b} { + if {![expr {$a eq $b}]} { + error "assert_equal $a $b" + } + } + + + + + + #{1 unallocated 2 unallocated 3 unallocated 4 unallocated 5 unallocated 6 unallocated} ;#initial v_map + #1 2 3 4 5 6 ;#original list posns example + # 2 6 ;#map_remaining example (scanlist) + #1 3 4 5 ;#map_allocated example + #{1 {cmd1 operand} 2 unallocated 3 {cmd2 operand} 4 {cmd2 flag} 5 {cmd2 flagvalue} 6 unallocated} ;#v_map updated example + oo::class create class_vmap { + variable o_map + variable o_remaining + variable o_allocated + variable o_values + variable o_codemap + variable o_flagcategory + constructor {values} { + set o_codemap [dict create \ + operand op \ + flagvalue fv \ + soloflag so \ + flag fl \ + unallocated un \ + endofoptions eo \ + ] + set o_flagcategory [list "flag" "flagvalue" "soloflag"] + set o_values $values + #set o_remaining [lsearch -all $values *] ;#create a list of indices e.g 0 1 2 3 4 5 6 + #lsearch -all * is fast for very small lists - but lseq wins from size around 30+ + if {[llength $values]} { + if {[llength $values] < 30} { + #common case is short lists - but we don't want to penalize large lists + set o_remaining [lsearch -all $values *] + } else { + #punk::lib::range wraps lseq if available + set o_remaining [punk::lib::range 0 [llength $values]-1] + } + } else { + set o_remaining [list] + } + set o_allocated [list] + set o_map [list] + foreach posn $o_remaining { + lappend o_map $posn unallocated + } + } + method load {values rem alloc map} { + set o_values $values + set o_remaining $rem + set o_allocated $alloc + set o_map $map + } + method copy_to {obj} { + $obj load $o_values $o_remaining $o_allocated $o_map + } + method update_map_from {obj} { + #very basic sanity check first + if {[llength $o_values] ne [llength [$obj get_values]]} { + error "[self class].update_map_from cannot update. length of values mismatch" + } + + set newmap [$obj get_map] + } + + method get_codemap {} { + return $o_codemap + } + method get_values {} { + return $o_values + } + method get_remaining {} { + return $o_remaining + } + method get_allocated {} { + return $o_allocated + } + method get_map {} { + return $o_map + } + method argnum_from_remaining_posn {scanlist_posn} { + set vidx [lindex $o_remaining $scanlist_posn] + if {![string is digit -strict $vidx]} { + return -code error "[self class].argnum_from_remaining_posn cannot determine argnum from scanlist position:$scanlist_posn using unallocated list:'$o_remaining'" + } + return $vidx + } + + method allocate {objp argnum type value} { + set processorname [$objp name] + if {$processorname eq "tail_processor"} { + set owner "unallocated" + } else { + set owner [$objp parentname] + } + if {$argnum > [llength $o_values]-1} { + return -code error "[self class].allocate cannot allocate argnum:$argnum. Only [llength $o_values] items in value list" + } + if {$argnum in $o_allocated} { + return -code error "[self class].allocate already allocated '$processorname' argnum:'$argnum' type:'$type' val:'$value' remaining:$o_remaining allocated:$o_allocated map:$o_map" + } + lappend o_allocated $argnum + set o_allocated [lsort -dictionary $o_allocated] + dict set o_map $argnum [list $owner $type $value] + set scanlist_posn [lsearch $o_remaining $argnum] + set o_remaining [lreplace $o_remaining[set o_remaining {}] $scanlist_posn $scanlist_posn] ;#inlineK + + + + } + + method get_list_unflagged_by_class {classmatch} { + set resultlist [list] + dict for {k vinfo} $o_map { + lassign $vinfo class type val + if {[string match $classmatch $class]} { + switch -- $type { + flag - flagvalue - soloflag {} + default { + lappend resultlist $val + } + } + } + } + return $resultlist + } + + method get_list_flagged_by_class {classmatch} { + set list_flagged [list] + dict for {k vinfo} $o_map { + lassign $vinfo class type val + if {[string match $classmatch $class]} { + switch -- $type { + flag - flagvalue - soloflag { + lappend list_flagged $val + } + } + } + } + return $list_flagged + } + + method get_merged_flagged_by_class {classmatch} { + variable flagcategory + set all_flagged [list] + set seenflag [dict create] ;#key = -flagname val=earliest vindex + dict for {k vinfo} $o_map { + lassign $vinfo class type val + if {[string match $classmatch $class]} { + set a [llength $all_flagged] ;#index into all_flagged list we are building + switch -- $type { + soloflag { + if {[dict exists $seenflag $val]} { + set seenindex [dict get $seenflag $val] + set seenindexplus [expr {$seenindex+1}] + set existingvals [lindex $all_flagged $seenindexplus] + lappend existingvals 1 ;#1 indicating presence - stored as list rather than a count. todo: consider global or per-solo options to support incrementing instead? + lset all_flagged $seenindexplus $existingvals + } else { + dict set seenflag $val $a + lappend all_flagged $val 1 + } + } + flag { + if {![dict exists $seenflag $val]} { + dict set seenflag $val $a + lappend all_flagged $val + } + #no need to do anything if already seen - flagvalue must be next, and it will work out where to go. + } + flagvalue { + set idxflagfor [expr {$k -1}] + set flagforinfo [dict get $o_map $idxflagfor] + lassign $flagforinfo ffclass fftype ffval + #jn "--" following a flag could result in us getting here accidentaly.. review + set seenindex [dict get $seenflag $ffval] + if {$seenindex == [expr {$a-1}]} { + #usual case - this is a flagvalue following the first instance of the flag + lappend all_flagged $val + } else { + #write the value back to the seenindex+1 + set seenindexplus [expr {$seenindex+1}] + set existingvals [lindex $all_flagged $seenindexplus] + lappend existingvals $val ;#we keep multiples as a list + lset all_flagged $seenindexplus $existingvals + } + } + } + } + } + return $all_flagged + } + method typedrange_class_type_from_arg {argclass argtype} { + #set o_flagcategory [list "flag" "flagvalue" "soloflag"] + if {$argclass eq "unallocated"} { + switch -- $argtype { + flag - flagvalue - soloflag { + return [list unallocated flagtype] + } + default { + if {![string length $argtype]} { + #should only happen if something wrong with the tail_processor - rather than error out, for now at least make it stand out in the . + set argtype UNKNOWN + } + return [list unallocated ${argtype}type] ;#e.g unallocated_operand, unallocated_endofoptions + } + } + } else { + return [list $argclass argtype] ;# e.g command something + } + } + + method get_ranges_from_classifications {classifications} { + #puts stderr "get_ranges_from_classifications $classifications" + #examine classifications and create a list of ranges + set ranges [list];# e.g [list {unallocated 0 4} {cmd1 5 7} {unallocated 8 8} {cmd2 9 9} {cmd3 10 10} {unallocated 11 15}] + set seen_commands [list] + dict for {posn arginfo} $classifications { + set is_new_cmd 0 + set is_sub_cmd 0 + set is_continuation 0 + set rangename [lindex $ranges end 0] + set alloc [lindex $arginfo 0] ;#e.g of form 0 {unallocated operand} 1 {lscmd operand} 2 {lscmd soloflag} 3 {lscmd.dir operand} 4 {unallocated flag} + set cmdname "" + if {$alloc ne "unallocated"} { + if {$alloc ni $seen_commands} { + if {![llength $seen_commands]} { + set cmdname $alloc + set is_new_cmd 1 + } else { + set tail [lindex $seen_commands end] + if {$tail eq "unallocated"} { + set cmdname $alloc + set is_new_cmd 1 + } else { + if {[string first . $alloc] >= 0} { + set prefixcheck [lindex [split $alloc .] 0] + if {![string equal -length [string length $prefixcheck] $prefixcheck $tail]} { + #this is not unallocated, not a subcommand of the previous seen ie new command + set cmdname $alloc + set is_new_cmd 1 + } else { + set cmdname $prefixcheck + set is_sub_cmd 1 + set is_continuation 1 + } + } else { + set cmdname $alloc + set is_new_cmd 1 + } + } + } + } else { + set cmdname $alloc + set is_continuation 1 + } + if {$is_continuation} { + lassign [lindex $ranges end] _cmd n a b + set ranges [lrange $ranges 0 end-1] + lappend ranges [list command $n $a [incr b]] + flagfilter::assert_equal $b $posn + } elseif {$is_new_cmd} { + lappend seen_commands $alloc + if {$rangename eq ""} { + lappend ranges [list command $cmdname $posn $posn] + } else { + lassign [lindex $ranges end] _cmd n a b + lappend ranges [list command $cmdname [incr b] $posn] + flagfilter::assert_equal $b $posn + } + } else { + error "coding error during dispatch" + } + } else { + if {$rangename eq ""} { + lappend ranges [list unallocated mixed 0 0] + } else { + lassign [lindex $ranges end] class n a b + if {$class eq "unallocated"} { + #continuation - extend + set ranges [lrange $ranges 0 end-1] + lappend ranges [list unallocated mixed $a [incr b]] + } else { + #change from allocated to unallocated + lappend ranges [list unallocated mixed [incr b] $posn] + flagfilter::assert_equal $b $posn + } + } + } + } + set rangesbytype [list] + foreach oldrange $ranges { + lassign $oldrange oldrangeclass oldrangetype A B ;#A,B for original range bounds, a,b for bounds of sub-ranges we are creating + set last_type "" + set newrangelist [list] + set inner_range [list 0 0] + if {$oldrangeclass ne "unallocated"} { + #pass through - user can split commands further themselves by referencing the classifications map where each arg position is listed + set last_type $oldrangeclass ;#note the deliberate slight misuse - we are using the 'class' here rather than the type as we aren't looking at types within a command range + lappend rangesbytype $oldrange + } else { + #puts stdout "???????????????????????????????????????????????A$A B$B examining old range:'$oldrange'" + for {set i $A} {$i <= $B} {incr i} { + lassign [lindex $rangesbytype end] last_class last_type a b ;#enough just to use the type without the class + set a_info [dict get $classifications $i] + lassign $a_info argclass argtype v + lassign [my typedrange_class_type_from_arg $argclass $argtype] newrangeclass newrangetype + if {$last_type eq ""} { + lappend rangesbytype [list "unallocated" $newrangetype 0 0] + } else { + if {$last_type eq $newrangetype} { + set rangesbytype [lrange $rangesbytype 0 end-1] + lappend rangesbytype [list $last_class $last_type $a $i] + } else { + lappend rangesbytype [list $newrangeclass $newrangetype $i $i] + } + } + } + } + } + + return [list -ranges $ranges -rangesbytype $rangesbytype] + } + + method grid {} { + set posns [dict keys $o_map] + set col1 [string repeat " " 15] + set col [string repeat " " 4] + set pline "[overtype::left $col1 {var indices}] " + foreach p $posns { + append pline [overtype::left $col $p] + } + set remline "[overtype::left $col1 {unallocated}] " + foreach vidx $posns { + if {$vidx ni $o_remaining} { + append remline [overtype::left $col "."] + } else { + set tp [lindex [dict get $o_map $vidx] 1] + #set tp [string map $o_codemap $tp] + if {[dict exists $o_codemap $tp]} { + set tp [dict get $o_codemap $tp] + } + append remline [overtype::left $col $tp] + } + } + set cmdlist [list] + dict for {vidx info} $o_map { + if {[lindex $info 0] ne "unallocated"} { + set c [lindex [split [lindex $info 0] .] 0] + if {$c ni $cmdlist} { + lappend cmdlist $c + } + } + } + set clinelist [list] + foreach c $cmdlist { + set cline "[overtype::left $col1 $c] " + dict for {vidx info} $o_map { + lassign $info class type v + if {($c eq $class) || [string equal -length [string length "$c."] "$c." $class]} { + #set tp [string map $o_codemap $type] + if {[dict exists $o_codemap $type]} { + set tp [dict get $o_codemap $type] + } + append cline [overtype::left $col $tp] + } else { + append cline [overtype::left $col "."] + } + } + lappend clinelist $cline + } + + + set aline "[overtype::left $col1 {allocated}] " + foreach vidx $posns { + if {$vidx ni $o_allocated} { + append aline [overtype::left $col "."] + } else { + set tp [lindex [dict get $o_map $vidx] 1] + #set tp [string map $o_codemap $tp] + if {[dict exists $o_codemap $tp]} { + set tp [dict get $o_codemap $tp] + } + append aline [overtype::left $col $tp] + } + } + + return "$pline\n$remline\n[join $clinelist \n]\n$aline\n" + } + + } + + + #!todo - check if -commandprocessors members will collide with existing -flags in values before moving them + #!todo - skip optional sub-flag value if the next arg following its parent is a flag i.e proper handling of -commandprocessors {cmd {cmd sub "default}} when only cmd supplied. + #!important to fix. At the moment it could eat a further unflagged item in values later in the list which was intended for a different -commandprocessors member! + #add support for -commandprocessors {-cmd {-cmd -othercmd "default"}} to be a safe way to specify a linked -flag move that does the same. + proc allocate_arguments {PROCESSORS solos values cf_args caller} { + set runid [lindex [split [namespace tail $PROCESSORS] _] 1] ;# objname is of form PROCESSORS_pid-threadid-counter where "PROCESSORS_" is a literal + #puts stderr ">>>>>>> solos: $solos" + dict set debugc -debugargs [dict get $cf_args -debugargs] + dict set debugc -source "allocate_arguments $caller" + + set defaults [dict get $cf_args -defaults] + + set cmdprocessor_records [$PROCESSORS get_commandspecs] + + + set sep "\uFFFE" ;#argument-subargument separator (choose something else if this causes problems.. but we want something unlikely (or preferably impossible?) to be in a commandline, ideally a single character, and which at least shows something on screen during debug) + set sepstr "\\uFFFE" ;#for human readable error msg + #\u001E was tried and doesn't output on some terminals) + + set remaining_unflagged [dict create] + + set extra_flags_from_positionals [list] ;#values moved to -values + set moved_to_flagged [dict create] + + #implied_ are values supplied from defaults when a flag or operand was not found + set implied_flagged [list] + set implied_unflagged [list] + + + set dispatch [dict create] + #sanitize and raise error if sep somehow in values + if {[string first $sep $cmdprocessor_records] >= 0} { + do_error "allocate_arguments flags error separator '$sep' ($sepstr) found in values " + } + #-------------------------------------- + set VMAP [flagfilter::class_vmap create flagfilter::VMAP_$runid $values] + #-------------------------------------- + + set unconsumed_flags_and_values [list] + set unflagged [dict create] + + ###################### + #main -commandprocessors loop which scans the valuelist + set values_index 0 ;#track where we are up to as we allocate values to unflagged elements + set source_values $values ;#start with all including -flagged + + #todo - get rid of most of these flags last_x_was etc - and just do lookups into the v_map + # as this will probably involve *lots* of small functiona calls - keep this boolean version and check for performance issues. + set a_index 0 + set is_args_flag 0 + set last_arg_was_paramflag 0 ;#a flag that expects a parameter to follow + set last_arg_was_solo 0 + set solo_flags [dict keys $solos] ;#solos is a dict of -flag (preprocessed) + set end_of_options 0 + set end_of_options_index -1 ;#as later processors can rescan - we need to make sure they only look at arguments after this point + set last_p_found [dict create by "" index "" item ""] + set sequence 0 + set argerrors [list] ;#despite being a list - we will break out at first entry and return for now. + set parsestatus "ok" + + #set LAUNCHED [oolib::collection create col_processors_launched_$runid] + #set MATCHED [oolib::collection create col_processors_matched_$runid] + #oo::objdefine col_processors_matched_$runid { + # method test {} { + # return 1 + # } + #} + + #set objp [$PROCESSORS object_from_record $p] ;#temp convenience + + foreach objp [$PROCESSORS items] { + set objparent [$objp parent] + #$LAUNCHED add $objp [$objp name] + set p [$objp get_def] ;#individual record e.g {mycmd {match run singleopts {-x}}} or {tail_processor {}} + + lassign $p parentname pinfo + set is_sub [$objp is_sub] ;#is subargument - should look to see if last related spec got a value and abort if not. + set is_p_flag [$objp is_flag] ;#sub can be a flag even if parent isn't + set processorname [$objp name] + if {[$objp is_sub]} { + if {![[$objp parent] found_match]} { + continue + } + set p_sub [dict get $pinfo sub] + } + do_debug 3 $debugc " =========================>> p $p sequence:$sequence a_index $a_index" + + if {$processorname in [list "global" "tail_processor"]} { + dict set last_p_found by $processorname + #dict set last_p_found index $a_index + #dict set last_p_found item $a + } + # -format {x {sub y default "default"}} means y is dependent on x being present and shouldn't eat if the next value isn't flaglike + # -format {-x {sub -y}} does the same for moving positionals to the flagged list. + + + #set remaining_values [lrange $source_values $a_index end] + ##################################### + # full rescans for later processors + set remaining_values $source_values ;#source_values shrinks as commands take arguments + set a_index 0 + ##################################### + + do_debug 3 $debugc "-------->________>p '$processorname' remaining vals $remaining_values" + + #!todo - use v_map as an extra determinant to stop sequence for a command-set. (don't extend beyond where args have already been snipped by another command) + if {[$objp name] eq "tail_processor"} { + set mapcopy [flagfilter::class_vmap new {}] ;#no need to supply values as we are copying data from $VMAP + $VMAP copy_to $mapcopy + $objp set_map_object $mapcopy + } else { + $objp set_map_object $VMAP + } + foreach a $remaining_values { + set argnum [[$objp get_map_object] argnum_from_remaining_posn $a_index] + if {![string is integer -strict $argnum]} { + error "arg '$a' scan_index:$a_index - calculated argnum:'$argnum' is invalid" + + } + set sub_operand 0 + do_debug 3 $debugc "$argnum >eoptions_idx:$end_of_options_index a_index:$a_index __________________________________________________________a $a" + if {$end_of_options_index > -1} { + set end_of_options [expr {$a_index >= $end_of_options_index}] + } + + #review - data with leading - may be unintentionally interpreted as a flag + if {[string trim $a] eq "--"} { + #generally means end of options processing.. + #review - pass -- through?? + set last_arg_was_paramflag 0 ;#we don't treat first arg following end_of_options as belonging to the flag! - it is potentially an operand to the command + set is_solo_flag 0 + set end_of_options 1 + set end_of_options_index $a_index + #if {[lindex $p 0] eq "tail_processor"} { + $objp allocate $argnum "endofoptions" $a + set source_values [lreplace $source_values[set source_values {}] $a_index $a_index] ;#inlineK + incr a_index -1 + #} + } else { + if {($last_arg_was_paramflag) && ([$objp arg_is_defined_solo_to_me $a])} { + #last flag expecting param - but this flag *known* to be solo + #keep it simple and break out at first solo_flag related error ...unless it is trailing flag in the list + lappend argerrors [list flagerror solo_flag_following_non_solo_flag bad_flag $a] + set last_arg_was_solo 1 + break + } + #set is_solo_flag [expr {($a in $solo_flags)}] + #set is_solo_flag [is_this_flag_solo $a $solo_flags $objp] + set is_solo_flag [$objp arg_is_defined_solo_to_me $a] + + if {!$end_of_options} { + if {!$last_arg_was_paramflag} { + if {!$is_solo_flag} { + set is_args_flag [is_candidate_toplevel_param_flag $a $solo_flags $cmdprocessor_records] + #set is_args_flag [string match -* $a] + } + if {$is_args_flag || $is_solo_flag} { + if {[dict get $last_p_found by] eq $processorname} { + if {![is_this_flag_for_me $a $objp $cf_args]} { + if {$processorname ne "globalXXX"} { + do_debug 3 $debugc "----breaking--- $processorname already found a value [dict get $last_p_found item] and has now hit an unrecognized option: $a" + break + } + } + } + } + } else { + #last was flag expecting a param + set is_args_flag 0 + set is_solo_flag 0 + } + } else { + #end_of_options - ignore solo and other flags now. + set is_args_flag 0 + set is_solo_flag 0 + set last_arg_was_paramflag 0 + + } + + #puts stderr "!!!!!!!!!!!!!!!!!!1 here is_args_flag:$is_args_flag" + do_debug 3 $debugc " >________>________>is_p_flag: $is_p_flag last_arg_was_paramflag:$last_arg_was_paramflag is_args_flag:$is_args_flag is_solo: $is_solo_flag (soloflags:$solo_flags) a:$a " + if {!$is_args_flag && !$is_solo_flag } { + + if {!$last_arg_was_paramflag} { + if {[dict get $last_p_found by] eq $processorname} { + if {$processorname ne "tail_processor"} { + #we already found our unflagged value - and now we've hit another - time to break and hand it to a subcommand processor if any + do_debug 3 $debugc "----breaking--- $processorname already found a value [dict get $last_p_found item] and has now hit another value: $a" + break + } + } + set sequence_ok 1 ;#default assumption + set can_allocate [can_this_commandspec_allocate_this_arg $a $p $cf_args] + + if {$can_allocate} { + if {$is_sub} { + #!todo - use v_map as sequence terminator + #check if our find is in sequence + #we are only hunting non-flagged items and the the previous finder removes 1 from the source_values list + #therefore the a_index of our find should be the same if we are processing the very next argument. + #we have already checked that it was a related entity which found the last one. + #todo - review if it matters when parents/siblings don't eat all the way up to the next -flag. + #todo - implement a 'gather' key to keep eating in sequence and accumulate the values as a list + if {$a_index > [dict get $last_p_found index]} { + do_debug 3 $debugc "OUT OF SEQUENCE a_index:$a_index vs last_found index:[dict get $last_p_found index], $processorname disengaging - ignoring value $a and leaving it to the next processor" + set last_arg_was_paramflag 0 + do_debug 3 $debugc "<--- breaking --->" + break + } elseif {$a_index < [dict get $last_p_found index]} { + #too early.... found something before previous match + do_debug 3 $debugc "+++++++++++++++out of sequence $processorname - too early.. keeping scanning" + set sequence_ok 0 + } + if {$sequence_ok} { + set sub_operand 1 + } + } + } + + if {$can_allocate && $sequence_ok} { + #found a non-flagged value in the argumentlist to either reallocate to flagged values or to positional values + if {[dict exists $pinfo dispatch]} { + if {!$is_sub} { + #this must be the arg that caused the match + dict set dispatch $parentname [list command [dict get $pinfo dispatch] matched $a arguments [list] raw [list]] + } else { + #todo + lappend argerrors [list unsupported_dispatch $processorname] + } + } + if {$sub_operand} { + if {[dict exists $dispatch $parentname]} { + #todo - defaults? + add_dispatch_argument "dispatch" $parentname $processorname $a + add_dispatch_raw "dispatch" $parentname $a + } else { + #warning? + #lappend argerrors [list subcommand_unable_to_add_operand $processorname] + do_debug 3 $debugc "subcommand $processorname aborting scanning because parent command wasn't activated" + break + } + } + do_debug 2 $debugc " >+++++++>++++++++>++++++++>setting $processorname [if {$is_p_flag} {list -} {}]value $a" + if {$processorname eq "tail_processor"} { + set argnum [[$objp get_map_object] argnum_from_remaining_posn $a_index] + set argname arg$argnum + lappend remaining_unflagged $argname $a + lappend unconsumed_flags_and_values $a + dict set unflagged $argname $a + } elseif {$is_p_flag} { + $objp set_matched_argument $argnum $a + if {$is_sub} { + dict set extra_flags_from_positionals $p_sub $a + } else { + dict set extra_flags_from_positionals $parentname $a + } + lappend moved_to_flagged $processorname $a + #if has dependent commands ? - check for deep subcommand match? + } else { + $objp set_matched_argument $argnum $a + #lappend positional_values $a + dict set unflagged $processorname $a + } + do_debug 4 $debugc " >________>________>________>source_values :'$source_values'" + do_debug 3 $debugc " >________>________>________>source_values len:[llength $source_values] removing element $a_index val:[lindex $source_values $a_index]" + + #---------------------------- + dict set last_p_found by $processorname + dict set last_p_found index $a_index + dict set last_p_found item $a + #------------------------------ + $objp allocate $argnum "operand" $a + set source_values [lreplace $source_values[set source_values {}] $a_index $a_index] ;#inlineK + incr values_index ;#only increment when we allocate a value to one of the members of -commandprocessors + set last_arg_was_paramflag 0 + if {$processorname ne "tail_processor"} { + #don't break until we hit an unrecognized flag or another unflagged value + incr a_index -1 + #don't increment a_index before break, because we have shortened the list by 1. + #do_debug 3 $debugc "----breaking---" + #break + } else { + #decrement to compensate for shortened list because tail_processor continues to end + incr a_index -1 + } + } + + } else { + #last_arg_was_paramflag + set lastarg [dict get $last_p_found item] + #puts stdout "+++ lastarg: $lastarg source_values: [dict get $last_p_found source_values] a_index: $a_index" + if {$processorname eq "tail_processor"} { + lappend unconsumed_flags_and_values $a + } + if {([dict get $last_p_found by] eq $processorname) && [is_this_flag_for_me $lastarg $objp $cf_args]} { + update_dispatch_argument "dispatch" $parentname $lastarg $a + add_dispatch_raw "dispatch" $parentname $a + dict set last_p_found by $processorname + dict set last_p_found index $a_index + dict set last_p_found item $a + $objp allocate $argnum "flagvalue" $a + set source_values [lreplace $source_values[set source_values {}] $a_index $a_index] ;#inlineK + incr a_index -1 + } + set last_arg_was_paramflag 0 + } + } else { + # is a flag of some sort ({!$is_args_flag && !$is_solo_flag} = false) + if {$processorname eq "tail_processor"} { + lappend unconsumed_flags_and_values $a + } + if {([dict get $last_p_found by] eq $processorname) && [is_this_flag_for_me $a $objp $cf_args]} { + if {$is_solo_flag} { + add_dispatch_argument "dispatch" $parentname $a 1 + add_dispatch_raw "dispatch" $parentname $a + set last_arg_was_solo 1 + set last_arg_was_paramflag 0 + $objp allocate $argnum "soloflag" $a + } else { + add_dispatch_argument "dispatch" $parentname $a "" + add_dispatch_raw "dispatch" $parentname $a + set last_arg_was_solo 0 + set last_arg_was_paramflag 1 + $objp allocate $argnum "flag" $a + } + dict set last_p_found by $processorname + dict set last_p_found index $a_index + dict set last_p_found item $a + do_debug 4 $debugc " >2_______>________>________>source_values :'$source_values'" + do_debug 3 $debugc " >2_______>________>________>source_values len:[llength $source_values] removing element $a_index val:[lindex $source_values $a_index]" + set source_values [lreplace $source_values[set source_values {}] $a_index $a_index] ;#inlineK + incr a_index -1 + } else { + #auto alternate based on last value.. unless end_of_options + if {!$end_of_options} { + if {$a in $solo_flags} { + set last_arg_was_solo 1 + set last_arg_was_paramflag 0 + } else { + set last_arg_was_paramflag 1 + } + } + if {$a_index eq ([llength $source_values]-1)} { + #puts "XXXXXXXXXXXXXXXXXXX $a_index source_values:'$source_values'" + #if at end of list don't retain any last..was info. + set last_arg_was_solo 0 + set last_arg_was_paramflag 0 + } + #skip - don't eat + } + } + } + incr a_index + } + + if {![$objp found_match]} { + + #after break - we have retained vars: $parent, $sub_operand $pinfo $processorname etc + #didn't find an unflagged var - set a default if one was specified. + #do nothing otherwise - check_args will determine if it was -required etc. + #review - should only apply if parent cmd found something? + if {[dict exists $pinfo default]} { + set defaultval [dict get $pinfo default] + if {$is_p_flag} { + if {$is_sub} { + dict set extra_flags_from_positionals $p_sub $defaultval + } else { + dict set extra_flags_from_positionals $processorname $defaultval + } + #lappend moved_to_flagged $processorname $defaultval + lappend implied_flagged $processorname $defaultval + do_debug 3 $debugc "SETTING DEFAULT varname:$processorname $defaultval implied_flagged: $implied_flagged " + } else { + lappend implied_unflagged $processorname $defaultval + dict set unflagged $processorname $defaultval + do_debug 3 $debugc "SETTING DEFAULT varname:$processorname $defaultval moved_to_flagged: $moved_to_flagged " + } + + if {$is_sub && !$sub_operand} { + if {[dict exists $dispatch $parentname]} { + add_dispatch_argument "dispatch" $parentname $processorname $defaultval + } else { + lappend argerrors [list subcommand_unable_to_add_default_operand $processorname $defaultval] + } + } + } + } + + if {[$objp name] eq "tail_processor"} { + $VMAP update_map_from [$objp get_map_object] + } + + if {[llength $argerrors]} { + set parsestatus "error" + #abort processing at first error - we won't be able to make sense of the remaining args anyway + #even the tail_processor won't be able to classify reliably because flag meanings depend on the configured commands + break + } + } + + #assertion - should be none? + #set remaining_values [lrange $source_values $a_index end] + #do_debug 3 $debugc "-------->________>end of processing - remaining vals $remaining_values" + + do_debug 2 $debugc "========>=========>originals : $values" + do_debug 2 $debugc "[$VMAP get_map]" + do_debug 2 $debugc "========>=========>unconsumed: $unconsumed_flags_and_values" + + + + + + set all_flagged [$VMAP get_merged_flagged_by_class *] + set all_flagged_plus [concat $all_flagged $extra_flags_from_positionals] + + set all_flagged_list [$VMAP get_list_flagged_by_class *] + set all_flagged_list [concat $all_flagged_list $extra_flags_from_positionals] + + set remaining_flagged [$VMAP get_merged_flagged_by_class "unallocated"] + + set remaining_flagged_list [$VMAP get_list_flagged_by_class "unallocated"] + + + set unflagged_list_in_processing_order [dict values $unflagged] + set unflagged_list [$VMAP get_list_unflagged_by_class *] + + set unflagged_list_remaining [$VMAP get_list_unflagged_by_class "unallocated"] + + return [dict create \ + listremaining $unconsumed_flags_and_values \ + parseerrors $argerrors \ + parsestatus $parsestatus \ + flagged $all_flagged_plus \ + flaggedlist $all_flagged_list \ + flaggedremaining $remaining_flagged \ + flaggedlistremaining $remaining_flagged_list \ + unflagged $unflagged \ + unflaggedlist $unflagged_list \ + unflaggedremaining $remaining_unflagged \ + unflaggedlistremaining $unflagged_list_remaining \ + flaggednew $extra_flags_from_positionals \ + arglist [concat $unflagged_list_in_processing_order $all_flagged] \ + arglistremaining [concat $unflagged_list_remaining $remaining_flagged] \ + impliedflagged $implied_flagged \ + impliedunflagged $implied_unflagged \ + dispatch $dispatch \ + classifications [$VMAP get_map] \ + gridstring "\n[$VMAP grid]" \ + vmapobject "flagfilter::VMAP_$runid" \ + ] + } + + + + + + + + + + + + #specialisation for collection class to contain commandprocessors + # we expect to use only a single instance of this + oo::class create col_allprocessors { + superclass oolib::collection + variable o_commandspecs + method add_processor {p} { + my add $p [$p name] + if {[$p is_sub]} { + set parentname [$p parentname] + set obj_parent [my item $parentname] + set col_siblings [$obj_parent children] + $col_siblings add $p [$p name] + } + } + method set_commandspecs {cspecs} { + set o_commandspecs $cspecs + } + method get_commandspecs {} { + set o_commandspecs + } + #treating as singleton.. todo tidy + method name_from_record {rec} { + lassign $rec parentname pinfo + if {[dict exists $pinfo sub]} { + set name [join [list $parentname [dict get $pinfo sub]] .] + } else { + set name $parentname + } + return $name + } + method object_from_record {rec} { + set name [my name_from_record $rec] + return [my item $name] + } + #basic check if arg may consume the following one - not based on any specific info from processors + method arg_appears_standalone {f} { + if {(![string match "-*" $f]) && (![string match "/*" $f])} { + #not even flaglike + return 1 + } + if {$f in {- --}} { + return 1 + } + } + #does any processor define it as solo + method flag_can_be_solo {f} { + foreach objp [my items] { + if {[$objp arg_is_defined_solo_to_me $f]} { + return 1 + } + } + return 0 + } + } + oo::class create col_parents { + superclass oolib::collection + method add_parent {p} { + if {[$p is_sub]} { + error "cannot add a sub-processor to the main parents collection" + } + my add $p [$p name] + } + } + #each parent processor has a children collection which can only accept processors with sub defined. + oo::class create col_childprocessors { + superclass oolib::collection + variable o_ownername + method set_owner {parentname} { + set o_ownername $parentname + } + #owner of the collection (a parent processor) + method owner {} { + return $o_ownername + } + method add_processor {p} { + if {![$p is_sub]} { + error "processor must have 'sub' element to add to the parent's collection" + } + #check name matches this parent.. + + my add $p [$p name] + } + } + + #todo - rename 'cprocessor' is misleading + oo::class create cprocessor { + variable o_runid + variable o_name + variable o_definition + variable o_pinfo + variable o_parentname + variable o_is_sub + variable o_col_children + variable o_mashopts + variable o_singleopts + variable o_pairopts + variable o_longopts + variable o_found_match ;#we directly matched a command trigger or positional argument + variable o_matched_argument + variable o_matched_argnum + variable o_matchspec + variable o_vmap + constructor {definition runid} { + set o_vmap "" + set o_definition $definition + set o_runid $runid + if {([llength $o_definition] < 2) || ([llength [lindex $o_definition 0]] != 1)} { + error "[self class].constructor Unable to interpret definition '$o_definition'" + } + lassign $o_definition o_parentname o_pinfo + if {([llength $o_pinfo] %2) != 0} { + error "[self class].constructor second element of definition '$o_definition' not a dict" + } + set o_is_sub [dict exists $o_pinfo sub] + if {!$o_is_sub} { + set o_name $o_parentname + set o_col_children [::flagfilter::col_childprocessors new] + $o_col_children set_owner $o_name + } else { + set o_name [join [list $o_parentname [dict get $o_pinfo sub]] .] + } + if {[dict exists $o_pinfo match]} { + set o_matchspec [dict get $o_pinfo match] + } else { + #review - unix paths? conflict with windows style flag such as /w + #must accept empty string + set o_matchspec {^[^-^/].*|^$} ;#match anything that isn't flaglike + } + set o_found_match 0 + set o_matched_argument "" ;#need o_found_match to differentiate match of empty string + set o_matched_argnum -1 + #load mashopts etc at construction time as they're static + set o_mashopts [list] + set o_singleopts [list] + set o_pairopts [list] + set o_longopts [list] + if {[dict exists $o_pinfo mashopts]} { + lappend o_mashopts {*}[dict get $o_pinfo mashopts] + } + if {[dict exists $o_pinfo singleopts]} { + lappend o_singleopts {*}[dict get $o_pinfo singleopts] + } + if {[dict exists $o_pinfo pairopts]} { + lappend o_pairopts {*}[dict get $o_pinfo pairopts] + } + if {[dict exists $o_pinfo longopts]} { + lappend o_longopts {*}[dict get $o_pinfo longopts] + } + } + destructor { + catch {$o_vmap destroy} + if {!$o_is_sub} { + $o_col_children destroy + } + } + + method name {} { + return $o_name + } + #open things up during oo transition.. + method get_def {} { + return $o_definition + } + method is_flag {} { + if {[my is_sub]} { + #sub can be a flag even if parent isn't + set subname [dict get $o_pinfo sub] + return [string match -* $subname] + } else { + return [string match -* $o_name] + } + } + method has_same_parent {other} { + return [expr {[other parentname] eq $o_parentname}] + } + method is_sub {} { + return $o_is_sub + } + + method set_map_object {map} { + set o_vmap $map + } + method get_map_object {} { + return $o_vmap + } + method allocate {argnum type val} { + if {$o_vmap eq ""} { + error "[self class].allocate ($o_name) vmap is not set." + } + $o_vmap allocate [self object] $argnum $type $val + } + + method found_match {} { + return $o_found_match + } + method matched_argument {} { + return $o_matched_argument + } + method matched_argnum {} { + return $o_matched_argnum + } + method set_matched_argument {argnum a} { + #could be empty string + if {$o_found_match} { + error "[self object].set_matched_argument processor:$o_name already found match '$o_matched_argument' - cannot set again" + } + if {![my can_match $a]} { + error "error [self class].set_matched_argument processor:$o_name cannot match '$a' (matchspec: $o_matchspec)" + } + set o_found_match 1 + set o_matched_argument $a + set o_matched_argnum $argnum + } + method has_explicit_matchspec {} { + return [dict exists $o_pinfo match] + } + method matchspec {} { + return $o_matchspec + } + method can_match {a} { + if {!$o_found_match} { + foreach m $o_matchspec { + if {[regexp -- $m $a]} { + return 1 + } + } + return 0 + } else { + return 0 + } + } + #?? + method can_allocate_flags {} { + } + + + + + + #if we are a parent - this is own name + method parentname {} { + return $o_parentname + } + method parent {} { + return [::flagfilter::obj::PARENTS_$o_runid item $o_parentname] + } + method is_parent {} { + return [expr {!$o_is_sub}] + } + method children {} { + if {!$o_is_sub} { + return $o_col_children + } else { + #raise error? + return "" + } + } + method mashopts {} { + return $o_mashopts + } + method singleopts {} { + return $o_singleopts + } + method pairopts {} { + return $o_pairopts + } + method longopts {} { + return $o_longopts + } + + #whether flag categorized as solo by this processor + method arg_is_defined_solo_to_me {a} { + if {(![string match "-*" $a]) && (![string match "/*" $a])} { + #not even flaglike + return 0 + } + if {[my can_match $a]} { + return 0 + } + if {$a in {- --}} { + #specials not defined as solos + return 0 + } + + if {$o_name eq "global"} { + + } elseif {$o_name eq "tail_processor"} { + + } + + if {$a in $o_singleopts} { + return 1 + } + if {"any" in $o_singleopts} { + return 1 + } + set equalposn [string first "=" $a] + if {$equalposn >=1} { + if {"any" in $o_longopts} { + return 1 + } else { + set namepart [string range $a 0 $equalposn-1] + foreach lo $o_longopts { + if {[string match "${namepart}=*" $lo]} { + return 1 + } + } + } + } + #Flag could still be part of a solo if it is in mashopts *and* has a value following it as part of the mash + #- but if it's a pairopt, but not mashable - we can rule it out now + if {($a in $o_pairopts) && ($a ni $o_mashopts)} { + return 0 + } + set flagletters [split [string range $a 1 end] ""] + set posn 1 + #trailing letters may legitimately not be in mashopts if they are part of a mashed value + #we can return 0 if we hit a non-mash flag first.. but at each mashflag we need to test if we can classify as definitely solo or not, or else keep processing + foreach l $flagletters { + if {"-$l" ni $o_mashopts} { + #presumably an ordinary flag not-known to us + return 0 + } else { + if {"-$l" in $o_pairopts} { + if {$posn == [llength $flagletters]} { + #in pairopts and mash - but no value for it in the mash - thefore not a solo + return 0 + } else { + #entire tail is the value - this letter is effectively solo + return 1 + } + } elseif {"-$l" in $o_singleopts} { + #not allowed to take a value - keep processing letters + } else { + #can take a value! but not if at very end of mash. Either way This is a solo + return 1 + } + } + } + #This object should not treat the flag as a known solo + #- so if it is allowed to consume it, it may fall back on examining the subsequent argument's flaginess(?) + return 0 + } + + + method get_opts {} { + return [list mashopts $o_mashopts singleopts $o_singleopts pairopts $o_pairopts longopts $o_longopts] + } + #include parent opts + #we use the terminology 'option' for "-" prefixed items belonging to a -commandprocessors spec as opposed to more general -flags + #Note - this may also be called on the default "tail_processor", which will return empty sets, or an overridden tail_processor which may have data + method get_combined_opts {} { + set objparent [::flagfilter::obj::PARENTS_$o_runid item $o_parentname] + set parentopts [$objparent get_opts] + set mashopts [dict get $parentopts mashopts] + set singleopts [dict get $parentopts singleopts] + set pairopts [dict get $parentopts pairopts] + set longopts [dict get $parentopts longopts] + if {[my is_sub]} { + #this spec is a sub + set subopts [my get_opts] + #does order matter? could use struct::set union ? + foreach m [dict get $subopts mashopts] { + if {$m ni $mashopts} { + lappend mashopts $m + } + } + foreach s [dict get $subopts singleopts] { + if {$s ni $singleopts} { + lappend singleopts $s + } + } + foreach po [dict get $subopts pairopts] { + if {$po ni $pairopts} { + lappend pairopts $po + } + } + foreach lo [dict get $subopts longopts] { + if {$lo ni $longopts} { + lappend longopts $lo + } + } + + } + return [list mashopts $mashopts singleopts $singleopts pairopts $pairopts longopts $longopts] + } + + } + + + + + + + + + + + + proc get_command_info {cmdname cspecs} { + foreach item $cspecs { + lassign $item cmd specinfo + if {$cmd eq $cmdname && [dict exists $specinfo dispatch]} { + return $specinfo + } + } + return [list] + } + #### check_flags + # does not support unvalued flags - unless explicitly specified in -soloflags (global) or in -singleopts for a commandprocessor + #e.g not supported: v1 v2 -arg1 arg1val -debug -anotherflag anotherflagval + # - unless -soloflags is something like -soloflags {-debug} or -soloflags {{-debug 1}} where 1 is the default. In this case - we can no longer support accepting a value for -soloflags - the processor will not assign it an argument from the commandline. + #e.g not supported (unless -debug in -soloflags): v1 v2 -arg1 arg1val -anotherflag anotherflagval -debug + #e.g supported: v2 v2 -arg1 arg1val -debug 1 -anotherflag anotherflagval + # supports positional arguments - but only if specified in -commandprocessors + # todo + # - supports -- for treating following arg as value even if it looks like a flag + # - supports - for reading stdin + # expects at least -values + # other options -caller -defaults -required -extras -commandprocessors + # -soloflags (these are flags that *must* be solo - ie they cannot take an argument ) if no default specified they are boolean defaulting to 1, repeated instances in -values will be appended to a list. + # The only flag that can be a mix of solo or not, is the very last flag in the values list. In this case it must not be in the -soloflags list, but it will default to a boolean 1 to indicate presence. + proc check_flags {args} { + set runid [flagfilter::get_new_runid] + #################################################### + #puts "Entered checkflags, args $args" + set distanceToTop [info level] + set callerlist [list] + set was_dispatched_by_another 0 ;#used to + for {set i 1} {$i < $distanceToTop} {incr i} { + set callerlevel [expr {$distanceToTop - $i}] + set callerinfo [info level $callerlevel] + set firstword [lindex $callerinfo 0] + if {[string match "*check_flags*" $firstword]} { + set was_dispatched_by_another 1 + } + lappend callerlist $firstword + } + #puts stdout "callerlist: $callerlist" + + #first handle args for check_flags itself + if {[catch {lindex [info level -1] 0} caller]} { + set caller "" + } + #puts stderr ">>>>check_flags caller $caller" + get_one_paired_flag_value {-x 1} -x ;# + + #manually check for -caller even if unbalanced args + #we only need to use get_one_paired_flag_value because we haven't yet checked args is a properly formed paired list and if -caller is present we want to use it for clearer error messages. + #use normal dict operations to retrieve other flags. + #if failed to retrieve.. fall through to checks below + if {![catch {get_one_paired_flag_value $args -caller} flag_value_result]} { + set caller $flag_value_result + } + #puts stderr ">>>>check_flags caller $caller" + + + + + set cf_defaults [dict create\ + -caller $caller\ + -return [list arglistremaining]\ + -match [list]\ + -commandprocessors [list]\ + -soloflags [list]\ + -extras [list]\ + -defaults [list]\ + -required [list]\ + -values \uFFFF\ + -debugargs 0\ + ] + dict set cf_defaults -debugargsonerror 1 ;#error level to use when dispatch error occurs.. will not set lower than -debugargs + + + + if {([llength $args] % 2) != 0} { + do_error "check_flags error when called from '$caller' :check_flags must be called with even number of arguments of form: -flag value Valid flags are: '[dict keys $cf_defaults]' \n got: $args" + } + set cf_args $cf_defaults + foreach {k v} $args { + switch -- $k { + -caller - -return - -match - -commandprocessors - -soloflags - -extras - -defaults - -required - -values - -debugargs - -debugargsonerror { + dict set cf_args $k $v + } + default { + do_error "check_flags error when called from ${caller}: Unknown option '$k': must be one of '[dict keys $cf_defaults]' \nIf calling check_flags directly, put args being checked in -values {...}" + } + } + } + unset args + #################################################### + #now look at -values etc that check_flags is checking + + set caller [dict get $cf_args -caller] + + set debugargs [dict get $cf_args -debugargs] + dict set debugc -debugargs [dict get $cf_args -debugargs] + dict set debugc -source "check_flags $caller" + do_debug 1 $debugc "DEBUG-START $caller" + + set returnkey [dict get $cf_args -return] + set defaults [dict get $cf_args -defaults] + if {([llength $defaults] % 2) != 0} { + do_error "check_flags error when called from '$caller' :-defaults must be a list containing an even number of arguments of form: -flag value'" + } + set required [dict get $cf_args -required] + + + set acceptextra [dict get $cf_args -extras] + + set supplied [string trim [dict get $cf_args -values]] + set soloflags [dict get $cf_args -soloflags] ;#By their nature - solo flags are unlikely to be automatically 'required' - review + set solos_with_defaults [list] + foreach solo_spec $soloflags { + if {[llength $solo_spec] == 1} { + lappend solos_with_defaults $solo_spec 1 + } else { + lappend solos_with_defaults [lindex $solo_spec 0] [lindex $solo_spec 1] + } + + } + + if {$debugargs >= 3} { + set prefix "| $caller>" + puts -nonewline stderr "$prefix [string repeat - 30]\n" + puts -nonewline stderr "$prefix input\n" + puts -nonewline stderr "$prefix [string repeat - 30]\n" + #puts stderr "$caller $cf_args" + dict for {k v} $cf_args { + if {$k ne "-commandprocessors"} { + puts -nonewline stderr "$prefix \[$k\]\n" + puts -nonewline stderr "$prefix $v\n" + } + } + if {$debugargs >=4} { + puts -nonewline stderr "$prefix \[-commandprocessors\]\n" + foreach record [dict get $cf_args -commandprocessors] { + puts -nonewline stderr "$prefix $record\n" + } + } + puts -nonewline stderr "$prefix [string repeat - 30]\n" + #dict for {key val} $cf_args { + # puts stderr " $key" + # puts stderr " $val" + #} + } + + + ################################################################################################## + # allocate_arguments does the main work of processing non-flagged items in the main supplied argument list into flagged versions depending on the specs in -commandprocessors + # It sets defaults only for those arguments processed by a '-commandprocessors' spec. + # We must supply it with the -soloflags info because the solo flags affect what is considered an operand. + set command_specs [dict get $cf_args -commandprocessors] ;#may be empty list - that's ok - it will still populate the 'flagged' and 'arglist' return-dict members. + + #some of these are keys returned by allocate_arguments + # - some (e.g supplied) are added by check_flags + # This list is the list of -return values that can be used with check_args + set flaginfo_returns [list \ + parseerrors \ + parsestatus \ + flagged \ + flaggedremaining \ + flaggednew \ + unflagged \ + unflaggedremaining \ + unflaggedlistremaining \ + listremaining \ + arglist \ + arglistremaining \ + impliedunflagged \ + impliedflagged \ + classifications \ + gridstring \ + ranges \ + dispatch \ + dispatchstatuslist \ + dispatchresultlist \ + dispatchstatus \ + supplied \ + defaults \ + status \ + vmapobject \ + ] + + set PROCESSORS [col_allprocessors create ::flagfilter::obj::PROCESSORS_$runid] + set PARENTS [col_parents create ::flagfilter::obj::PARENTS_$runid] + + # + #set command_specs [concat [list {global {}}] $command_specs] + lappend command_specs {tail_processor {}} + + foreach cspec $command_specs { + set obj [cprocessor new $cspec $runid] ;#runid gives access to the context-objects PROCESSORS_runid & PARENTS_runid + if {[$obj is_parent]} { + $PARENTS add_parent $obj + } + #do_debug 1 $debugc "CONFIGURING OBJECT for commandprocessor [$obj name]" + $PROCESSORS add_processor $obj + } + do_debug 1 $debugc "ADDED [$PROCESSORS count] processors to main commandprocessor collection" + do_debug 1 $debugc "ADDED [$PARENTS count] processors to the parents collection" + $PROCESSORS set_commandspecs $command_specs + + #allocate_arguments uses the PROCESSORS object + set processed_arguments [allocate_arguments $PROCESSORS $solos_with_defaults $supplied $cf_args $caller] + #set processed_arguments [allocate_arguments {} $supplied] + + set newly_flagged_positionals [dict get $processed_arguments flaggednew] + set unflaggedremaining [dict get $processed_arguments unflaggedremaining] + set unflaggedlistremaining [dict get $processed_arguments unflaggedlistremaining] + set dispatch [dict get $processed_arguments dispatch] + set flaggedremaining [dict get $processed_arguments flaggedremaining] + set RETURNED_VMAP [dict get $processed_arguments vmapobject] + + + + if {$debugargs >= 3} { + set prefix "| $caller>" + puts -nonewline stderr "$prefix [string repeat - 30]\n" + puts -nonewline stderr "$prefix output\n" + puts -nonewline stderr "$prefix [string repeat - 30]\n" + #puts stderr "processed_arguments: $processed_arguments" + dict for {key val} $processed_arguments { + puts -nonewline stderr "$prefix $key\n" + puts -nonewline stderr "$prefix $val\n" + } + puts -nonewline stderr "$prefix [string repeat - 30]\n" + } + + ################################################################################################## + + + + + + if {![llength $newly_flagged_positionals]} { + if {($supplied eq "\uFFFF") || ![llength $supplied]} { + #do_error "check_flags error when called from ${caller}: missing or empty -values" + } + } + + #probably not something to enforce... we might pass on unbalanced lists to other check_args etc. + #if {([llength $supplied] % 2) != 0} { + # do_error "${caller}: Error. $caller must be called with even number of arguments of form: -flag value Valid flags are: '[dict keys $defaults]'\n received values: $supplied" + #} + + + + set new_arg_list [dict get $processed_arguments arglistremaining] + set flagged_list [dict get $processed_arguments flagged] + #set suppliedkeys_with_extrakeys [concat [dict keys $supplied] [dict keys $newly_flagged_positionals]] + #puts stdout "suppliedkeys and new keys: $suppliedkeys_with_extrakeys" + + #todo - add flaggednew to required if all was specified? + #check invalid flags if not indicated in -extras , either explicitly or with 'extra' + set flags_from_required [get_flagged_only $required {}] + #set known_flags [lsort -unique -nocase [concat [dict keys $defaults] $flags_from_required $soloflags]] ;#why -nocase? why should -l and -L collapse to the uppercase version? + set known_flags [punk::lib::lunique_unordered [concat [dict keys $defaults] $flags_from_required $soloflags ]] + foreach spec $command_specs { + lassign $spec parentname pinfo + if {[string match -* $parentname] && $parentname ni $known_flags} { + lappend known_flags $parentname + } + if {[dict exists $pinfo sub]} { + if {[string match -* [dict get $pinfo sub]]} { + lappend known_flags [dict get $pinfo sub] + } + } + } + do_debug 2 $debugc "------------------->known_flags: $known_flags soloflags:$soloflags" + set invalid_flags [list] + if {"all" ni [string tolower $acceptextra]} { + if {"none" in [string tolower $acceptextra]} { + set ok_extras [list] + } elseif {[llength $acceptextra]} { + set ok_extras $acceptextra + } + #todo + #puts stderr " check_flags - temporary disable of checking for invalid flags" + set pairflagged $flagged_list + foreach {f v} $pairflagged { + if {$f ni $acceptextra && $f ni $known_flags} { + lappend invalid_flags $f + } + } + } + if {[llength $invalid_flags]} { + do_error "check_flags $caller error when called from ${caller}: unknown flags '$invalid_flags'" + } + + set calc_required [list] + set keywords_in_required [lsearch -inline -all -not $required -*] + set bad_keywords_in_required [lsearch -regexp -nocase -all -inline -not $keywords_in_required "all|none"] + if {[llength $bad_keywords_in_required]} { + do_error "check_flags error when called from ${caller}: bad flags in '-required' it must be a list of flags of the form -flagname or ONLY one of the keywords 'none' or 'all'" + } + #keywords_in_required now known to be only comprised of (possibly case variant) values of all|none + if {[llength $keywords_in_required] > 1} { + do_error "check_flags error when called from ${caller}: specifying both 'none' and 'all' in -required is not valid, and repeated values are not valid." + } + if {"none" eq [string tolower [lindex $keywords_in_required 0]]} { + set calc_required [list] + } + set flags [lsearch -inline -all $required -*] + + if {[llength $required]} { + if {[lsearch -nocase $keywords_in_required "all"] >= 0} { + #'all' can be present with other flags - and indicates we also require all the flags from -defaults + dict for {k -} $defaults { + if {$k ni $calc_required} { + lappend calc_required $k + } + } + } + } + + set classifications [dict get $processed_arguments classifications] ;#assertion - ordered by numerically increasing key representing positions in supplied argument list + set rangesets [$RETURNED_VMAP get_ranges_from_classifications $classifications] + set ranges [dict get $rangesets -ranges] + set rangesbytype [dict get $rangesets -rangesbytype] ;#unallocated are split into flag,operand and endofoptions - further splitting is easy enough to do by looking up the classifications list for each position in the supplied arg list. + #tailflags are the same for all dispatch items + set tailflagspaired [tailflagspaired $defaults $supplied $classifications $rangesbytype] + + + set dict_supplied [dict create supplied $supplied] + set dict_defaults [dict create defaults $defaults] + set dict_ranges [dict create ranges $ranges] + set dict_rangesbytype [dict create rangesbytype $rangesbytype] + set raise_dispatch_error_instead_of_return "" + set dict_dispatch_results [list dispatchstatuslist [list] dispatchresultlist [list] dispatchstatus "ok"] + #todo - only dispatch if no unallocated args (must get tail_processor to allocate known flags to 'global') + + if {[llength $dispatch]} { + set dispatchstatuslist [list] + set dispatchresultlist [list] + set dispatchstatus "ok" + #each dispatch entry is a commandname and dict + #set dispatchrecord [lrange $dispatch 0 1] + set re_argnum {%arg([0-9^%]+)%} + set re_argtake {%argtake([0-9^%]+)%} + set re_dquotedparts {(?:(?:\"[^\"]*\")|(?:\"[^\"]*"))|(?:\S*[^ \"])} ;#for use with regexp -all -inline + #e.g {"a b" 'b x' "x cd "e f" g a} -> {"a b"} 'b x' {"x cd "} e f {" g a} + #dumb-editor rebalancing quote for above comment " + foreach {parentname dispatchrecord} $dispatch { + set commandinfo [get_command_info $parentname $command_specs] + + do_debug 1 $debugc ">>>>>DISPATCHRECORD: $dispatchrecord" + + # e.g lscmd lscmd natsortcommandline_ls lscmd.dir x + + do_debug 2 $debugc "commandinfo for $parentname: $commandinfo" + set command [dict get $dispatchrecord command] + #support for %x% placeholders in dispatchrecord command + set command [string map {%match% %matched%} $command] ;#alias + set command [string map [list %matched% [dict get $dispatchrecord matched]] $command] + + set argnum_indices [regexp -indices -all -inline $re_argnum $command] + if {[llength $argnum_indices]} { + foreach {argx_indices x_indices} $argnum_indices { + #argx eg %arg12% + set argx [string range $command {*}$argx_indices] + set x [string range $command {*}$x_indices] + set command [string map [list $argx [lindex [dict get $dispatchrecord arguments] $x]] $command] + } + } + + set argsreduced [dict get $dispatchrecord arguments] + #set rawparts [regexp -all -inline $re_dquotedparts [dict get $dispatchrecord raw]] + + #review! + #how will this behave differently on unix + package require punk::winrun + set rawparts [punk::winrun::unquote_wintcl [dict get $dispatchrecord raw]] + #set argtake_indices [regexp -indices -all -inline $re_argtake $command] + + + set start 0 + while {[regexp -start $start -indices $re_argtake $command argx_indices x_indices]} { + #argx eg %argtake12% + set argx [string range $command {*}$argx_indices] + set x [string range $command {*}$x_indices] + set argval [lindex [dict get $dispatchrecord arguments] $x] + set replacementlen [string length $argval] + set command [string map [list $argx $argval] $command] + set start [expr {[lindex $argx_indices 0] + $replacementlen}] + set argsreduced [lremove $argsreduced $x] + set rawparts [lremove $rawparts $x] + } + dict set dispatchrecord arguments $argsreduced + if {$start > 0} { + set rawreduced [join $rawparts] + dict set dispatchrecord raw $rawreduced + } + + set argvals [dict get $dispatchrecord arguments] + set matched_operands [list] + set matched_opts [list] + set matched_in_order [list] + set prefix "${parentname}." + set prefixlen [string length $prefix] + foreach {k v} $argvals { + #puts "$$$$ $k" + if {[string equal -length $prefixlen $prefix $k]} { + #key is prefixed with "commandname." + set k [string replace $k 0 $prefixlen-1] + } + #todo - -- ? + if {[string match -* $k]} { + lappend matched_opts $k $v + lappend matched_in_order $k $v + } else { + set kparts [split $k .] + lappend matched_operands $v + lappend matched_in_order $v + } + } + + if {![dict exists $commandinfo dispatchtype]} { + set dispatchtype tcl + } else { + set dispatchtype [dict get $commandinfo dispatchtype] + } + if {![dict exists $commandinfo dispatchglobal]} { + if {$dispatchtype eq "tcl"} { + set dispatchglobal 1 + } else { + set dispatchglobal 0 + } + } else { + set dispatchglobal [dict get $commandinfo dispatchglobal] + } + #generally we only want to dispatch remaining flagged, and only at the tail end.(as opposed to flags occurring between command groups) + # -It doesn't usually make much sense to dispatch remaining unflagged items, and it would be rare to require flags occurring before the command. + #however - there are potential commands such as help, dryrun or maybe an analysis command that may need to see unconsumed operands or even look 'back' at prior items + ##update 2023-03 - we definitely want to look back to prior non-matches when we match on a script e.g tclsh8.6 -someflag etc xxx.tcl scriptarg1 -etc + # if we match and dispatch on *.tcl - then we may need 'tclsh8.6 -someflag etc' as the interpreter (possibly with arguments) to use. + # we may need a 'script' dispatchtype (as well as the option to just pass these prior arguments as additional options for some other dispatchtypes) + # + # todo - add supported dispatchglobal values such as all, pre, post, allpre, allpost, and classifications + # where pre & post are only those occurring directly before and after the command and its args, i.e not extending beyond any prior or subsequent other command. + # classifications would be flagged as -classifications $classifications whereas pre and post would be added directly if specified singly, or flagged with -pre, -post etc if multiple are specified + # Those beginning with 'all' should also be wrapped in flags, because potentially they come from disjointed sections of the argumentlist + # - and we generally shouldn't supply arguments next to each other that weren't contiguous in the original list + # The 1,true,yes,tailflagspaired value is designed for the usecase where a common set of tail flags e.g -debug can apply to any commands matched by the filter. + # tail = all unallocated args after final command, including operands and end-of-options '--' (todo) + # tailflags = all unallocated *contiguous* flags after the final command and final operands. (ie it will deliberately miss flags following last command if there is a later operand) (todo) + # tailflagspaired = same as tailflags, but any solo-flags are defaulted to 1 (flags not merged, so there might be duplicate keys) so that it's a fully paired list + # In other situations - post may make sense to get the very next set of unconsumed arguments. + if {[string tolower $dispatchglobal] in [list 1 true yes tailflagspaired]} { + set command_range_posn [lsearch -index 1 $ranges $parentname] + set extraflags $tailflagspaired + } else { + set extraflags [list] + } + + #jn concat allows $command to itself be a list + ##tcl dispatchtype + dict set dispatchrecord dispatchtype $dispatchtype + switch -- $dispatchtype { + tcl { + do_debug 1 $debugc "DISPATCHING with tcl arg order: $command $matched_operands $matched_opts $extraflags" + #set commandline [list $command {*}$matched_operands {*}$matched_opts {*}$extraflags] + set commandline [concat $command $matched_operands $matched_opts $extraflags] + } + raw { + do_debug 1 $debugc "DISPATCHING with raw args : $command [dict get $dispatchrecord raw]" + #set commandline [list $command {*}[dict get $dispatchrecord raw] {*}$extraflags] + set commandline [concat $command [dict get $dispatchrecord raw] $extraflags] + } + shell { + do_debug 1 $debugc "DISPATCHING with shell args : $command [dict get $dispatchrecord raw]" + #assume the shell arguments are in one quoted string? + set commandline [concat $command [list [dict get $dispatchrecord raw]] $extraflags] + } + default { + #non quoted shell? raw + defaults? + do_debug 1 $debugc "DISPATCHING with given arg order: $command $matched_in_order $extraflags" + #set commandline [list $command {*}$matched_in_order {*}$extraflags] + set commandline [concat $command $matched_in_order $extraflags] + } + } + + + + + dict set dispatchrecord asdispatched $commandline + set dispatchresult "" + set dispatcherror "" + if {![catch {{*}$commandline} cmdresult]} { + set dispatchresult $cmdresult + lappend dispatchstatuslist [list status ok cmd $parentname outputlength [string length $cmdresult]] + lappend dispatchresultlist $cmdresult + } else { + set dispatchstatus "error" + set dispatcherror $cmdresult + #don't add to dispatchresultlist + lappend dispatchstatuslist [list status err cmd $parentname outputlength 0 error $cmdresult] + if {!$was_dispatched_by_another} { + #this is the first (or a direct) call to check_flags - so make sure error gets raised in this proc rather than just storing the error in the data and returning + set raise_dispatch_error_instead_of_return "dispatchstatuslist:\n[join $dispatchstatuslist \n] \nerrinfo:\n $::errorInfo" + dict set dispatchrecord result $dispatchresult + dict set dispatchrecord error $dispatcherror + dict set dispatch $parentname $dispatchrecord + + break + #return -code error "check_flags error during command dispatch:\n$cmdresult" + } + #we've been dispatched from another check_flags - so ok to propagate the error up via the dispatchrecord/dispatchstatuslist + } + dict set dispatchrecord result $dispatchresult + dict set dispatchrecord error $dispatcherror + dict set dispatch $parentname $dispatchrecord + } + + set dict_dispatch_results [list dispatchcaller $caller dispatchstatuslist $dispatchstatuslist dispatchresultlist $dispatchresultlist dispatchstatus $dispatchstatus] + } + #end llength $dispatch + + + set combined [dict merge $dict_defaults $dict_supplied $processed_arguments $dict_ranges $dict_rangesbytype $dict_dispatch_results] + dict set combined dispatch $dispatch ;#update with asdispatched info + if {([dict get $combined parsestatus] eq "ok") && ([dict get $combined dispatchstatus] eq "ok")} { + dict set combined status "ok" + } else { + dict set combined status "error" + } + do_debug 1 $debugc "COMBINED:$combined" + + + set returnkey [string tolower $returnkey] + if {"all" in $returnkey} { + set returnval $combined + #set returnval [dict merge $combined $dict_dispatch_results] + } else { + if {[llength $returnkey] == 1} { + set invalid 0 + #todo - support multiple merge? + set right "" + if {[regexp -all {\|} $returnkey] == 1} { + lassign [split $returnkey |] left right + set joinparts [split $left ,] + } else { + set joinparts [split $returnkey ,] + } + foreach j [concat $joinparts $right] { + if {$j ni $flaginfo_returns} { + set invalid 1 + } + } + set returnval [list] + if {!$invalid} { + foreach j $joinparts { + lappend returnval {*}[dict get $combined $j] + } + if {[string length $right]} { + set returnval [dict merge $returnval $defaults $returnval] + } + } else { + set returnval [list callerrors [list "-return '$returnkey' not valid"]] + } + } else { + set callerrors [list] + set returnval [dict create] + foreach rk $returnkey { + if {$returnkey in $flaginfo_returns} { + dict set returnval $rk [dict get $combined $returnkey] + } else { + lappend callerrors [list "-return '$returnkey' not valid"] + } + } + if {[llength $callerrors]} { + dict set returnval callerrors $callerrors + } + } + } + + do_debug 1 $debugc "[string repeat = 40]" + do_debug 1 $debugc "dispatch_results: $dict_dispatch_results" + do_debug 1 $debugc "[string repeat - 40]" + + if {[string length $raise_dispatch_error_instead_of_return]} { + set errdebug [dict get $cf_args -debugargsonerror] + if {$errdebug > [dict get $cf_args -debugargs]} { + dict set debugc -debugargs $errdebug + } + } + + set debuglevel_return 2 + set debugdict [concat {*}[lmap k [dict keys $combined] {list $k $debuglevel_return}]] ;#create a dict of keys from combined, all defaulted to $debuglevel_return + if {[llength [dict get $combined parseerrors]]} { + dict set debugdict "parseerrors" 0 + } else { + dict set debugdict "parseerrors" 2 + } + dict set debugdict "defaults" 1 + dict set debugdict "supplied" 1 + dict set debugdict "dispatch" 1 + dict set debugdict "ranges" 1 + dict set debugdict "rangesbytype" 1 + dict set debugdict "dispatchstatus" 1 + if {[dict get $combined "status"] eq "ok"} { + dict set debugdict "status" 1 + } else { + dict set debugdict "status" 0 + } + + do_debug 1 $debugc "returning '$returnkey'" + do_debug 1 $debugc "returnval '$returnval'" + if {([llength $returnval] % 2) == 0} { + do_debug 1 $debugc "returnkeys '[dict keys $returnval]'" + } + do_debug 1 $debugc "[string repeat = 40]" + dict for {k v} $combined { + set dlev [dict get $debugdict $k] + switch -- $k { + dispatch { + set col1 [string repeat " " 12] + #process as paired list rather than dict (support repeated commands) + set i 0 + foreach {cmdname cmdinfo} $v { + set field1 [string repeat " " [expr {[string length $cmdname]}]] + set col2_dispatch [string repeat " " [expr {[string length $cmdname] + 15}]] + set j 0 + foreach {ckey cval} $cmdinfo { + + if {$i == 0 && $j == 0} { + set c1 [overtype::left $col1 "dispatch"] + } else { + set c1 [overtype::left $col1 { ... }] + } + + if {$j == 0} { + set f1 [overtype::left $field1 $cmdname] + set c2 [overtype::left $col2_dispatch "$f1 $ckey"] + } else { + set f1 [overtype::left $field1 ...] + set c2 [overtype::left $col2_dispatch "$f1 $ckey"] + } + #leave at debug level 1 - because dispatch is generally important + do_debug $dlev $debugc "${c1}${c2} $cval" + + incr j + } + incr i + } + + #do_debug 1 $debugc "[overtype::left $col1 $k] [lindex $v 0] [list [lindex $v 1]]" + #foreach {nm rem} [lrange $v 2 end] { + # do_debug 1 $debugc "[overtype::left $col1 { ... }] $nm [list $rem]" + #} + } + dispatchresultlist { + set col1 [string repeat " " 25] + set i 0 + foreach dresult $v { + if {$i == 0} { + set c1 [overtype::left $col1 $k] + } else { + set c1 [overtype::left $col1 { ... }] + } + do_debug $dlev $debugc "$c1 $dresult" + incr i + } + } + classifications { + set col1 [string repeat " " 25] + set len [dict size $v] + if {$len == 0} { + do_debug $dlev $debugc "[overtype::left $col1 $k]" + continue + } + set max [expr {$len -1}] + set numlines [expr $len / 3 + 1] + if {($len % 3) == 0} { + incr numlines -1 + } + set j 0 + for {set ln 0} {$ln < $numlines} {incr ln} { + if {$ln == 0} { + set c1 "[overtype::left $col1 $k]" + } else { + set c1 "[overtype::left $col1 { ... }]" + } + set line "" + for {set col 0} {$col < 3} {incr col} { + if {$j <= $max} { + append line "$j [list [dict get $v $j]] " + } + incr j + } + do_debug $dlev $debugc "$c1 [string trim $line]" + } + } + gridstring { + set col1 [string repeat " " 25] + set i 0 + foreach ln [split $v \n] { + if {$i == 0} { + set c1 [overtype::left $col1 $k] + } else { + set c1 [overtype::left $col1 { ... }] + } + do_debug $dlev $debugc "$c1 $ln" + incr i + } + } + default { + set col1 [string repeat " " 25] + do_debug $dlev $debugc "[overtype::left $col1 $k] $v" + } + } + } + + + # --------------------------------- + foreach obj [$PARENTS items] { + catch {$obj destroy} + } + $PARENTS destroy + #puts "PROCESSORS: $PROCESSORS" + foreach obj [$PROCESSORS items] { + catch {$obj destroy} + } + $PROCESSORS destroy + catch {$RETURNED_VMAP destroy} + # --------------------------------- + + do_debug 1 $debugc "[string repeat = 40]" + do_debug 1 $debugc "DEBUG-END $caller" + if {[string length $raise_dispatch_error_instead_of_return]} { + return -code error $raise_dispatch_error_instead_of_return + } + + + return $returnval + } + + proc tailflagspaired {defaults supplied classifications rangesbytype} { + lassign [lindex $rangesbytype end] c tp a b + if {($c eq "unallocated") && ($tp eq "flagtype")} { + set tail_unallocated [lrange $supplied $a $b] + } else { + set tail_unallocated [list] + } + #set extraflags [list] + set extraflags [punk::lib::dict_merge_ordered $defaults $tail_unallocated] + #dict merge based operation can't work if there are solo_flags? + #review + if {[llength $tail_unallocated]} { + for {set i $a} {$i <=$b} {incr i} { + set arginfo [dict get $classifications $i] + lassign $arginfo class ftype v + switch -- $ftype { + flag - flagvalue { + lappend extraflags $v + } + soloflag { + lappend extraflags $v + if {[dict exists $defaults $v]} { + lappend extraflags [dict get $defaults $v] + } else { + lappend extraflags 1 + } + } + } + } + foreach {k v} [dict get $defaults] { + if {$k ni $extraflags} { + lappend extraflags $k $v + } + } + } else { + set extraflags $defaults + } + return $extraflags + } + + proc tailflagspaired1 {defaults supplied classifications rangesbytype} { + lassign [lindex $rangesbytype end] c tp a b + if {($c eq "unallocated") && ($tp eq "flagtype")} { + set tail_unallocated [lrange $supplied $a $b] + } else { + set tail_unallocated [list] + } + #set all_post_unallocated_ranges [lsearch -all -inline -index 0 [lrange $rangesbytype $command_range_posn end] "unallocated"] + + set extraflags [list] + + #set extraflags [punk::lib::dict_merge_ordered $defaults $tail_unallocated] + #dict merge based operation can't work if there are solo_flags with no value set + if {[llength $tail_unallocated]} { + for {set i $a} {$i <=$b} {incr i} { + set arginfo [dict get $classifications $i] + lassign $arginfo class ftype v + switch -- $ftype { + flag - flagvalue { + lappend extraflags $v + } + soloflag { + lappend extraflags $v + if {[dict exists $defaults $v]} { + lappend extraflags [dict get $defaults $v] + } else { + lappend extraflags 1 + } + } + } + } + foreach {k v} [dict get $defaults] { + if {$k ni $extraflags} { + lappend extraflags $k $v + } + } + } else { + set extraflags $defaults + } + + } + + + +} + + +namespace eval flagfilter { + + #punk::lib::dict_merge_ordered + + + + #retrieve *only* names that are dependant on the provided namekey - not the key itself + # (query is sorted by the trailing numerical index which represents order the arguments were processed) + proc flag_array_get_sorted_subs {arrname sep namekey} { + upvar $arrname arr + set allsubs [array names arr ${namekey}.*${sep}name,*] + set rnames [lmap nm $allsubs {string reverse $nm}] + set sorted_rnames [lsort -dictionary $rnames] + set ordered [lmap nm $sorted_rnames {string reverse $nm}] + return $ordered + } + + proc flag_array_get_sorted_siblings {arrname sep namekey} { + #determine parent by looking at dot - but confirm parent name is in array. + + } + + + + #dictionary based lsort of reversed names which are presumed to have a trailing separator of some sort and a number e.g: name,0 name,1 ... name,10 etc. + #use -dictionary to ensure embedded numbers are sorted as integers + proc array_names_sorted_by_tail {arrname nameglob} { + upvar $arrname arr + set matched_names [array names arr $nameglob] + set rnames [lmap nm $matched_names {string reverse $nm}] + set sorted_rnames [lsort -dictionary $rnames] + return [lmap nm $sorted_rnames {string reverse $nm}] + } + + +} + +package provide [lassign {flagfilter 0.3.1} pkg ver]$pkg [namespace eval $pkg[set pkg {}] {list [variable version $::ver[set ::ver {}]]$version}] + + + + + diff --git a/src/vfs/_vfscommon.vfs/modules/punk/char-0.1.0.tm b/src/vfs/_vfscommon.vfs/modules/punk/char-0.1.0.tm index c8195b6e..e6bf4b9d 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/char-0.1.0.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/char-0.1.0.tm @@ -186,8 +186,9 @@ tcl::namespace::eval punk::char { set r [list "" {*}[split $lowbits ""] $ridx {*}$charlist] $t add_row $r } - puts stderr $t - $t print + set result [$t print] + $t destroy + return $result } #just the 7-bit ascii. use [page ascii] for the 8-bit layout diff --git a/src/vfs/_vfscommon.vfs/modules/punk/mix/templates/utility/scriptappwrappers/multishell.cmd b/src/vfs/_vfscommon.vfs/modules/punk/mix/templates/utility/scriptappwrappers/multishell.cmd index 82d174a5..7bfca8d4 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/mix/templates/utility/scriptappwrappers/multishell.cmd +++ b/src/vfs/_vfscommon.vfs/modules/punk/mix/templates/utility/scriptappwrappers/multishell.cmd @@ -1,4 +1,4 @@ -: "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^ +: "punk MULTISHELL - shebangless polyglot for Tcl Perl sh bash cmd pwsh powershell" + "[rename set S;proc Hide shell_not_supported {proc $shell_not_supported 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 + \ @@ -16,6 +16,70 @@ set -- "$@" "a=[Hide <#;Hide set;S 1 list]"; set -- : "$@";$1 = @' @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 ------------------------------------------------------------------------------------------------------------------------------- +@rem return from endlocal macro - courtesy of jeb +@rem This allows return of values containing special characters from subroutines +@rem https://stackoverflow.com/questions/3262287/make-an-environment-variable-survive-endlocal/8257951#8257951 +@rem ------------------------------------------------------------------------------------------------------------------------------- +@setlocal DisableDelayedExpansion +@echo off +%= 2 blank lines after next are required =% +set LF=^ + + +set ^"\n=^^^%LF%%LF%^%LF%%LF%^^" +%= I use EDE for EnableDelayeExpansion and DDE for DisableDelayedExpansion =% +set ^"endlocal=for %%# in (1 2) do if %%#==2 (%\n% + setlocal EnableDelayedExpansion%\n% + %= Take all variable names into the varName array =%%\n% + set varName_count=0%\n% + for %%C in (!args!) do set "varName[!varName_count!]=%%~C" ^& set /a varName_count+=1%\n% + %= Build one variable with a list of set statements for each variable delimited by newlines =%%\n% + %= The lists looks like --> set result1=myContent\n"set result1=myContent1"\nset result2=content2\nset result2=content2\n =%%\n% + %= Each result exists two times, the first for the case returning to DDE, the second for EDE =%%\n% + %= The correct line will be detected by the (missing) enclosing quotes =%%\n% + set "retContent=1!LF!"%\n% + for /L %%n in (0 1 !varName_count!) do (%\n% + for /F "delims=" %%C in ("!varName[%%n]!") DO (%\n% + set "content=!%%C!"%\n% + set "retContent=!retContent!"set !varName[%%n]!=!content!"!LF!"%\n% + if defined content (%\n% + %= This complex block is only for replacing '!' with '^!' =%%\n% + %= First replacing '"'->'""q' '^'->'^^' =%%\n% + set ^"content_EDE=!content:"=""q!"%\n% + set "content_EDE=!content_EDE:^=^^!"%\n% + %= Now it's poosible to use CALL SET and replace '!'->'""e!' =%%\n% + call set "content_EDE=%%content_EDE:^!=""e^!%%"%\n% + %= Now it's possible to replace '""e' to '^', this is effectivly '!' -> '^!' =%%\n% + set "content_EDE=!content_EDE:""e=^!"%\n% + %= Now restore the quotes =%%\n% + set ^"content_EDE=!content_EDE:""q="!"%\n% + ) ELSE set "content_EDE="%\n% + set "retContent=!retContent!set "!varName[%%n]!=!content_EDE!"!LF!"%\n% + )%\n% + )%\n% + %= Now return all variables from retContent over the barrier =%%\n% + for /F "delims=" %%V in ("!retContent!") DO (%\n% + %= Only the first line can contain a single 1 =%%\n% + if "%%V"=="1" (%\n% + %= We need to call endlocal twice, as there is one more setlocal in the macro itself =%%\n% + endlocal%\n% + endlocal%\n% + ) ELSE (%\n% + %= This is true in EDE =%%\n% + if "!"=="" (%\n% + if %%V==%%~V (%\n% + %%V !%\n% + )%\n% + ) ELSE IF not %%V==%%~V (%\n% + %%~V%\n% + )%\n% + )%\n% + )%\n% + ) else set args=" + +@rem ------------------------------------------------------------------------------------------------------------------------------- +@SETLOCAL EnableExtensions EnableDelayedExpansion @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 @@ -24,7 +88,6 @@ set -- "$@" "a=[Hide <#;Hide set;S 1 list]"; set -- : "$@";$1 = @' @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 @@ -51,8 +114,6 @@ set -- "$@" "a=[Hide <#;Hide set;S 1 list]"; set -- : "$@";$1 = @' : <> @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 @@ -73,7 +134,7 @@ set -- "$@" "a=[Hide <#;Hide set;S 1 list]"; set -- : "$@";$1 = @' @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 -- deck scriptwrap.checkfile filepath @REM -- to check your templates or final wrapped scripts for byte boundary issues @REM -- It will report any labels that are on boundaries @REM -- This is why the nextshell value above is a 2 digit key instead of a string - so that editing the value doesn't change the byte offsets. @@ -83,12 +144,13 @@ set -- "$@" "a=[Hide <#;Hide set;S 1 list]"; set -- : "$@";$1 = @' @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 -- 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 "winpath=%~dp0" %= e.g c:\punkshell\bin\ %= @SET "fname=%~nx0" +@SET "scriptrootname=%~dp0%~n0" %= e.g c:\punkshell\bin\runtime (full path without extension) unavailable after shift, so store it =% @REM @ECHO fname %fname% @REM @ECHO winpath %winpath% @REM @ECHO commandlineascalled %0 @@ -123,17 +185,6 @@ set -- "$@" "a=[Hide <#;Hide set;S 1 list]"; set -- : "$@";$1 = @' @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 ) @@ -178,25 +229,101 @@ set -- "$@" "a=[Hide <#;Hide set;S 1 list]"; set -- : "$@";$1 = @' @IF "!selected_shelltype_trimmed!"=="none" ( SET selected_shelltype_trimmed=pwsh ) + + + + +@set argCount=30 +@rem This is the max number of args we are willing to handle. also bounded by approx 8k char limit of cmd.exe +@rem We do not loop over %* to count args as it is brittle for some inputs e.g will always skip cmd.exe separators e.g comma and semicolon +@rem Set argCount higher if desired, but there is a small amount of additional looping overhead. + +@set tmpfile_base=%TEMP%\punkbatch_params +@call :getUniqueFile %tmpfile_base% ".txt" paramfile +@echo %paramfile% + +%= NOTE when we loop like this using the percent-n args, we lose unquoted separators such as comma and semicolon %= +@rem https://stackoverflow.com/questions/26551/how-can-i-pass-arguments-to-a-batch-file/5493124#5493124 +@rem outer loop required to redirect all rem lines at once to file +@for %%x in (1) do @( + @for /L %%f in (1,1,%argCount%) do @( + @set "argnum=%%~nf" + @set "a1=%%1" + @rem @set "argname=%%!argnum!" + @rem @echo argname: !argname! + @call :rem_output !argnum! !a1! + @shift + ) +) > %paramfile% +@echo off + +@set "newcommandline= " + +@(set target=cmd_pwsh) +@if "%target%"=="cmd_pwsh" ( + @for /F "delims=" %%L in (%paramfile%) do @( + SETLOCAL DisableDelayedExpansion + set "param=%%L" + @REM @echo ######### %%L + @rem call :buildcmdline newcommandline param "{" "}" + @rem call :buildcmdline newcommandline param ' ' %= cmd.exe /c powershell ... -c %= + call :buildcmdline newcommandline param %= cmd.exe /c powershell ... -f %= + @rem @echo . + ) +) ELSE ( + @for /F "delims=" %%L in (%paramfile%) do @( + SETLOCAL DisableDelayedExpansion + set "param=%%L" + call :buildcmdline newcommandline param + ) +) +@REM padding +SETLOCAL EnableDelayedExpansion + +@echo off +@IF EXIST %paramfile% ( + @DEL /F /Q %paramfile% +) +@IF EXIST %paramfile% ( + echo failed to delete %paramfile% + cat %paramfile% +) + + + +@REM @SET "squoted_args=" +@REM @for %%a in (%*) do @( +@REM set "v=%%a" +@REM set "v=!v:'=''!" +@REM SET "squoted_args=!squoted_args!'!v!' " +@REM ) +@REM @SET "squoted_args=%squoted_args:~0,-1%" +@REM @ECHO %squoted_args% + + @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 + REM when run without cmd.exe - pwsh will receive the semicolon (for cmd.exe unquoted semicolon and comma are separators that aren't seen in positional arguments) 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% + @rem pwsh -nop -nol -c set-executionpolicy -Scope Process Unrestricted; "%scriptrootname%.ps1" %arglist% + @rem pwsh -nop -nol -c set-executionpolicy -Scope Process Unrestricted + cmd /c pwsh -nop -nol -ExecutionPolicy bypass -f "%scriptrootname%.ps1" !newcommandline! 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% + @rem powershell -nop -nol -ExecutionPolicy Bypass -c "%scriptrootname%.ps1" %arglist% + cmd /c powershell -nop -nol -ExecutionPolicy Bypass -f "%scriptrootname%.ps1" !newcommandline! SET task_exitcode=!errorlevel! ) ) ELSE ( IF "!selected_shelltype_trimmed!"=="powershell" ( - powershell -nop -nol -ExecutionPolicy Bypass -c "%~dp0%~n0.ps1" %arglist% + @rem powershell -nop -nol -ExecutionPolicy Bypass -c "%scriptrootname%.ps1" %arglist% + cmd /c powershell -nop -nol -ExecutionPolicy Bypass -f "%scriptrootname%.ps1" !newcommandline! SET task_exitcode=!errorlevel! ) ELSE ( IF "!selected_shelltype_trimmed!"=="wslbash" ( @@ -211,7 +338,7 @@ set -- "$@" "a=[Hide <#;Hide set;S 1 list]"; set -- : "$@";$1 = @' 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; + %selected_shellpath_trimmed% "%winpath%%fname%" %arglist% & SET task_exitcode=!errorlevel! & Call; ) ELSE ( ECHO %fname% has invalid nextshelltype value %selected_shelltype% valid options are %validshelltypes% SET task_exitcode=66 @@ -222,9 +349,145 @@ set -- "$@" "a=[Hide <#;Hide set;S 1 list]"; set -- : "$@";$1 = @' ) ) @REM batch file library functions -@REM boundary padding + @GOTO :endlib +@REM padding +@REM padding +@REM padding + +%= ---------------------------------------------------------------------- =% +@rem courtesy of dbenham +:: Example usage +@rem call :getUniqueFile "d:\test\myFile" ".txt" myFile +@rem echo myFile="%myFile%" + +:getUniqueFile baseName extension rtnVar +setlocal +:getUniqueFileLoop +for /f "skip=1" %%A in ('wmic os get localDateTime') do for %%B in (%%A) do set "rtn=%~1_%%B%~2" +if exist "%rtn%" ( + goto :getUniqueFileLoop +) else ( + 2>nul >nul (9>"%rtn%" timeout /nobreak 1) || goto :getUniqueFileLoop +) +endlocal & set "%~3=%rtn%" +exit /b +%= ---------------------------------------------------------------------- =% + +@REM padding +:buildcmdline cmdlinevar paramvar wrapA wrapB + %= quoting for cmd.exe /c pwsh -nop !args! =% + @SETLOCAL EnableDelayedExpansion + + @REM @echo ===================== + set "pval=!%~2:*#=!" + set "pval=!pval:~0,-2!" + @REM set "pval=!pval:~0,-1!" + set "wrapa=%~3" + set "wrapb=%~4" + + @call :strlen pval slen + @rem @echo strlen: !slen! + if "!slen!"=="0" ( + goto :eof + ) + @set /A n = !slen! - 1 + @(set str=) + @set "dq="" + @set "bang=^!" + @(set carat=^^) + @for /l %%i in (0,1,!n!) do @( + (set c=!pval:~%%i,1!) + if "!c!"=="|" ( + set "ch=^^!pval:~%%i,1!" + ) ELSE IF "!c!"=="(" ( + set "ch=^(" + ) ELSE if "!c!"==")" ( + set "ch=^)" + ) ELSE if "!c!"=="&" ( + set "ch=^^&" + ) ELSE if "!c!"=="!dq!" ( + set "ch=^"" + ) ELSE if "!c!"=="!bang!" ( + @rem - double caret - first for initial parsing, second to ensure remains escaped during delayed expansion phase + @rem - REVIEW + set "ch=^^!bang!" + ) ELSE if "!c!"=="^carat" ( + set "ch=^^^^" + ) ELSE if "!c!"=="'" ( + set "ch=''" + ) ELSE ( + set "ch=!c!" + ) + @rem @echo - !ch! + set "str=!str!!ch!" + ) + echo +++++ %~1 = !%1! !str! + + set "%~1=!%1! !wrapa!!str!!wrapb!" + + @rem old method of return - failes to preserve exclamation marks + @rem for /f "delims=" %%A in (""!str!"") do endlocal & set "%~1=!%1! '%%~A'" + @rem macro method of endlocal return - preserving !val! + @echo off + %endlocal% %~1 + + @exit /b + +:rem_output + @rem --------------------------------------------- + @rem rem_output is called for each n in the number of args we process - as we don't have a non-destructive way to count args whilst accepting special chars + @rem we therefore need a way to stop processing on the last received arg so we don't write argCount entries to param.txt if less are received + @rem see 'disappearing quotes' technique + @rem https://stackoverflow.com/questions/4643376/how-to-split-double-quoted-line-into-multiple-lines-in-windows-batch-file/4645113#4645113 + @rem and + @rem https://groups.google.com/g/alt.msdos.batch.nt/c/J71F17Bve9Y (sponge belly) + @echo off + setlocal enableextensions disabledelayedexpansion + set "param1=%~2" + rem do must not be indented + for %%^" in ("") ^ +do if not defined param1 set %%~"param1=%2%%~" + if not defined param1 goto :eof + endlocal + @rem --------------------------------------------- + + @PROMPT @ + @echo on + rem %1 #%2# +@exit /b + +@REM courtesy of: https://stackoverflow.com/users/463115/jeb +:strlen stringVar returnVar +@( + setlocal EnableDelayedExpansion + @SET "rtrn=%~2" + (set^ tmp=!%~1!) + @rem @echo jjjjj !tmp! + @if defined tmp ( + set "len=1" + @for %%P in (4096 2048 1024 512 256 128 64 32 16 8 4 2 1) do @( + @if "!tmp:~%%P,1!" NEQ "" ( + set /a "len+=%%P" + set "tmp=!tmp:~%%P!" + ) + ) + ) ELSE ( + set len=0 + ) +) +@( + endlocal + @IF "%~2" neq "" ( + @SET "%rtrn%=%len%" + ) ELSE ( + @ECHO :strlen result: %len% + ) + exit /b +) + + :getWslPath @SETLOCAL @SET "_path=%~p1" @@ -280,7 +543,7 @@ set -- "$@" "a=[Hide <#;Hide set;S 1 list]"; set -- : "$@";$1 = @' ) ) @EXIT /B -@REM boundary padding +@REM boundary padding @REM boundary padding :getNormalizedScriptTail @SETLOCAL @@ -295,13 +558,12 @@ set -- "$@" "a=[Hide <#;Hide set;S 1 list]"; set -- : "$@";$1 = @' ) @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 +: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' @SETLOCAL @CALL :stringContains %~1 "\" hasBackSlash @CALL :stringContains %~1 "/" hasForwardSlash @@ -327,6 +589,10 @@ set -- "$@" "a=[Hide <#;Hide set;S 1 list]"; set -- : "$@";$1 = @' ) @EXIT /B +@REM boundary padding +@REM boundary padding +@REM boundary padding + :stringContains @REM usage: @CALL:stringContains string needle returnvarname @SETLOCAL @@ -348,7 +614,7 @@ set -- "$@" "a=[Hide <#;Hide set;S 1 list]"; set -- : "$@";$1 = @' @EXIT /B @REM boundary padding @REM boundary padding -:stringToUpper +:stringToUpper strvar returnvar @SETLOCAL @SET "rtrn=%~2" @SET "string=%~1" @@ -384,6 +650,11 @@ set -- "$@" "a=[Hide <#;Hide set;S 1 list]"; set -- : "$@";$1 = @' @EXIT /B @REM boundary padding @REM boundary padding +@REM boundary padding +@REM boundary padding +@REM boundary padding +@REM boundary padding +@REM boundary padding :stringTrimTrailingUnderscores @SETLOCAL @SET "rtrn=%~2" @@ -442,12 +713,104 @@ set -- "$@" "a=[Hide <#;Hide set;S 1 list]"; set -- : "$@";$1 = @' # -- 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 +# -- e.g ./scriptname.cmd in sh or zsh or bash +# -- e.g tclsh scriptname.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 '@ +#--------------------------------------------------------------------- +#divert to configured nextshell +package require platform +set plat_full [platform::generic] +set plat [lindex [split $plat_full -] 0] +#may be old tcl - not assuming readFile available +set fd [open [info script] r] +set scriptdata [read $fd] +close $fd +set scriptdata [string map [list \r\n \n] $scriptdata] +set in_data 0 +set nextshellpath "" +set nextshelltype "" +puts stderr "PLAT: $plat" +foreach ln [split $scriptdata \n] { + if {[string trim $ln] eq ""} {continue} + if {!$in_data} { + if {[string match ": <>*" $ln]} { + set in_data 1 + } + } else { + if {[string match "*@SET*nextshellpath?${plat}_*" $ln]} { + set lineparts [split $ln =] + set tail [lindex $lineparts 1] + set nextshellpath [string trimright $tail {_"}] + if {$nextshellpath ne "" && $nextshelltype ne ""} { + break + } + } elseif {[string match "*@SET*nextshelltype?${plat}_*" $ln]} { + set lineparts [split $ln =] + set tail [lindex $lineparts 1] + set nextshelltype [string trimright $tail {_"}] + if {$nextshellpath ne "" && $nextshelltype ne ""} { + break + } + } elseif {[string match ": <>*" $ln]} { + break + } + } +} +if {$nextshelltype ne "tcl" && $nextshelltype ne "none"} { + if {$nextshelltype in "pwsh powershell"} { + set scrname [file rootname [info script]].ps1 + set arglist [list] + foreach a $::argv { + set a "'$a'" + lappend arglist $a + } + } else { + set scrname [info script] + set arglist $::argv + } + puts stdout "tclsh launching subshell of type: $nextshelltype shellpath: $nextshellpath on script $scrname with args: $arglist" + #todo - handle /usr/bin/env + #todo - exitcode + if {[llength $nextshellpath] == 1 && [string index $nextshellpath 0] eq {"} && [string index $nextshellpath end] eq {"}} { + set nextshell_words [list $nextshellpath] + } else { + set nextshell_words $nextshellpath + } + set ns_firstword [lindex $nextshellpath 0] + if {[string index $ns_firstword 0] eq {"} && [string index $ns_firstword end] eq {"}} { + set ns_firstword [string range $ns_firstword 1 end-1] + } + + if {[string match {/*/env} $ns_firstword] && $::tcl_platform(platform) ne "windows"} { + set exec_part $nextshellpath + } else { + set epath [auto_execok $ns_firstword] + if {$epath eq ""} { + error "unable to find executable path for first word '$ns_firstword' of nextshellpath '$nextshellpath'" + } else { + set exec_part [list {*}$epath {*}[lrange $nextshellpath 1 end]] + } + } + catch {exec {*}$exec_part $scrname {*}$arglist <@stdin >@stdout 2>@stderr} emsg eopts + + if {[dict exists $eopts -errorcode]} { + set ecode [dict get $eopts -errorcode] + if {[lindex $ecode 0] eq "CHILDSTATUS"} { + exit [lindex $ecode 2] + } else { + puts stderr "error calling next shell $nextshelltype :" + puts stderr $emsg + exit 1 + } + } else { + exit 0 + } +} +#--------------------------------------------------------------------- + namespace eval ::punk::multishell { set last_script_root [file dirname [file normalize ${::argv0}/__]] set last_script [file dirname [file normalize [info script]/__]] @@ -481,7 +844,7 @@ namespace eval ::punk::multishell { # -- --- --- --- --- --- --- --- --- --- --- --- # -puts stderr "No tcl code for this script. Try another program such as perl or bash" +puts stderr "No tcl code for this script. Try another program such as zsh or bash or perl" # # @@ -512,21 +875,26 @@ if {[::punk::multishell::is_main]} { # -- --- --- --- --- --- --- --- --- --- --- --- --- ---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}" - +# Be wary of any non-trivial sed/awk etc - can be brittle to maintain across linux,freebsd,macosx due to differing implementations \ +echo "var0: $0 @: $@" +# echo "script: `echo $0 | sed 's/^-//'`" +# use oldschool backticks and sed - lowest common denominator \ +# echo "shell: " `ps -p $$ | awk '$1 != "PID" {print $(NF)}' | tr -d '()' | sed -E 's/^.*\/|^-//'` +# zsh diversion \ +# if [[ "$argv[*]" != "[*]" ]]; then /usr/bin/env bash "$0" "${argv[@]:2:$((${#argv[@]}-2))}"; exit $?; fi +# \ +ps_shellname=`ps -p $$ | awk '$1 != "PID" {print $(NF)}' | tr -d '()' | sed -E 's/^.*\/|^-//'` +# \ +echo "shell from ps: $ps_shellname argc: ${#@} inner: ${@:2:$((${#@}-2))}" +# non-bash-like diversion \ +if [[ "$ps_shellname" != "bash" && "$ps_shellname" != "zsh" ]]; then /usr/bin/env bash "$0" "${@:2:$((${#@}-2))}"; exit $?; fi +# sh/bash (or zsh?) \ +shift && set -- "${@:1:$((${#@}-1))}" +# \ #echo "shell:" `ps -o args= $$ | sed -E 's/^.*\/|^-//' | awk '{print $1}'` -#------------------------------------------------------ +# \ +echo "args: $@" +# ------------------------------------------------------ # -- This if block only needed if Tcl didn't exit or return above. if false==false # else { then @@ -541,20 +909,30 @@ if false==false # else { # -- # ## ### ### ### ### ### ### ### ### ### ### ### ### ### -if [[ "$OSTYPE" == "linux"* ]]; then +plat=$(uname -s) #platform/system +if [[ "$plat" = "Linux"* ]]; then os="linux" -elif [[ "$OSTYPE" == "darwin"* ]]; then +elif [[ "$plat" == "Darwin"* ]]; then os="macosx" -elif [[ "$OSTYPE" == "freebsd"* ]]; then +elif [[ "$plat" == "FreeBSD"* ]]; then os="freebsd" -elif [[ "$OSTYPE" == "dragonflybsd"* ]]; then +elif [[ "$plat" == "DragonFly"* ]]; then os="dragonflybsd" -elif [[ "$OSTYPE" == "netbsd"* ]]; then +elif [[ "$plat" == "NetBSD"* ]]; then os="netbsd" -elif [[ "$OSTYPE" == "win32" ]]; then +elif [[ "$plat" == "OpenBSD"* ]]; then + os="openbsd" +elif [[ "$plat" = "MINGW32"* ]]; then + os="win32" +elif [[ "$plat" = "MINGW64"* ]]; then os="win32" -elif [[ "$OSTYPE" == "msys" ]]; then +elif [[ "$plat" = "CYGWIN_NT"* ]]; then + os="win32" +elif [[ "$plat" == "MSYS_NT"* ]]; then + #review.. echo MSYS + #win32 binaries - but e.g tclsh installed in msys reports ::tcl_platform(platform) as 'unix' + #bash reports $OSTYPE msys os="win32" #review - need ps/sed/awk to determine shell? interp = `ps -p $$ | awk '$1 != "PID" {print $(NF)}' | tr -d '()' | sed -E 's/^.*\/|^-//'` @@ -564,37 +942,50 @@ elif [[ "$OSTYPE" == "msys" ]]; then #"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}}" +elif [[ "$OSTYPE" == "win32" ]]; then + os="win32" 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" +## This is the sort of sed that will not work across implementations +## shellconfiglines=$( sed -n "/: <>/{:a;n;/: <>/q;p;ba}" "$0" | grep $os) +#awk tested on linux & freebsd +shellconfiglines=$( awk '/^:.*<>.*$/,/^:.*<>.*$/' "$0" | grep $os) +# echo $shellconfiglines; +# readarray requires bash 4.0 +if [[ "$ps_shellname" == "bash" ]]; then + readarray -t arr_oslines <<<"$shellconfiglines" +elif [[ "$ps_shellname" == "zsh" ]]; then + arr_oslines=("${(f)shellconfiglines}") else - echo "unable to find config for os $os" - echo "shellconfigline: $shellconfigline" - nextshellpath="" - nextshelltype="" + #fallback - doesn't seem to work in zsh - untested in early bash + IFS=$'\n' arr_oslines=($shellconfiglines) fi +nextshellpath="" +nextshelltype="" +for ln in "${arr_oslines[@]}"; do + # echo "---- $ln" + if [[ "$ln" == *"nextshellpath"* ]]; then + splitln="${ln#*=}" #remove everything through the first '=' + pathraw="${splitln%%\"*}" #take everything before the quote - use %% to get longest match + #remove trailing underscores (% means must match at end) + nextshellpath="${pathraw/%_*/}" + echo "nextshellpath: $nextshellpath" + elif [[ "$ln" == *"nextshelltype"* ]]; then + splitln="${ln#*=}" + typeraw="${splitln%%\"*}" + nextshelltype="${typeraw/%_*/}" + echo "nextshelltype: $nextshelltype" + fi +done + 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" "$@" + echo bash launching subshell of type: $nextshelltype shellpath: $nextshellpath on "$0" with args "$@" + #e.g /usr/bin/env tclsh "$0" "$@" ${nextshellpath} "$0" "$@" exitcode=$? @@ -752,12 +1143,14 @@ function GetDynamicParamDictionary { return $DynParamDictionary } } +# Example usage: # 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 +# [Parameter(Mandatory)][string] $myargument, +# [Parameter(ValueFromRemainingArguments)] $opts # ) #} #function psmain { @@ -768,10 +1161,15 @@ function GetDynamicParamDictionary { # #called once with $PSBoundParameters dictionary # #can be used to validate arguments, or set a simpler variable name for access # switch ($PSBoundParameters.keys) { -# 'myargumentname' { +# 'myargument' { # Set-Variable -Name $_ -Value $PSBoundParameters."$_" # } -# #... +# 'opts' { +# write-warning "Unused parameters: $($PSBoundParameters.$_)" +# } +# Default { +# write-warning "Unhandled parameter -> [$($_)]" +# } # } # foreach ($boundparam in $PSBoundParameters.GetEnumerator()) { # #... @@ -779,24 +1177,24 @@ function GetDynamicParamDictionary { # } # end { # #Main function logic -# Write-Host "myargumentname value is: $myargumentname" +# Write-Host "myargument value is: $myargument" # #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 +"Script Name : {0}" -f $scriptname | write-host +"Powershell Version: {0}" -f $PSVersionTable.PSVersion.Major | write-host +"powershell args : {0}" -f ($args -join ", ") | write-host # -- --- --- --- +$thisfileContent = Get-Content $scriptname -Raw $startTag = ": <>" $endTag = ": <>" -$fileContent = Get-Content $scriptname -Raw -$pattern = "(?s)$startTag(.*?)$endTag" -$matches = [regex]::Matches($fileContent,$pattern) -$admininfo = $matches[0].Groups[1].Value +$pattern = "(?s)`n$startTag[^`n]*`n(.*?)`n$endTag" +$match = [regex]::Match($thisfileContent,$pattern) $asadmin = 0 -if ($matches.count) { +if ($match.Success) { + $admininfo = $match.Groups[1].Value $asadmin = $admininfo.Contains("asadmin=1") if ($asadmin) { if (-not ([Security.Principal.WindowsPrincipal][Security.Principal.WindowsIdentity]::GetCurrent()).IsInRole([Security.Principal.WindowsBuiltInRole]::Administrator)) { @@ -814,10 +1212,72 @@ if ($matches.count) { } } } +# +$startTag = ": <>" +$endTag = ": <>" +$pattern = "(?s)`n$startTag[^`n]*`n(.*?)`n$endTag" +$match = [regex]::Match($thisfileContent,$pattern) +if ($match.Success) { + $plat = [System.Environment]::OSVersion.Platform + if ($plat -eq "Unix") { + $runtime_ident = [System.Runtime.InteropServices.RuntimeInformation]::RuntimeIdentifier + switch ($runtime_ident.split("-")[0]) { + "freebsd" { + # untested + $os = "freebsd" + } + "linux" { + $os = "linux" + } + "osx" { + # osx-x64 or osx-arm64 ? + $os = "macosx" + } + default { + #openbsd, netbsd ? + $os = "other" + } + } + } else { + $os = "win32" + } + + $matchedlines = $match.Groups[1].Value + $nextshell_type = "" + $nextshell_path = "" + ForEach ($line in $($matchedlines -split "\r?\n")) { + $m = [regex]::Match($line,".*nextshelltype\[${os}[_]+\]=([^_]*)[_]*") + if ($m.Success) { + $nextshell_type = $m.Groups[1].Value + } + $m = [regex]::Match($line,".*nextshellpath\[${os}[_]+\]=([^_]*)[_]*") + if ($m.Success) { + $nextshell_path = $m.Groups[1].Value + } + if ($nextshell_type -ne "" -and $nextshell_path -ne "") { + break + } + } + 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" + + # $arguments = @($($MyInvocation.MyCommand.Path)) + # $arguments += $args + # NOTE - this gives incorrect argument quoting e.g wrong number of arguments received by launched process for arguments: a "b c" + # $process = (Start-Process -FilePath $nextshell_path -ArgumentList $arguments -NoNewWindow -Wait) + # Exit $process.ExitCode + + & $nextshell_path $scriptname $args + exit $LASTEXITCODE + } +} + # -- --- --- --- --- --- --- --- --- --- --- --- --- ---begin powershell Payload # -Write-Error "No powershell code for this script. Try another program such as perl, tcl or bash" +Write-Error "No powershell code for this script. Try another program such as tcl or bash`n" +"powershell args : {0}" -f ($args -join ", ") | write-host # # diff --git a/src/vfs/_vfscommon.vfs/modules/punk/mix/templates/utility/scriptappwrappers/multishell1.cmd b/src/vfs/_vfscommon.vfs/modules/punk/mix/templates/utility/scriptappwrappers/multishell1.cmd index 9daf7ebf..3fce3bcf 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/mix/templates/utility/scriptappwrappers/multishell1.cmd +++ b/src/vfs/_vfscommon.vfs/modules/punk/mix/templates/utility/scriptappwrappers/multishell1.cmd @@ -1,5 +1,5 @@ -: "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 = @' +: "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" + @@ -16,41 +16,41 @@ set -- "$@" "a=[Hide <#;Hide set;s 1 list]"; set -- : "$@";$1 = @' @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 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= powershell______ sh______________ wslbash_________ bash____________ tcl_____________ perl____________" +@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 32 chars needed for a target, it can still be done but overall script padding may need checking/adjusting +@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___________]=tclsh___________________________" +: <> +@SET "nextshellpath[win32___________]=tclsh___________________________________________________________" @SET "nextshelltype[win32___________]=tcl_____________" -@SET "nextshellpath[dragonflybsd____]=/usr/bin/env tclsh______________" +@SET "nextshellpath[dragonflybsd____]=/usr/bin/env tclsh______________________________________________" @SET "nextshelltype[dragonflybsd____]=tcl_____________" -@SET "nextshellpath[freebsd_________]=/usr/bin/env tclsh______________" +@SET "nextshellpath[freebsd_________]=/usr/bin/env tclsh______________________________________________" @SET "nextshelltype[freebsd_________]=tcl_____________" -@SET "nextshellpath[netbsd__________]=/usr/bin/env tclsh______________" +@SET "nextshellpath[netbsd__________]=/usr/bin/env tclsh______________________________________________" @SET "nextshelltype[netbsd__________]=tcl_____________" -@SET "nextshellpath[linux___________]=/usr/bin/env tclsh______________" +@SET "nextshellpath[linux___________]=/usr/bin/env tclsh______________________________________________" @SET "nextshelltype[linux___________]=tcl_____________" -@SET "nextshellpath[macosx__________]=/usr/bin/env tclsh______________" +@SET "nextshellpath[macosx__________]=/usr/bin/env tclsh______________________________________________" @SET "nextshelltype[macosx__________]=tcl_____________" -@SET "nextshellpath[other___________]=/usr/bin/env tclsh______________" +@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___________]%" @@ -143,7 +143,7 @@ set -- "$@" "a=[Hide <#;Hide set;s 1 list]"; set -- : "$@";$1 = @' @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 +@ECHO Launching script in new window due to administrator elevation @"%SystemRoot%\System32\WScript.exe" "%vbsGetPrivileges%" %* @EXIT /B @@ -175,43 +175,57 @@ set -- "$@" "a=[Hide <#;Hide set;s 1 list]"; set -- : "$@";$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 +@IF "!selected_shelltype_trimmed!"=="none" ( + SET selected_shelltype_trimmed=pwsh +) +@SET "squoted_args=" +@for %%a in (%*) do @( + set "v=%%a" + set "v=!v:'=''!" + SET "squoted_args=!squoted_args!'!v!' " +) +@SET "squoted_args=%squoted_args:~0,-1%" +@ECHO %squoted_args% +@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; write-host "statusmessage: pwsh-found" >NUL + 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% + pwsh -nop -nol -c set-executionpolicy -Scope Process Unrestricted; "%~dp0%~n0.ps1" %squoted_args% 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% + 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" %squoted_args% 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% + IF "!selected_shelltype_trimmed!"=="powershell" ( + powershell -nop -nol -ExecutionPolicy Bypass -c "%~dp0%~n0.ps1" %squoted_args% 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; + 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 ( - 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 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 + ) ) ) ) @@ -342,7 +356,7 @@ set -- "$@" "a=[Hide <#;Hide set;s 1 list]"; set -- : "$@";$1 = @' @EXIT /B @REM boundary padding @REM boundary padding -:stringToUpper +:stringToUpper @SETLOCAL @SET "rtrn=%~2" @SET "string=%~1" @@ -383,14 +397,15 @@ set -- "$@" "a=[Hide <#;Hide set;s 1 list]"; set -- : "$@";$1 = @' @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:###=% + @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 "" ( @@ -439,7 +454,7 @@ set -- "$@" "a=[Hide <#;Hide set;s 1 list]"; set -- : "$@";$1 = @' # -- e.g tclsh filename.cmd # -- # ## ### ### ### ### ### ### ### ### ### ### ### ### ### -rename set ""; rename s set; set k {-- "$@" "a}; if {[info exists ::env($k)]} {unset ::env($k)} ;# tidyup and restore +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}/__]] @@ -473,6 +488,9 @@ namespace eval ::punk::multishell { #puts "argv0 : $::argv0" # -- --- --- --- --- --- --- --- --- --- --- --- +# +puts stderr "No tcl code for this script. Try another program such as perl or bash" +# # # @@ -502,8 +520,20 @@ if {[::punk::multishell::is_main]} { # -- --- --- --- --- --- --- --- --- --- --- --- --- ---end Tcl Payload # end hide from unix shells \ HEREDOC1B_HIDE_FROM_BASH_AND_SH +#Be wary of any non-trivial sed/awk etc - can be brittle to maintain across linux,freebsd,macosx due to differing implementations +#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 { @@ -518,10 +548,113 @@ if false==false # else { # -- if sh/bash scripting needs to run on windows too. # -- # ## ### ### ### ### ### ### ### ### ### ### ### ### ### -# -- --- --- --- --- --- --- --- --- --- --- --- --- ---begin sh Payload + +plat=$(uname -s) #platform/system +if [[ "$plat" = "Linux"* ]]; then + os="linux" +elif [[ "$plat" == "Darwin"* ]]; then + os="macosx" +elif [[ "$plat" == "FreeBSD"* ]]; then + os="freebsd" +elif [[ "$plat" == "DragonFly"* ]]; then + os="dragonflybsd" +elif [[ "$plat" == "NetBSD"* ]]; then + os="netbsd" +elif [[ "$plat" == "OpenBSD"* ]]; then + os="openbsd" +elif [[ "$plat" = "MINGW32"* ]]; then + os="win32" +elif [[ "$plat" = "MINGW64"* ]]; then + os="win32" +elif [[ "$plat" = "CYGWIN_NT"* ]]; then + os="win32" +elif [[ "$plat" == "MSYS_NT"* ]]; then + #review.. + echo MSYS + #win32 binaries - but e.g tclsh installed in msys reports ::tcl_platform(platform) as 'unix' + #bash reports $OSTYPE 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}}" +elif [[ "$OSTYPE" == "win32" ]]; then + os="win32" +else + #os="$OSTYPE" + os="other" +fi +echo ostype: $OSTYPE +## This is the sort of sed that will not work across implementations +## shellconfiglines=$( sed -n "/: <>/{:a;n;/: <>/q;p;ba}" "$0" | grep $os) +#awk tested on linux & freebsd +shellconfiglines=$( awk '/^:.*<>.*$/,/^:.*<>.*$/' "$0" | grep $os) +#echo $shellconfiglines; +readarray -t arr_oslines <<<"$shellconfiglines" +nextshellpath="" +nextshelltype="" +for ln in "${arr_oslines[@]}"; do + if [[ "$ln" == *"nextshellpath"* ]]; then + splitln="${ln#*=}" #remove everything through the first '=' + pathraw="${splitln%%\"*}" #take everything before the quote - use %% to get longest match + #remove trailing underscores (% means must match at end) + nextshellpath="${pathraw/%_*/}" + echo "nextshellpath: $nextshellpath" + elif [[ "$ln" == *"nextshelltype"* ]]; then + splitln="${ln#*=}" + typeraw="${splitln%%\"*}" + nextshelltype="${typeraw/%_*/}" + fi +done + +#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" +# +echo "No bash code for this script. Try another program such as perl or tcl" >&2 +# + # # @@ -531,8 +664,8 @@ exitcode=0 #-- 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=$? +#/usr/bin/env tclsh "$0" "$@" +#exitcode=$? #echo "sh/bash reporting tcl exitcode: ${exitcode}" #-- override exitcode example #exit 66 @@ -558,8 +691,18 @@ exit ${exitcode} # ## ### ### ### ### ### ### ### ### ### ### ### ### ### =cut #!/user/bin/perl -# -- --- --- --- --- --- --- --- --- --- --- --- --- ---begin perl Payload 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(); @@ -571,13 +714,15 @@ my $exit_code = 0; -my $scriptname = $0; -print "perl $scriptname\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"; +# + # # @@ -585,7 +730,7 @@ foreach my $a(@ARGV) { # -- --- --- --- --- --- --- --- # -$exit_code=system("tclsh", $scriptname, @ARGV); +#$exit_code=system("tclsh", $scriptname, @ARGV); #print "perl reporting tcl exitcode: $exit_code"; # # -- --- --- --- --- --- --- --- @@ -648,12 +793,14 @@ function GetDynamicParamDictionary { return $DynParamDictionary } } +# Example usage: # 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 +# [Parameter(Mandatory)][string] $myargument, +# [Parameter(ValueFromRemainingArguments)] $opts # ) #} #function psmain { @@ -664,10 +811,15 @@ function GetDynamicParamDictionary { # #called once with $PSBoundParameters dictionary # #can be used to validate arguments, or set a simpler variable name for access # switch ($PSBoundParameters.keys) { -# 'myargumentname' { +# 'myargument' { # Set-Variable -Name $_ -Value $PSBoundParameters."$_" # } -# #... +# 'opts' { +# write-warning "Unused parameters: $($PSBoundParameters.$_)" +# } +# Default { +# write-warning "Unhandled parameter -> [$($_)]" +# } # } # foreach ($boundparam in $PSBoundParameters.GetEnumerator()) { # #... @@ -675,17 +827,46 @@ function GetDynamicParamDictionary { # } # end { # #Main function logic -# Write-Host "myargumentname value is: $myargumentname" +# Write-Host "myargument value is: $myargument" # #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 # -- --- --- --- +$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 + +# +Write-Error "No powershell code for this script. Try another program such as perl, tcl or bash" +# # # @@ -693,7 +874,7 @@ function GetDynamicParamDictionary { # -- --- --- --- --- --- --- --- # -tclsh $scriptname $args +#tclsh $scriptname $args #"powershell reporting exitcode: {0}" -f $LASTEXITCODE | write-host # # -- --- --- --- --- --- --- --- diff --git a/src/vfs/_vfscommon.vfs/modules/punk/mix/templates/utility/scriptappwrappers/multishell2.cmd b/src/vfs/_vfscommon.vfs/modules/punk/mix/templates/utility/scriptappwrappers/multishell2.cmd index 17fe4c15..9daf7ebf 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/mix/templates/utility/scriptappwrappers/multishell2.cmd +++ b/src/vfs/_vfscommon.vfs/modules/punk/mix/templates/utility/scriptappwrappers/multishell2.cmd @@ -1,41 +1,65 @@ -: "[rename set s;proc Hide x {proc $x args {}};Hide :]" "\$(function : {<#pwsh#>})" ^ -set -- "$@" "a=[list shebangless punk MULTISHELL tclsh sh bash cmd pwsh powershell;proc Hide x {proc $x args {}}; 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 @ECHO; Hide ); Hide (;Hide echo; Hide @REM]#not necessary but can help avoid errs in testing" +: "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 \ : { -: STRONG SUGGESTION: DO NOT MODIFY FIRST LINE OF THIS SCRIPT. 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. @REM ############################################################################################################################ -@REM THIS IS A POLYGLOT SCRIPT - supporting payloads in Tcl, bash, sh and/or powershelll (powershell.exe or pwsh.exe) +@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: pmix scriptwrap.multishell -outputfolder +@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 "validshells= ^(10^) 'pwsh' ^(11^) 'sh' (^12^) 'bash' (^13^) 'tclsh'" -@SET "shells[10]=pwsh" -@SET "shells[11]=sh" -@set "shells[12]=bash" -@SET "shells[13]=tclsh" +@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 "nextshell=13" +@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 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 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 ## ### ### ### ### ### ### ### ### ### ### ### ### ### @@ -49,16 +73,16 @@ set -- "$@" "a=[list shebangless punk MULTISHELL tclsh sh bash cmd pwsh powershe @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.checkfile +@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 pmix scriptwrap.checkfile is still recommended. +@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 pmix scriptwrap.checkfile doesn't check all such boundaries. +@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 @@ -89,22 +113,36 @@ set -- "$@" "a=[list shebangless punk MULTISHELL tclsh sh bash cmd pwsh powershe ) @SET "vbsGetPrivileges=%temp%\punk_bat_elevate_%fname%.vbs" @SET arglist=%* -@IF "%1"=="PUNK-ELEVATED" ( +@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 '%1'=='PUNK-ELEVATED' (echo PUNK-ELEVATED & shift /1 & goto :gotPrivileges ) +@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.cmd", args, "", "runas", 1 >> "%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 @@ -113,7 +151,7 @@ set -- "$@" "a=[list shebangless punk MULTISHELL tclsh sh bash cmd pwsh powershe @REM setlocal & pushd . @PUSHD . @cd /d %~dp0 -@IF "%1"=="PUNK-ELEVATED" ( +@IF "is%qstrippedargs:~4,13%"=="isPUNK-ELEVATED" ( @DEL "%vbsGetPrivileges%" 1>nul 2>nul @SET arglist=%arglist:~14% ) @@ -124,7 +162,7 @@ set -- "$@" "a=[list shebangless punk MULTISHELL tclsh sh bash cmd pwsh powershe @if not exist "%~dp0%~n0.ps1" ( @SET need_ps1=1 ) ELSE ( - fc "%~dp0%~n0.cmd" "%~dp0%~n0.ps1" >nul || goto different + fc "%~dp0%~n0%~x0" "%~dp0%~n0.ps1" >nul || goto different @REM @ECHO "files same" @SET need_ps1=0 ) @@ -134,10 +172,10 @@ set -- "$@" "a=[list shebangless punk MULTISHELL tclsh sh bash cmd pwsh powershe @SET need_ps1=1 :pscontinue @IF !need_ps1!==1 ( - COPY "%~dp0%~n0.cmd" "%~dp0%~n0.ps1" >NUL + 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" ( +@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 @@ -145,7 +183,8 @@ set -- "$@" "a=[list shebangless punk MULTISHELL tclsh sh bash cmd pwsh powershe 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! + 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" %* @@ -153,24 +192,31 @@ set -- "$@" "a=[list shebangless punk MULTISHELL tclsh sh bash cmd pwsh powershe SET task_exitcode=!errorlevel! ) ) ELSE ( - IF "!shells[%nextshell%]!"=="bash" ( + IF "%selected_shelltype_trimmed%"=="wslbash" ( CALL :getWslPath %winpath% wslpath REM ECHO wslfullpath "!wslpath!%fname%" - !shells[%nextshell%]! "!wslpath!%fname%" %arglist% & SET task_exitcode=!errorlevel! + %selected_shellpath_trimmed% "!wslpath!%fname%" %arglist% + SET task_exitcode=!errorlevel! ) ELSE ( - REM probably tclsh or sh - IF NOT "x%keyRemoved%"=="x%validshells%" ( + 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 - !shells[%nextshell%]! "%~dp0%fname%" %arglist% & SET task_exitcode=!errorlevel! + 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 nextshell value ^(%nextshell%^) !shells[%nextshell%]! valid options are %validshells% + 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 @@ -179,7 +225,9 @@ set -- "$@" "a=[list shebangless punk MULTISHELL tclsh sh bash cmd pwsh powershe @SET "name=%~nx1" @SET "drive=%~d1" @SET "rtrn=%~2" - @SET "result=/mnt/%drive:~0,1%%_path:\=/%%name%" + @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%" @@ -227,6 +275,7 @@ set -- "$@" "a=[list shebangless punk MULTISHELL tclsh sh bash cmd pwsh powershe ) @EXIT /B @REM boundary padding +@REM boundary padding :getNormalizedScriptTail @SETLOCAL @SET "result=%~nx0" @@ -245,6 +294,8 @@ set -- "$@" "a=[list shebangless punk MULTISHELL tclsh sh bash cmd pwsh powershe @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 @@ -289,7 +340,8 @@ set -- "$@" "a=[list shebangless punk MULTISHELL tclsh sh bash cmd pwsh powershe ) ) @EXIT /B - +@REM boundary padding +@REM boundary padding :stringToUpper @SETLOCAL @SET "rtrn=%~2" @@ -307,7 +359,47 @@ set -- "$@" "a=[list shebangless punk MULTISHELL tclsh sh bash cmd pwsh powershe ) ) @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" @@ -328,6 +420,8 @@ set -- "$@" "a=[list shebangless punk MULTISHELL tclsh sh bash cmd pwsh powershe :endlib : \ +@REM padding +@REM padding @REM @SET taskexit_code=!errorlevel! & goto :exit_multishell @GOTO :exit_multishell # } @@ -348,9 +442,9 @@ set -- "$@" "a=[list shebangless punk MULTISHELL tclsh sh bash cmd pwsh powershe 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_root [file dirname [file normalize ${::argv0}/__]] set last_script [file dirname [file normalize [info script]/__]] - if {[info exists argv0] && + 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 @@ -365,7 +459,7 @@ namespace eval ::punk::multishell { 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}/__]]" + puts stderr "Info: script_root: [file dirname [file normalize ${::argv0}/__]]" return 0 } return [set ::punk::multishell::is_main($script_name)] @@ -380,10 +474,16 @@ namespace eval ::punk::multishell { # -- --- --- --- --- --- --- --- --- --- --- --- -# -# +# +# + +# +# +# +# + # -- --- --- --- --- --- --- --- --- --- --- --- # -- Best practice is to always return or exit above, or just by leaving the below defaults in place. @@ -414,33 +514,33 @@ if false==false # else { # -- 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 @call line above ... to something like @call sh ... @call bash .. or @call env sh ... etc as appropriate +# -- 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" -# -# +# +# # -- --- --- --- --- --- --- --- -# -exitcode=0 ;#default assumption +# #-- 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 "tcl exitcode: ${exitcode}" +#echo "sh/bash reporting tcl exitcode: ${exitcode}" #-- override exitcode example #exit 66 -# +# # -- --- --- --- --- --- --- --- -# -# +# +# #printf "sh/bash done \n" @@ -448,7 +548,57 @@ exitcode=$? #------------------------------------------------------ fi exit ${exitcode} -# end hide sh/bash block from Tcl +# ## ### ### ### ### ### ### ### ### ### ### ### ### ### +# -- 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 @@ -460,9 +610,76 @@ if 0 { # -- 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 +$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 @@ -470,22 +687,22 @@ $scriptname = getScriptName #"powershell args : {0}" -f ($args -join ", ") | write-host # -- --- --- --- -# -# +# +# # -- --- --- --- --- --- --- --- -# +# tclsh $scriptname $args -# +#"powershell reporting exitcode: {0}" -f $LASTEXITCODE | write-host +# # -- --- --- --- --- --- --- --- -# -# +# +# # -- --- --- --- --- --- --- --- --- --- --- --- --- ---end powershell Payload -#"powershell reporting exitcode: {0}" -f $LASTEXITCODE | write-host Exit $LASTEXITCODE # heredoc2 for powershell to ignore block below $1 = @' @@ -498,7 +715,7 @@ $1 = @' : \ @REM @ECHO exitcode: !task_exitcode! : \ -@IF "%1"=="PUNK-ELEVATED" (echo. & @cmd /k echo elevated prompt: type exit to quit) +@IF "is%qstrippedargs:~4,13%"=="isPUNK-ELEVATED" (echo. & @cmd /k echo elevated prompt: type exit to quit) : \ @EXIT /B !task_exitcode! # cmd has exited @@ -509,6 +726,7 @@ $1 = @' # -- powershell multiline comment #> <# +no script engine should try to run me # id:tailblock1 #  diff --git a/src/vfs/_vfscommon.vfs/modules/punk/mix/templates/utility/scriptappwrappers/multishell3.cmd b/src/vfs/_vfscommon.vfs/modules/punk/mix/templates/utility/scriptappwrappers/multishell3.cmd index a9688b6a..17fe4c15 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/mix/templates/utility/scriptappwrappers/multishell3.cmd +++ b/src/vfs/_vfscommon.vfs/modules/punk/mix/templates/utility/scriptappwrappers/multishell3.cmd @@ -1,34 +1,29 @@ -: "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" + +: "[rename set s;proc Hide x {proc $x args {}};Hide :]" "\$(function : {<#pwsh#>})" ^ +set -- "$@" "a=[list shebangless punk MULTISHELL tclsh sh bash cmd pwsh powershell;proc Hide x {proc $x args {}}; 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 @ECHO; Hide ); Hide (;Hide echo; 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 \ : { +: STRONG SUGGESTION: DO NOT MODIFY FIRST LINE OF THIS SCRIPT. 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. @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: deck scriptwrap.multishell -outputfolder +@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 "validshells= ^(10^) 'pwsh' ^(11^) 'sh' (^12^) 'bash' (^13^) 'tclsh'" @SET "shells[10]=pwsh" @SET "shells[11]=sh" @set "shells[12]=bash" @SET "shells[13]=tclsh" -@SET "shells[14]=perl" : @SET "nextshell=13" : @@ -54,16 +49,16 @@ set -- "$@" "a=[Hide <#;Hide set;s 1 list]"; set -- : "$@";$1 = @' @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 -- pmix 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 -- 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.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 -- It is unknown what versions of cmd interpreters behave this way - and pmix 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 @@ -94,40 +89,22 @@ set -- "$@" "a=[Hide <#;Hide set;s 1 list]"; set -- : "$@";$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" ( +@IF "%1"=="PUNK-ELEVATED" ( GOTO :gotPrivileges ) @IF !asadmin!==1 ( net file 1>NUL 2>NUL @IF '!errorlevel!'=='0' ( GOTO :gotPrivileges ) else ( GOTO :getPrivileges ) ) -@REM -@REM -@REM -@REM -@REM -@REM -@REM -@REM -@REM -@REM -@REM -@REM -@REM -@REM -@REM -@REM @GOTO skip_privileges :getPrivileges -@IF "is%qstrippedargs:~4,13%"=="isPUNK-ELEVATED" (echo PUNK-ELEVATED & shift /1 & goto :gotPrivileges ) +@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 UAC.ShellExecute "%~dp0%~n0.cmd", args, "", "runas", 1 >> "%vbsGetPrivileges%" @ECHO Launching script in new windows due to administrator elevation @"%SystemRoot%\System32\WScript.exe" "%vbsGetPrivileges%" %* @EXIT /B @@ -136,7 +113,7 @@ set -- "$@" "a=[Hide <#;Hide set;s 1 list]"; set -- : "$@";$1 = @' @REM setlocal & pushd . @PUSHD . @cd /d %~dp0 -@IF "is%qstrippedargs:~4,13%"=="isPUNK-ELEVATED" ( +@IF "%1"=="PUNK-ELEVATED" ( @DEL "%vbsGetPrivileges%" 1>nul 2>nul @SET arglist=%arglist:~14% ) @@ -147,7 +124,7 @@ set -- "$@" "a=[Hide <#;Hide set;s 1 list]"; set -- : "$@";$1 = @' @if not exist "%~dp0%~n0.ps1" ( @SET need_ps1=1 ) ELSE ( - fc "%~dp0%~n0%~x0" "%~dp0%~n0.ps1" >nul || goto different + fc "%~dp0%~n0.cmd" "%~dp0%~n0.ps1" >nul || goto different @REM @ECHO "files same" @SET need_ps1=0 ) @@ -157,7 +134,7 @@ set -- "$@" "a=[Hide <#;Hide set;s 1 list]"; set -- : "$@";$1 = @' @SET need_ps1=1 :pscontinue @IF !need_ps1!==1 ( - COPY "%~dp0%~n0%~x0" "%~dp0%~n0.ps1" >NUL + COPY "%~dp0%~n0.cmd" "%~dp0%~n0.ps1" >NUL ) @REM avoid using CALL to launch pwsh,tclsh etc - it will intercept some args such as /? @IF "!shells[%nextshell%]!"=="pwsh" ( @@ -168,8 +145,7 @@ set -- "$@" "a=[Hide <#;Hide set;s 1 list]"; set -- : "$@";$1 = @' 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! + 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" %* @@ -180,26 +156,21 @@ set -- "$@" "a=[Hide <#;Hide set;s 1 list]"; set -- : "$@";$1 = @' IF "!shells[%nextshell%]!"=="bash" ( CALL :getWslPath %winpath% wslpath REM ECHO wslfullpath "!wslpath!%fname%" - !shells[%nextshell%]! "!wslpath!%fname%" %arglist% - SET task_exitcode=!errorlevel! + !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! + !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 - @REM boundary padding GOTO :exit_multishell ) ) ) @REM batch file library functions -@REM boundary padding @GOTO :endlib :getWslPath @@ -256,7 +227,6 @@ set -- "$@" "a=[Hide <#;Hide set;s 1 list]"; set -- : "$@";$1 = @' ) @EXIT /B @REM boundary padding -@REM boundary padding :getNormalizedScriptTail @SETLOCAL @SET "result=%~nx0" @@ -275,8 +245,6 @@ set -- "$@" "a=[Hide <#;Hide set;s 1 list]"; set -- : "$@";$1 = @' @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 @@ -412,15 +380,9 @@ namespace eval ::punk::multishell { # -- --- --- --- --- --- --- --- --- --- --- --- -# -# - -# -# - +# +# -# -# # -- --- --- --- --- --- --- --- --- --- --- --- @@ -452,33 +414,33 @@ if false==false # else { # -- 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 +# -- adjust @call line above ... to something like @call sh ... @call bash .. or @call env sh ... etc as appropriate # -- if sh/bash scripting needs to run on windows too. # -- # ## ### ### ### ### ### ### ### ### ### ### ### ### ### # -- --- --- --- --- --- --- --- --- --- --- --- --- ---begin sh Payload -exitcode=0 #printf "start of bash or sh code" -# -# +# +# # -- --- --- --- --- --- --- --- -# +# +exitcode=0 ;#default assumption #-- 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}" +#echo "tcl exitcode: ${exitcode}" #-- override exitcode example #exit 66 -# +# # -- --- --- --- --- --- --- --- -# -# +# +# #printf "sh/bash done \n" @@ -486,57 +448,7 @@ exitcode=$? #------------------------------------------------------ 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 +# end hide sh/bash 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 @@ -548,76 +460,9 @@ if 0 { # -- 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 +$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 @@ -625,22 +470,22 @@ function GetDynamicParamDictionary { #"powershell args : {0}" -f ($args -join ", ") | write-host # -- --- --- --- -# -# +# +# # -- --- --- --- --- --- --- --- -# +# tclsh $scriptname $args -#"powershell reporting exitcode: {0}" -f $LASTEXITCODE | write-host -# +# # -- --- --- --- --- --- --- --- -# -# +# +# # -- --- --- --- --- --- --- --- --- --- --- --- --- ---end powershell Payload +#"powershell reporting exitcode: {0}" -f $LASTEXITCODE | write-host Exit $LASTEXITCODE # heredoc2 for powershell to ignore block below $1 = @' @@ -653,7 +498,7 @@ $1 = @' : \ @REM @ECHO exitcode: !task_exitcode! : \ -@IF "is%qstrippedargs:~4,13%"=="isPUNK-ELEVATED" (echo. & @cmd /k echo elevated prompt: type exit to quit) +@IF "%1"=="PUNK-ELEVATED" (echo. & @cmd /k echo elevated prompt: type exit to quit) : \ @EXIT /B !task_exitcode! # cmd has exited @@ -664,7 +509,6 @@ $1 = @' # -- powershell multiline comment #> <# -no script engine should try to run me # id:tailblock1 #  diff --git a/src/vfs/_vfscommon.vfs/modules/punk/mix/templates/utility/scriptappwrappers/multishell4.cmd b/src/vfs/_vfscommon.vfs/modules/punk/mix/templates/utility/scriptappwrappers/multishell4.cmd new file mode 100644 index 00000000..a9688b6a --- /dev/null +++ b/src/vfs/_vfscommon.vfs/modules/punk/mix/templates/utility/scriptappwrappers/multishell4.cmd @@ -0,0 +1,680 @@ +: "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: 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. +@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=13" +: +@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 -- 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 +@REM +@REM +@REM +@REM +@REM +@REM +@REM +@REM +@REM +@REM +@REM +@REM +@REM +@REM +@REM +@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 "!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 + @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 +# -- 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/vfs/_vfscommon.vfs/modules/punk/repl-0.1.2.tm b/src/vfs/_vfscommon.vfs/modules/punk/repl-0.1.2.tm index 731e263e..9d199997 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/repl-0.1.2.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/repl-0.1.2.tm @@ -2418,6 +2418,8 @@ proc repl::repl_process_data {inputchan chunktype chunk stdinlines prompt_config #if {[lindex $command 0] eq "runx"} {} + #temporary hack. + #todo - use happy path return options for non-primary result (like www package) ? if { [string equal -length [string length "d/ "] "d/ " $commandstr] || \ [string equal "d/\n" $commandstr] || \ diff --git a/src/vfs/_vfscommon.vfs/modules/punk/zip-0.1.1.tm b/src/vfs/_vfscommon.vfs/modules/punk/zip-0.1.1.tm index 2ed4f1e4..02415ccd 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/zip-0.1.1.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/zip-0.1.1.tm @@ -283,9 +283,47 @@ tcl::namespace::eval punk::zip { #if there is an external preamble - extract that. (if there is also an internal preamble - ignore and consider part of the archive-data) #Otherwise extract an internal preamble. - #if neither - + #if neither -? #review - reconsider auto-determination of internal vs external preamble - proc extract_preamble {infile outfile_preamble {outfile_zip ""}} { + punk::args::define { + @id -id ::punk::zip::extract_preamble + @cmd -name punk::zip::extract_preamble -help\ + "Split a zipfs based executable or library into its constituent + binary and zip parts. + + Note that the binary preamble might be either 'within' the zip offsets, + or simply catenated prior to an unadjusted zip. + Some build processes may have 'adjusted' the zip offsets to make the zip cover the entire file + ('file based' offset) whilst the more modern approach is to simply concatenate the binary and the zip + ('archive based' offset). An archive-based offset is simpler and more reliably points to the proper + split location. It also allows 'zipfs info //zipfs:/app' to return the correct offset information. + + Either way, extract_preamble can usually separate them, but in the unusual case that there is both an + external preamble and a preamble within the zip, only the external preamble will be split, with the + internal one remaining in the zip. + + The inverse of this process would be to extract the .zip file created by this split to a folder, + e.g extracted_zip_folder (adjusting contents as required) and then to run: + zipfs mkimg newbinaryname.exe extracted_zip_folder \"\" + " + @values -min 2 -max 3 + infile -type file -optional 0 -help\ + "Name of existing tcl executable or shared lib with attached zipfs filesystem" + outfile_preamble -optional 0 -type file -help\ + "Name of output file for binary preamble to be extracted to. + If this file already exists, an error will be raised" + outfile_zip -default "" -type file -help\ + "Name of output file for zip data to be extracted to. + If this file already exists, an error will be raised" + } + proc extract_preamble {args} { + set argd [punk::args::parse $args withid ::punk::zip::extract_preamble] + lassign [dict values $argd] leaders opts values received + + set infile [dict get $values infile] + set outfile_preamble [dict get $values outfile_preamble] + set outfile_zip [dict get $values outfile_zip] + set inzip [open $infile r] fconfigure $inzip -encoding iso8859-1 -translation binary if {[file exists $outfile_preamble]} { @@ -346,7 +384,7 @@ tcl::namespace::eval punk::zip { #we could scan from top (ugly) - and with binary prefixes we could get false positives in the data that look like PK\3\4 headers #we could either work out the format for all possible executables that could be appended (across all platforms) and understand where they end? #or we just look for the topmost PK\3\4 header pointed to by a CDR record - and assume the CDR is complete - + #step one - read all the CD records and find the highest pointed to local file record (which isn't necessarily the first - but should get us above most if not all of the zip data) #we can't assume they're ordered in any particular way - so we in theory have to look at them all. set baseoffset "unknown" diff --git a/src/vfs/_vfscommon.vfs/modules/shellrun-0.1.1.tm b/src/vfs/_vfscommon.vfs/modules/shellrun-0.1.1.tm index b2ce1feb..8f03892d 100644 --- a/src/vfs/_vfscommon.vfs/modules/shellrun-0.1.1.tm +++ b/src/vfs/_vfscommon.vfs/modules/shellrun-0.1.1.tm @@ -427,7 +427,7 @@ namespace eval shellrun { cmdarg -type any -multiple 1 -optional 1 }] proc runerr {args} { - set argd [punk::args::parse $args withid ::shellrun::runout] + set argd [punk::args::parse $args withid ::shellrun::runerr] lassign [dict values $argd] leaders opts values received if {[dict exists $received "-nonewline"]} { diff --git a/src/vfs/_vfscommon.vfs/modules/www-2.8.tm b/src/vfs/_vfscommon.vfs/modules/www-2.8.tm new file mode 100644 index 00000000..7fc6b616 --- /dev/null +++ b/src/vfs/_vfscommon.vfs/modules/www-2.8.tm @@ -0,0 +1,2048 @@ +# Package implementing the HTTP protocol. The http package shipping with Tcl +# is too cumbersome and has too many issues to be used effectively. + +# Test sites: +# http://jigsaw.w3.org/HTTP/ +# http://httpbin.org/ + +package require platform +package require Thread +package require sqlite3 + +if {$tcl_platform(platform) ne "windows"} { + # Need the fix for bug f583715154 + package require Tcl 8.6.11- +} + +proc ::oo::Helpers::callback {method args} { + list [uplevel 1 {::namespace which my}] $method {*}$args +} + +namespace eval www { + variable schemes { + http {port 80 command {} secure 0} + https {port 443 command www::encrypt secure 1} + } + variable encodings { + gzip {decode gzip} + deflate {decode deflate} + } + variable config { + -proxy defaultproxy + -pipeline 0 + -urlencoding utf-8 + -socketcmd socket + } + variable headers { + Accept {*/*} + Accept-Encoding {identity} + } + dict set headers User-Agent [format {Tcl-www/%s (%s)} \ + [package present www] [platform::generic]] + + variable formmap [apply [list {} { + set map {} + for {set i 0} {$i <= 256} {incr i} { + set c [format %c $i] + if {![string match {[-._~a-zA-Z0-9]} $c]} { + dict set map $c %[format %.2X $i] + } + } + return $map + }]] + variable tlscfg {} + variable defaultproxy {} + variable logpfx list + variable timer {} + variable persist 300000 + variable maxconn 256 + + # Track the persistent connections using an in-memory sqlite db + sqlite3 [namespace current]::db :memory: + db eval { + create table reuse ( + connection text primary key, + scheme text, + host text, + port text, + persistent boolean default 1 + ); + } + + namespace ensemble create -subcommands { + get post head put delete log configure register certify cookiedb + header urlencode cookies + } -map { + log logpfx + cookiedb cookies::dbfile + } + + namespace ensemble create -command cert -parameters pass -map { + error errcmd info nop verify vfycmd message nop session nop + } -unknown [namespace code unknown] + + namespace ensemble create -command stdcert -parameters pass -map { + error errcmd info nop verify stdvfy message nop session nop + } -unknown [namespace code unknown] + + namespace ensemble create -command nocert -parameters pass -map { + error errcmd info nop verify novfy message nop session nop + } -unknown [namespace code unknown] + + dict set tlscfg -command [list [namespace which nocert] 1] + dict set tlscfg -validatecommand [list [namespace which nocert] 1] +} + +proc www::log {str} { + variable logpfx + if {[catch {uplevel #0 [list {*}$logpfx $str]}]} {logpfx ""} +} + +proc www::logpfx {prefix} { + variable logpfx $prefix + if {$prefix eq ""} {set logpfx list} +} + +# Load the TLS package on the first use of a secure url. +proc www::encrypt {sock host} { + variable tlscfg + package require tls + if {[namespace which ::tls::validate_command] eq ""} { + # Old version of tls uses only -command + dict unset tlscfg -validatecommand + } + proc encrypt {sock host} { + variable tlscfg + ::tls::import $sock -servername $host {*}$tlscfg + } + tailcall encrypt $sock $host +} + +# Execute a script when a variable is accessed +proc www::varevent {name ops {script ""}} { + set cmd {{cmd var arg op} {catch {uplevel #0 $cmd}}} + foreach n [uplevel 1 [list trace info variable $name]] { + lassign $n op prefix + if {$op eq $ops && \ + [lindex $prefix 0] eq "apply" && [lindex $prefix 1] eq $cmd} { + if {[llength [info level 0]] < 4} { + return [lindex $prefix 2] + } + uplevel 1 [list trace remove variable $name $ops $prefix] + } + } + if {$script ne ""} { + uplevel 1 \ + [list trace add variable $name $ops [list apply $cmd $script]] + } + return +} + +oo::class create www::connection { + constructor {host port {transform ""}} { + namespace path [linsert [namespace path] 0 ::www] + variable fd "" timeout 30000 id "" + variable translation {crlf crlf} + variable waiting {} pending {} + # Copy the arguments to namespace variables with the same name + namespace eval [namespace current] \ + [list variable host $host port $port transform $transform] + } + + destructor { + my Disconnect + } + + method Disconnect {} { + my variable fd id + after cancel $id + if {$fd ne ""} { + rename ::www::$fd "" + if {[catch {close $fd} err]} {log "Disconnect: $err"} + set fd "" + } + } + + method Failed {code info {index 0}} { + my variable pending + my Disconnect + set callback [dict get [lindex $pending $index] Request callback] + set opts [dict create -code 1 -level 1 -errorcode $code] + # Clean up the pending request before invoking the callback in case + # the coroutine generates another request for the same connection + set pending [lreplace $pending $index $index] + $callback -options $opts $info + } + + method Failure {args} { + if {[llength $args] == 1} { + set opts [lindex $args] + } else { + set opts [dict create -code 1 -level 1] + lassign $args errorcode result + dict set opts -errorcode $errorcode + } + my variable waiting pending + foreach n [concat $pending $waiting] { + # Inform the caller of the failure + if {[catch {uplevel #0 [linsert [dict get $n callback] end $opts]} err opts]} { + log "Failure: $err" + } + } + my destroy + } + + method Pending {} { + my variable pending + set num 0 + foreach transaction $pending { + if {[dict get $transaction Attempt] > 5} { + my Failed {WWW MAXATTEMPTS} {too many attempts} $num + } else { + incr num + } + } + return [expr {$num > 0}] + } + + method Process {} { + my variable fd waiting pending + if {[llength $waiting] == 0} return + set count [llength $pending] + if {$count && [dict get [lindex $waiting 0] pipeline] == 0} return + if {$count && $fd eq ""} return + # Start processing the next request + set request [my PushRequest] + if {$fd eq ""} { + my Connect + } else { + my Request $count + } + } + + # Connect the socket in another thread to be totally non-blocking + method Connect {} { + my Disconnect + if {![my Pending]} return + coroutine connect my Initiate + } + + method Initiate {} { + if {[my Contact]} { + if {[catch {my Request} err opts]} { + log "Request: $err" + log [dict get $opts -errorinfo] + } + } + } + + method Timeout {} { + my variable pending timeout + if {[dict exists [lindex $pending 0] Request timeout]} { + return [dict get [lindex $pending 0] Request timeout] + } else { + return $timeout + } + } + + method UserVar {data} { + if {[dict exists $data Request result]} { + upvar #0 [dict get $data Request result] var + set var [dict filter $data key {[a-z]*}] + } + } + + method Contact {} { + my variable fd host port connect transform + + # Build a command to open a socket in a separate thread + set cmd [list {cmd} { + global fd result + if {![catch $cmd fd opts]} { + fileevent $fd writable {set result socket} + vwait result + fileevent $fd writable {} + if {[fconfigure $fd -connecting]} { + close $fd + set msg {connection timed out} + set fd "couldn't open socket: $msg" + dict set opts -code 1 + dict set opts -errorcode [list POSIX ETIMEDOUT $msg] + } else { + set error [fconfigure $fd -error] + if {$error eq ""} { + thread::detach $fd + } else { + close $fd + set fd "couldn't open socket: $error" + dict set opts -code 1 + switch $error { + {connection refused} { + dict set opts \ + -errorcode [list POSIX ECONNREFUSED $error] + } + {host is unreachable} { + dict set opts \ + -errorcode [list POSIX EHOSTUNREACH $error] + } + } + } + } + } + return [list $fd $opts] + }] + + set socketcmd [linsert [cget -socketcmd] end -async $host $port] + set script [list apply $cmd $socketcmd] + # Open a plain socket in a helper thread + set tid [thread::create] + set ms [my Timeout] + set id [after $ms [list thread::send -async $tid {set result timeout}]] + set var [namespace which -variable connect] + thread::send -async $tid $script $var + trace add variable $var write [list [info coroutine]] + yieldto list + trace remove variable $var write [list [info coroutine]] + after cancel $id + lassign $connect result opts + thread::release $tid + # Check the socket was opened successfully + if {[dict get $opts -code] == 0} { + set fd $result + coroutine ::www::$fd my Monitor + thread::attach $fd + fconfigure $fd -blocking 0 + # Apply any transformations, such as importing TLS + if {$transform ne ""} { + try { + {*}$transform $fd $host + } trap WWW {result opts} { + # Immediately return WWW errors, without retrying + my Failed [dict get $opts -errorcode] $result + } on error {err opts} { + log "Transform: $err" + } + } + return 1 + } else { + my Failed [list WWW CONNECT $result] $result + } + return 0 + } + + method Monitor {} { + set result [yield] + my Failed [list WWW CONNECT $result] $result + } + + method Request {{num 0}} { + my variable fd pending id + if {[eof $fd]} { + my Connect + } + + my Result connection [self] + set transaction [lindex $pending $num] + dict incr transaction Attempt + lset pending $num $transaction + # Do not report the failure at this point because the callback may + # create a new request that would mess up the order of the messages + if {[dict get $transaction Attempt] > 5} {tailcall my Pending} + try { + my Transmit [dict get $transaction Request] + } trap {POSIX EPIPE} {} { + # Force eof condition + read $fd + tailcall my Connect + } + # Now report any problems to the callers + my Pending + + if {$num == 0} {my Response} + tailcall my Process + } + + method Transmit {request} { + my variable fd + fconfigure $fd -translation [set translation {crlf crlf}] + set method [dict get $request method] + set resource [dict get $request resource] + set head [list "$method $resource HTTP/1.1"] + lappend head "Host: [dict get $request host]" + if {[dict exists $request upgrade]} { + dict update request headers hdrs upgrade upgrade { + header add hdrs Connection Upgrade + header add hdrs Upgrade {*}[dict keys $upgrade] + } + } + foreach {key val} [dict get $request headers] { + lappend head "$key: $val" + } + lappend head "" + set str [join $head \n] + log $str + puts $fd $str + if {[dict exists $request body]} { + fconfigure $fd -translation [lset translation 1 binary] + puts -nonewline $fd [dict get $request body] + } + flush $fd + } + + method Result {args} { + my variable pending + set response [lindex $pending 0] + if {[llength $args] > 1} { + lset pending 0 [dict set response {*}$args] + my UserVar $response + } elseif {[llength $args] == 0} { + return $response + } elseif {[dict exists $response {*}$args]} { + return [dict get $response {*}$args] + } + return + } + + method Response {} { + my variable fd translation id + set ms [my Timeout] + set id [after $ms [callback Timedout]] + fconfigure $fd -translation [lset translation 0 crlf] + # When the tls handshake fails, the readable event doesn't always + # fire. Adding a writable event as well improves reliability. + fileevent $fd readable [callback Statusline] + fileevent $fd writable [callback Statusline] + } + + method Statusline {} { + my variable fd + try { + fileevent $fd writable {} + if {[eof $fd]} { + my Connect + } elseif {[gets $fd line] >= 0} { + log $line + if {[scan $line {HTTP/%s %d %n} version code pos] != 3} { + my Failed [list WWW DATA STATUS] "invalid status line" + } + set reason [string range $line $pos end] + my Result status [dict create line $line \ + version HTTP/$version code $code reason $reason] + fileevent $fd readable [callback Responsehead] + } elseif {[chan pending input $fd] > 1024} { + # A status line shouldn't be this long. + my Failed [list WWW DATA STATUS] "status line too long" + } + } trap {POSIX ECONNABORTED} {msg opts} { + # This happens if there is a problem with the certificate + my Failed [dict get $opts -errorcode] $msg + } + } + + method Responsehead {} { + my variable fd + if {[eof $fd]} { + tailcall my Connect + } + set head [my Result Head] + while {[gets $fd line] >= 0} { + if {$line eq ""} { + set headers [my Headers $head] + my Result Head {} + my Result headers $headers + tailcall my Responsebody $headers + } + lappend head $line + } + my Result Head $head + } + + method Headers {head} { + # Unfold headers + foreach x [lreverse [lsearch -all -regexp $head {^\s}]] { + set str [string trimright [lindex $head [expr {$x - 1}]]] + append str " " [string trimleft [lindex $head $x]] + set head [lreplace $head [expr {$x - 1}] $x $str] + } + log [join $head \n]\n + # Parse headers into a list + set rc {} + foreach str $head { + lassign [slice $str] name value + lappend rc [string tolower $name] $value + } + return $rc + } + + method Responsebody {headers} { + my variable fd translation + set code [dict get [my Result status] code] + variable size 0 length 0 + if {[dict get [my Result Request] method] eq "HEAD"} { + # All responses to the HEAD request method MUST NOT include + # a message-body, even though the presence of entity-header + # fields might lead one to believe they do + tailcall my Finished + } elseif {$code eq "101" && [header exists $headers upgrade]} { + tailcall my Upgrade $headers + } elseif {[string match 1?? $code] || $code in {204 304}} { + # All 1xx (informational), 204 (no content), and 304 (not + # modified) responses MUST NOT include a message-body + tailcall my Finished + } + set enc [header get $headers content-encoding all -lowercase] + set transfer [header get $headers transfer-encoding all -lowercase] + foreach n $transfer {if {$n ni {chunked identity}} {lappend enc $n}} + if {[llength $transfer] == 0} {set transfer [list identity]} + my Result Encoding [lmap name [lreverse $enc] { + set coro encodingcoro_$name + coroutine $coro {*}[encodingcmd $name] + set coro + }] + if {"identity" ni $transfer} { + fileevent $fd readable [callback Responsechunks] + } elseif {[header exists $headers content-length]} { + set length [header get $headers content-length last] + if {$length} { + fconfigure $fd -translation [lset translation 0 binary] + fileevent $fd readable [callback Responsecontent] + } else { + my Finished + } + } elseif {[header get $headers content-type last] \ + eq "multipart/byteranges"} { + # Not currently implemented + my Failure + } else { + # Read data until the connection is closed + fconfigure $fd -translation [lset translation 0 binary] + fileevent $fd readable [callback Responserest] + } + } + + method Responsecontent {} { + my variable fd size length + if {[eof $fd]} { + tailcall my Connect + } + set data [read $fd [expr {$length - $size}]] + if {$data ne ""} { + incr size [string length $data] + my Progress $data + log "Received $size/$length" + if {$size >= $length} { + my Finished + } + } + } + + method Responsechunks {} { + my variable fd translation size length + if {[eof $fd]} { + tailcall my Finished + } + if {$length == 0} { + if {[gets $fd line] <= 0} return + lassign [slice $line {;}] hex ext + scan $hex %x length + if {$length == 0} { + fileevent $fd readable [callback Responsetrailer] + return + } + set size 0 + fconfigure $fd -translation [lset translation 0 binary] + } + set data [read $fd [expr {$length - $size}]] + if {$data ne ""} { + incr size [string length $data] + # log "$size/$length" + my Progress $data + if {$size >= $length} { + fconfigure $fd -translation [lset translation 0 crlf] + set length 0 + } + } + } + + method Responsetrailer {} { + my variable fd + set tail [my Result Tail] + if {[eof $fd]} { + set done 1 + } else { + set done 0 + while {[gets $fd line] >= 0} { + if {$line eq ""} { + set done 1 + break + } + lappend tail $line + } + } + if {$done} { + if {$tail ne ""} { + my Result Tail {} + set headers [my Result headers] + my Result headers [dict merge $headers [my Headers $tail]] + } + tailcall my Finished + } else { + my Result Tail $tail + } + } + + method Responserest {} { + my variable fd + if {[eof $fd]} { + tailcall my Finished + } + my Progress [read $fd] + } + + method Responseidle {} { + my variable fd + read $fd + if {[eof $fd]} { + my destroy + } + } + + method Progress {{data ""}} { + set finish [expr {$data eq ""}] + foreach n [my Result Encoding] { + if {$data ne ""} {set data [$n $data]} + if {$finish} {append data [$n]} + } + if {$data eq ""} return + + set request [my Result Request] + set handler \ + [if {[dict exists $request handler]} {dict get $request handler}] + + if {$handler eq ""} { + set body [my Result Body] + my Result Body [append body $data] + } else { + uplevel #0 [linsert $handler end $data] + } + } + + method PushRequest {} { + # Move the next request from the waiting queue to the pending queue + my variable waiting pending + set waiting [lassign $waiting request] + set transaction [dict create Request $request Attempt 0] + # Provide some information back to the caller + dict set transaction url [dict get $request url] + dict set transaction uri [dict get $request resource] + lappend pending $transaction + return $request + } + + method PopRequest {} { + my variable pending + set pending [lassign $pending result] + return $result + } + + method Finished {} { + my variable fd id pending waiting + # Process any leftover data and end the coroutines + my Progress + set result [my PopRequest] + if {[scan [dict get $result status version] HTTP/%s version] != 1} { + tailcall my Failure \ + "invalid HTTP version: [dict get $result status version]" + } + set connection \ + [header get [dict get $result headers] connection all -lowercase] + after cancel $id + if {[llength $pending]} { + my Response + } else { + fileevent $fd readable [callback Responseidle] + } + if {![package vsatisfies $version 1.1] || "close" in $connection} { + my Disconnect + my Return $result + if {[llength $pending] == 0 && [llength $waiting] == 0} { + # Nothing left to do. Destroy the object, if it still exists. + if {[self] ne ""} {my destroy} + return + } + } else { + keep [self] + my Return $result + } + # The callback may have destroyed the object + if {[self] ne ""} {my Process} + } + + method Return {result} { + set callback [dict get $result Request callback] + set data [if {[dict exists $result Body]} {dict get $result Body}] + dict unset result connection + my UserVar $result + # Just like in TclOO, public names start with a lowercase letter + $callback -options [dict filter $result key {[a-z]*}] $data + } + + method Upgrade {headers} { + my variable fd id + set upgrade [header get $headers upgrade] + # Unfortunately (some) upgrade protocol names are not case sensitive + try { + dict for {name mixin} [dict get [my Result Request] upgrade] { + if {![string equal -nocase $name $upgrade]} continue + after cancel $id + oo::objdefine [self] mixin $mixin + my Startup $headers + return + } + my Failed {WWW UPGRADE} "protocol not supported: $upgrade" + } on error {msg info} { + log [dict get $info -errorinfo] + } + } + + method Timedout {} { + my Failed {WWW DATA TIMEOUT} "timeout waiting for a response" + } + + method request {data} { + my variable waiting + dict set data callback [info coroutine] + lappend waiting $data + return {*}[yieldto my Process] + } + + method fd {} { + my variable fd + return $fd + } + + method disconnect {} { + my Finished + } +} + +# Use a derived class to simplify setting up an HTTP tunnel to a proxy server +oo::class create www::proxyconnect { + superclass www::connection + + constructor {fh} { + namespace path [linsert [namespace path] 0 ::www] + variable fd $fh timeout 30000 id "" + variable translation {crlf crlf} + variable waiting {} pending {} + } + + destructor { + # Obscure the connection destructor, which would disconnect the socket + } + + method connect {resource} { + set request {headers {}} + dict set request method CONNECT + dict set request resource $resource + dict set request host $resource + dict set request url $resource + dict set request path $resource + try { + my request $request + } on ok {data opts} { + set code [dict get $opts status code] + if {![string match 2?? $code]} { + set codegrp [string replace $code 1 2 XX] + set reason [dict get $opts status reason] + dict set opts -code 1 + dict set opts -errorcode [list WWW CODE $codegrp $code $reason] + } + return -options [dict incr opts -level] $data + } + } + + method Responsebody {headers} { + set code [dict get [my Result status] code] + if {[string match 2?? $code]} { + # A "200 Connection established" response doesn't have a body + tailcall my Finished + } else { + # All other responses are treated normally, but will finally fail + next $headers + } + } +} + +namespace eval www::cookies { + variable cookiejar "" + namespace path [namespace parent] + namespace ensemble create -subcommands {delete get store} +} + +proc www::cookies::dbfile {filename} { + variable cookiejar $filename +} + +proc www::cookies::db {args} { + variable cookiejar + sqlite3 [namespace current]::db $cookiejar + set create { + create table if not exists %s.cookies ( + domain text, + path text, + name text, + value text, + created int, + accessed int, + expires int not null default 4294967295, + attributes text, + primary key (domain, path, name) + ); + } + db transaction { + db eval [format $create main] + # Add a temporary database to hold the session cookies + db eval {attach database "" as sess} + db eval [format $create sess] + # Create a view combining the two tables to simplify access + # This must be a temporary view to allow combining two databases + db eval { + create temp view cookieview as \ + select domain, path, name, value, \ + created, accessed, expires, attributes \ + from main.cookies \ + union all \ + select domain, path, name, value, \ + created, accessed, expires, attributes \ + from sess.cookies + } + # Clean up expired cookies + set now [clock seconds] + db eval {delete from cookies where expires < $now} + } + tailcall db {*}$args +} + +proc www::cookies::date {str} { + # Implement most of the weird date and time parsing rules of RFC 6265 + # https://tools.ietf.org/html/rfc6265#section-5.1.1 + set time {} + foreach token [regexp -all -inline -nocase {[0-9A-Z:]+} $str] { + switch -nocase -regexp -matchvar match $token { + {^\d\d?:\d\d?:\d\d?} { + if {![dict exists $time %T]} { + dict set time %T $match + } + } + {^\d{5}} {} + {^\d{4}} { + if {![dict exists $time %Y]} { + dict set time %Y $match + } + } + {^\d{3}} {} + {^\d{2}} { + if {![dict exists $time %d]} { + dict set time %d $match + } elseif {![dict exists $time %Y]} { + incr match [expr {$match < 70 ? 2000 : 1900}] + dict set time %Y $match + } + } + ^jan - ^feb - ^mar - ^apr - + ^may - ^jun - ^jul - ^aug - + ^sep - ^oct - ^nov - ^dec { + if {![dict exists $time %b]} { + dict set time %b $match + } + } + } + } + if {[dict size $time] == 4} { + return [clock scan [join [dict values $time]] \ + -format [join [dict keys $time]] -timezone :UTC] + } + # invalid expiry date +} + +proc www::cookies::store {url args} { + set rec [parseurl $url] + set now [clock seconds] + db transaction { + foreach n $args { + set args {} + foreach av [lassign [split $n {;}] pair] { + lassign [slice $av =] key value + dict set args [string tolower $key] $value + } + lassign [slice $pair =] name value + array unset arg + set host [dict get $rec host] + if {[dict exists $args domain]} { + set str [dict get $args domain] + if {[string index $str 0] eq "."} { + set str [string range $str 1 end] + } + set pat [format {*.%s} [string tolower $str]] + if {$host eq $str || [string match $pat $host]} { + set arg(domain) $pat + } else { + # Reject the cookie because of an invalid domain + continue + } + } else { + set arg(domain) $host + } + set path [dict get $rec path] + set arg(path) [file join [if {[dict exists $args path]} { + dict get $args path + } else { + file dirname $path + }] *] + if {![string match $arg(path) $path]} { + # Reject the cookie because of an invalid path + continue + } + if {[dict exists $args max-age]} { + set maxage [dict get $args max-age] + if {[string is integer -strict $maxage]} { + set arg(expires) [expr {[clock seconds] + $maxage}] + } + } elseif {[dict exists $args expires]} { + set sec [date [dict get $args expires]] + if {$sec ne ""} {set arg(expires) $sec} + } + if {[dict exists $args secure]} { + lappend arg(attr) secure + } + if {[dict exists $args httponly]} { + lappend arg(attr) httponly + } + set arg(created) $now + set arg(accessed) $now + db eval { + select created, attributes from cookies \ + where name = $name \ + and domain = $arg(domain) and path = $arg(path) + } { + set arg(created) $created + } + if {[info exists arg(expires)]} {set db main} else {set db sess} + db eval [format { + replace into %s.cookies \ + (domain, path, name, value, created, accessed, expires, attributes) \ + values ($arg(domain), $arg(path), $name, $value, $arg(created), $arg(accessed), $arg(expires), $arg(attr)) + } $db] + } + } +} + +proc www::cookies::get {url} { + set rec [parseurl $url] + set host [dict get $rec host] + set path [dict get $rec path] + set scheme [dict get $rec scheme] + set attr {} + if {[secure $scheme]} {lappend attr secure} + if {$scheme in {http https}} {lappend attr httponly} + set now [clock seconds] + set rc {} + db eval { + select name, value, attributes, expires from cookieview \ + where (domain = '*.' || $host or $host glob domain) \ + and $path glob path \ + order by length(path), created + } { + set allowed [expr {$expires >= $now}] + foreach a $attributes { + if {$a ni $attr} {set allowed 0} + } + if {$allowed} { + lappend rc $name $value + } + } + return $rc +} + +proc www::cookies::delete {url args} { + set rec [parseurl $url] + set host [dict get $rec host] + set where [list {domain = $host}] + if {$host ne $url} { + set path [dict get $rec path] + lappend where {$path glob path} + } + set i 0 + set names [lmap n $args { + set arg([incr i]) $n + format {$arg(%d)} $i + }] + if {$i} {lappend where [format {name in (%s)} [join $names ,]]} + set query "delete from %s where [join $where { and }]" + db eval [format $query main.cookies] + db eval [format $query sess.cookies] +} + +proc www::slice {str {sep :}} { + set x [string first $sep $str] + if {$x < 0} {return [list [string trim $str]]} + return [list [string trim [string range $str 0 [expr {$x - 1}]]] \ + [string trim [string range $str [expr {$x + [string length $sep]}] end]]] +} + +proc www::secure {scheme} { + variable schemes + if {[dict exists $schemes $scheme secure]} { + return [dict get $schemes $scheme secure] + } else { + return 0 + } +} + +proc www::urljoin {url args} { + foreach n $args { + switch -glob $n { + *://* { + # Absolute URL + set url $n + } + //* { + # URL relative on current scheme + set x [string first :// $url] + set url [string replace $url [expr {$x + 1} end $n] + } + /* { + # URL relative to the root of the website + set x [string first :// $url] + set x [string first / $url [expr {$x + 3}]] + if {$x < 0} { + append url $n + } else { + set url [string replace $url $x end $n] + } + } + * { + # Relative URL + set x [string first ? $url] + if {$x < 0} { + set x [string first # $url] + if {$x < 0} { + set x [string length $url] + } + } + set x [string last / $url $x] + if {$x < [string first :// $url] + 3} { + append url / $n + } else { + set url [string replace $url $x end $n] + } + } + } + } + return $url +} + +proc www::parseurl {url} { + variable schemes + set list [slice $url ://] + if {[llength $list] < 2} {set list [list http $url]} + lassign $list scheme str + if {![dict exists $schemes $scheme port]} { + throw {WWW URL SCHEME} "unknown scheme: $scheme" + } + lassign [slice $str /] authority str + lassign [slice /$str #] resource fragment + lassign [slice $resource ?] path query + set rc [dict create url $url scheme $scheme host localhost \ + port [dict get $schemes $scheme port] \ + command [dict get $schemes $scheme command] \ + resource $resource path $path fragment $fragment] + set slice [slice $authority @] + dict set rc host [lindex $slice end] + if {[llength $slice] > 1} { + lassign [slice [lindex $slice 0]] username password + dict set rc username $username + dict set rc password $password + } + return $rc +} + +proc www::getopt {var list body} { + upvar 1 $var value + dict for {pat code} $body { + switch -glob -- $pat { + -- {# end-of-options option} + -?*:* {# option requiring an argument + set opt [lindex [split $pat :] 0] + set arg($opt) [dict create pattern $pat argument 1] + # set arg(-$opt) $arg($opt) + } + -?* {# option without an argument + set arg($pat) [dict create pattern $pat argument 0] + # set arg(-$pat) $arg($pat) + } + } + } + while {[llength $list]} { + set rest [lassign $list opt] + # Does it look like an option? + if {$opt eq "-" || [string index $opt 0] ne "-"} break + # Is it the end-of-options option? + if {$opt eq "--"} {set list $rest; break} + set value 1 + if {![info exists arg($opt)]} { + throw {WWW GETOPT OPTION} "unknown option: $opt" + } elseif {[dict get $arg($opt) argument]} { + if {![llength $rest]} { + throw {WWW GETOPT ARGUMENT} \ + "option requires an argument: $opt" + } + set rest [lassign $rest value] + } + uplevel 1 [list switch -- [dict get $arg($opt) pattern] $body] + set list $rest + } + return $list +} + +proc www::stdopts {{body {}}} { + return [dict merge { + -timeout:milliseconds { + dict set request timeout $arg + } + -auth:data { + dict set request headers \ + Authorization "Basic [binary encode base64 $arg]" + } + -digest:cred { + dict set request digest [slice $arg] + } + -persistent:bool { + if {[string is false -strict $arg]} { + dict set request headers Connection close + } + } + -headers:dict { + dict update request headers hdrs { + foreach {name value} $arg { + header append hdrs $name $value + } + } + } + -upgrade:dict { + dict set request upgrade $arg + } + -handler:cmdprefix { + dict set request handler $arg + } + -maxredir:cnt { + dict set request maxredir $arg + } + -infovariable:var { + dict set request result $arg + } + } $body] +} + +proc www::postopts {} { + return { + -multipart:type { + dict set request multipart $arg + } + -name:string { + dict set request partdata name $arg + } + -type:mediatype { + dict set request partdata type $arg + } + -file:file { + dict set request partdata file $arg + dict lappend request parts [dict get $request partdata] + dict unset request partdata file + } + -value:string { + dict set request partdata value $arg + dict lappend request parts [dict get $request partdata] + dict unset request partdata value + } + } +} + +proc www::configure {args} { + variable config + variable headers + set args [getopt arg $args { + -accept:mimetypes { + header add headers Accept {*}$arg + } + -maxconnections:count { + if {[string is integer -strict $arg] && $arg > 0} { + variable maxconn $arg + } else { + return -code error -errorcode {WWW CONFIGURE INVALID} \ + "bad argument \"$arg\": must be a positive integer" + } + } + -persist:milliseconds { + if {[string is integer -strict $arg] && $arg > 0} { + variable persist $arg + } else { + return -code error -errorcode {WWW CONFIGURE INVALID} \ + "bad argument \"$arg\": must be a positive integer" + } + } + -pipeline:boolean { + if {[catch {expr {!!$arg}} arg]} { + return -code error -errorcode {WWW CONFIGURE INVALID} \ + "bad argument \"$arg\": must be a boolean value" + } else { + dict set config -pipeline $arg + } + } + -proxy:cmdprefix { + dict set config -proxy $arg + } + -socketcmd:prefix { + dict set config -socketcmd $arg + } + -useragent:string { + header replace headers User-Agent $arg + } + }] +} + +proc www::cget {opt} { + variable config + if {[dict exists $config $opt]} { + return [dict get $config $opt] + } + set valid [lsort [dict keys $config]] + if {[llength $valid] > 1} {lset valid end "or [lindex $valid end]"} + retrun -code error -errorcode {WWW CONFIGURE UNKNOWN} \ + [format {unknown option: "%s"; must be %s} $opt [join $valid ,]] +} + +proc www::certify {cainfo {prefix ""}} { + variable tlscfg + variable cacheck $prefix + set status 0 + if {$cainfo eq ""} { + set status 1 + dict unset tlscfg -cadir + dict unset tlscfg -cafile + } elseif {[file isdir $cainfo]} { + dict set tlscfg -cadir $cainfo + dict unset tlscfg -cafile + } else { + dict set tlscfg -cafile $cainfo + dict unset tlscfg -cadir + } + if {$prefix ne ""} { + set callback [list [namespace which cert] $status] + } elseif {$cainfo ne ""} { + set callback [list [namespace which stdcert] $status] + } else { + set callback [list [namespace which nocert] $status] + } + dict set tlscfg -command $callback + if {[dict exists $tlscfg -validatecommand]} { + dict set tlscfg -validatecommand $callback + } + # Prevent reusing old connections that were created using a different + # certification strategy. + db eval {select connection from reuse where scheme = 'https'} { + $connection destroy + } +} + +proc www::unknown {args} { + return [list [namespace which nop]] +} + +proc www::nop args {} + +proc www::novfy {args} { + # Accept anything + return 1 +} + +proc www::stdvfy {pass chan depth cert status args} { + return $status +} + +proc www::vfycmd {pass chan depth cert status args} { + variable cacheck + try { + if {$pass} {set status 1} + set rc [uplevel #0 [linsert $cacheck end $depth $cert]] + if {[string is boolean -strict $rc]} {set status [string is true $rc]} + } on error msg { + log "Error: $msg" + } + return $status +} + +proc www::errcmd {pass sock msg} { + # Errors aren't necessarily fatal + # Handshake not complete, will retry later + # Resource temporarily unavailable + #$sock $msg +} + +proc www::encodingcmd {name} { + variable encodings + return [dict get $encodings $name] +} + +namespace eval www { + # The three compression formats deflate, compress, and gzip are all the + # same, except for headers and checksums. The Tcl zlib package uses the + # following mapping: + # deflate: raw compressed data only + # compress: 2-byte header (78 ..) + data + ADLER32 checksum + # gzip: 10-byte header (1F 8B 08 ...) + data + CRC-32 checksum + # The http 1.1 spec rfc2616 uses the same names with the following mapping: + # deflate: 2-byte header (78 ..) + data + ADLER32 checksum + # compress: different compression method used by unix compress command + # gzip: 10-byte header (1F 8B 08 ...) + data + CRC-32 checksum + # One additional complication is that Microsoft got it wrong again and + # made IE to expect a bare deflate stream for content-encoding deflate, + # so some sites may provide that instead of the correct format. Other + # browsers adapted by accepting both types. + namespace ensemble create -command decode \ + -subcommands {gzip compress deflate} +} + +proc www::gzip {} { + set cmd [zlib stream gunzip] + set data [yield] + while {$data ne ""} { + set data [yield [$cmd add $data]] + } + set rc [if {![$cmd eof]} {$cmd add -finalize {}}] + $cmd close + return $rc +} + +proc www::deflate {} { + set cmd [zlib stream decompress] + set data [yield] + if {$data ne ""} { + try { + $cmd add $data + } trap {TCL ZLIB DATA} {} { + # log "Decompress failed, trying inflate" + $cmd close + set cmd [zlib stream inflate] + set data [$cmd add $data] + } on ok {data} { + } + set data [yield $data] + while {$data ne ""} { + set data [yield [$cmd add $data]] + } + } + set rc [if {![$cmd eof]} {$cmd add -finalize {}}] + $cmd close + return $rc +} + +proc www::proxies {rec} { + variable config + set cmd [dict get $config -proxy] + if {$cmd eq ""} {return [list DIRECT]} + set host [dict get $rec host] + set scheme [dict get $rec scheme] + if {$scheme eq "https"} { + set url [format %s://%s/ $scheme $host] + } else { + set url [dict get $rec url] + } + try { + return [uplevel 0 [linsert $cmd end $url $host]] + } on error {err opts} { + return [list DIRECT] + } +} + +proc www::noproxy {url host} { + return [list DIRECT] +} + +proc www::defaultproxy {url host} { + variable defaultproxy + if {[dict size $defaultproxy] == 0} { + global env + dict set defaultproxy no {} + foreach n [array names env -regexp {(?i)_proxy$}] { + set scheme [string tolower [string range $n 0 end-6]] + set proxy $env($n) + if {$scheme eq "no"} { + dict set defaultproxy no [split $proxy {;,}] + continue + } elseif {[string match *://* $proxy]} { + set proxy [dict get [parseurl $env(http_proxy)] host] + } + dict set defaultproxy $scheme [list [list PROXY $proxy]] + } + } + set scheme [lindex [slice $url ://] 0] + if {[dict exists $defaultproxy $scheme]} { + foreach domain [dict get $defaultproxy no] { + if {[string match $domain $host]} { + return [list DIRECT] + } + } + return [dict get $defaultproxy $scheme] + } + return [list DIRECT] +} + +proc www::httpproxy {server url host} { + return [list "HTTP $server"] +} + +proc www::httpsproxy {server url host} { + return [list "HTTPS $server"] +} + +proc www::socksproxy {server url host} { + return [list "SOCKS $server"] +} + +proc www::socks4proxy {server url host} { + return [list "SOCKS4 $server"] +} + +proc www::socks5proxy {server url host} { + return [list "SOCKS5 $server"] +} + +proc www::register {scheme port {command ""} {secure 0}} { + variable schemes + dict set schemes $scheme \ + [dict create port $port command $command secure $secure] + return +} + +proc www::urlencode {str} { + variable config + variable formmap + set string [encoding convertto [dict get $config -urlencoding] $str] + return [string map $formmap $str] +} + +proc www::challenge {str} { + scan $str {%s %n} type pos + set rc {} + foreach n [split [string range $str $pos end] ,] { + lassign [slice $n =] key val + if {[string match {"*"} $val]} {set val [string range $val 1 end-1]} + dict set rc $key $val + } + return [list $type $rc] +} + +proc www::hostport {dest {defaultport 80}} { + # Extract host and port from the destination specification + if {[regexp {^\[([[:xdigit:]:]+)\]} $dest ipv6 host]} { + set l [string length $ipv6] + if {$l == [string length $spec]} { + return [list $host $defaultport] + } elseif {[string index $spec $l] eq ":"} { + return [list $host [string range $spec [expr {$l + 1}] end]] + } else { + throw {WWW URL HOSTSPEC} "invalid host specification" + } + } else { + set rc [slice $dest] + if {[llength $rc] < 2} {lappend rc $defaultport} + return $rc + } +} + +proc www::reuse {scheme host port cmd} { + variable timer + variable maxconn + # Check if a connection to the requested destination already exists + db eval {select connection from reuse \ + where scheme = $scheme and host = $host and port = $port} { + after cancel [dict get $timer $connection] + dict unset timer $connection + dict set timer $connection {} + return $connection + } + if {[dict size $timer] >= $maxconn} { + # Delete the oldest connection + dict for {key val} $timer { + $key destroy + break + } + } + set conn [{*}$cmd] + db eval {insert into reuse (connection, scheme, host, port) \ + values($conn, $scheme, $host, $port)} + + # Arrange to update the administration when the object disappears + trace add command $conn delete [list apply [list {obj args} { + release $obj + } [namespace current]]] + + dict set timer $conn {} + return $conn +} + +proc www::release {obj} { + variable timer + log "Deleting connection $obj" + db eval {delete from reuse where connection = $obj} + log "deleted [db changes] rows" + after cancel [dict get $timer $obj] + dict unset timer $obj +} + +proc www::keep {obj} { + variable timer + variable persist + # Stop the timer and move the connection to the end of the dict + after cancel [dict get $timer $obj] + dict unset timer $obj + dict set timer $obj [after $persist [list $obj destroy]] +} + +proc www::headers {extra} { + variable headers + variable encodings + set hdrs $headers + header add hdrs Accept-Encoding {*}[dict keys $encodings] + foreach {name value} $extra { + header replace hdrs $name $value + } + return $hdrs +} + +namespace eval www::header { + namespace ensemble create -subcommands {exists get replace append add} + + proc indexlist {hdrs name} { + return [lmap n [lsearch -all -nocase -exact $hdrs $name] { + if {$n % 2} continue else {expr {$n + 1}} + }] + } + + proc exists {hdrs name} { + # Usage: header exists headerlist name + # Check if a header with the specified name exists + return [expr {[llength [indexlist $hdrs $name]] != 0}] + } + + proc get {hdrs name args} { + # Usage: header get headerlist name ?index? ?-lowercase? + # Return the value of the requested header, if any. By default all + # entries are joined together, separated with a comma and a space. + # The resulting string is returned. + # If an index is specified, that is taken as an indication that the + # header value is defined as a comma-separated list. In that case, + # a Tcl list is constructed from the individual elements of all + # entries. The requested index from the resulting list is returned. + # The special index "all" causes the complete list to be returned. + # When the -lowercase option is specified, all values are converted + # to lower case. + if {[lindex $args 0] eq "-lowercase"} { + set cmd [list string tolower] + set index [lindex $args 1] + } else { + set cmd [list string cat] + set index [lindex $args 0] + } + if {$index eq ""} { + return [join [lmap n [indexlist $hdrs $name] { + {*}$cmd [lindex $hdrs $n] + }] {, }] + } + set list [indexlist $hdrs $name] + set rc {} + if {[string equal -nocase $name Set-Cookie]} { + # The Set-Cookie header is special + foreach h $list {lappend rc [lindex $hdrs $h]} + } else { + foreach h $list { + foreach v [split [lindex $hdrs $h] ,] { + lappend rc [{*}$cmd [string trim $v]] + } + } + } + if {$index eq "all"} { + return $rc + } elseif {$index eq "last"} { + return [lindex $rc end] + } else { + return [lindex $rc $index] + } + } + + proc add {var name args} { + # Usage: header add headerlistvar name ?-nocase? value ?...? + # Add one or more values to a header, if they are not alread present + # The -nocase option makes the compare operation case insensitive. + upvar 1 $var hdrs + set list [get [lappend hdrs] $name all] + set opts -exact + if {[lindex $args 0] eq "-nocase"} { + lappend opts -nocase + set args [lrange $args 1 end] + } + foreach arg $args { + if {[lsearch {*}$opts $list $arg] < 0} { + lappend list $arg + } + } + return [replace hdrs $name [join $list {, }]] + } + + proc append {var name args} { + # Usage: header append headerlistvar name ?value? ?...? + # Set a new value for a header in addition to any existing values + upvar 1 $var hdrs + set list [indexlist [lappend hdrs] $name] + set values [linsert $args 0 {*}[lmap n $list {lindex $hdrs $n}]] + set index end + foreach index [lreverse $list] { + set hdrs [lreplace $hdrs [expr {$index - 1}] $index] + incr index -1 + } + set hdrs [linsert $hdrs $index $name [join $values {, }]] + } + + proc replace {var name args} { + # Usage: header replace headerlistvar name ?value? ?...? + # Set a new value for a header replacing all existing entries. + # Multiple values are joined together into a comma-separated list. + # If no values are specified, all entries for the header are removed. + upvar 1 $var hdrs + set index end + foreach index [lreverse [indexlist [lappend hdrs] $name]] { + set hdrs [lreplace $hdrs [expr {$index - 1}] $index] + incr index -1 + } + if {[llength $args]} { + set hdrs [linsert $hdrs $index $name [join $args {, }]] + } + return $hdrs + } +} + +proc www::boundary {} { + # Generate a unique boundary string + for {set i 0} {$i < 6} {incr i} { + lappend data [expr {int(rand() * 0x100000000)}] + } + # ModSecurity 2.9.2 complains about some characters in the boundary + # string that are perfectly legal according to RFC 2046. "/" is one + # of them. (It looks like this is fixed in ModSecurity 2.9.3.) + # Wireshark also has issues when the boundary contains a "/". + return [string map {/ -} [binary encode base64 [binary format I* $data]]] +} + +proc www::formdata {list} { + return [lmap {name value} $list { + dict create name $name value $value + }] +} + +proc www::multipart {sep parts {disp ""}} { + set rc {} + foreach part $parts { + lassign [bodypart $part $disp] body hdrs + lappend rc "--$sep" + foreach {hdr val} $hdrs { + lappend rc "$hdr: $val" + } + lappend rc "" $body + } + lappend rc --$sep-- + return [join $rc \r\n] +} + +proc www::mimetype {file} { + return application/octet-string +} + +proc www::bodypart {data {disp ""}} { + if {$disp ne ""} { + if {[dict exists $data name]} { + set name [dict get $data name] + } else { + set name value + } + set dispstr [format {%s; name="%s"} $disp $name] + if {[dict exists $data file]} { + set filename [file tail [dict get $data file]] + append dispstr [format {; filename="%s"} $filename] + } + header replace hdrs Content-Disposition $dispstr + } + if {$disp eq "" || ![dict exists $data value]} { + if {[dict exists $data type]} { + set type [dict get $data type] + } elseif {[dict exists $data file]} { + set type [mimetype [dict get $data file]] + } else { + set type application/octet-string + } + header replace hdrs Content-Type $type + } + if {[dict exists $data value]} { + set body [dict get $data value] + } elseif {[dict exists $data file]} { + set f [open [dict get $data file] rb] + set body [read $f] + close $f + } else { + set body {} + } + return [list $body $hdrs] +} + +proc www::bodybuilder {method url request args} { + dict lappend request headers + dict lappend request parts + if {[llength $args] % 2} { + dict set request partdata value [lindex $args end] + set args [lrange $args 0 end-1] + dict lappend request parts [dict get $request partdata] + } + if {$method in {POST}} { + if {[llength [dict get $request parts]] == 0} { + set type application/x-www-form-urlencoded + } elseif {[llength [dict get $request parts]] > 1 || [llength $args]} { + set type multipart/form-data + } else { + set type application/octet-string + } + } elseif {[llength [dict get $request parts]] > 1} { + set type multipart/mixed + } elseif {[llength [dict get $request parts]]} { + set type application/octet-string + } else { + set type "" + } + + if {[dict exists $request multipart]} { + switch [dict get $request multipart] { + "" { + set type "" + } + formdata { + set type multipart/form-data + } + default { + set type multipart/[dict get $request multipart] + } + } + } + + set query {} + set parts [if {[dict exists $request parts]} {dict get $request parts}] + if {$type eq "multipart/form-data"} { + set sep [boundary] + set body [multipart $sep [concat $parts [formdata $args]] form-data] + append type "; boundary=$sep" + } elseif {$type eq "application/x-www-form-urlencoded"} { + set body [join [lmap {key val} $args { + string cat [urlencode $key] = [urlencode $val] + }] &] + } else { + set query $args + if {[string match multipart/* $type]} { + set sep [boundary] + set body [multipart $sep $parts] + append type "; boundary=$sep" + } elseif {[llength $parts]} { + lassign [bodypart [lindex $parts 0]] body hdrs + set type [header get $hdrs Content-Type] + } + } + if {[llength $query]} { + append url ? [join [lmap {key val} $args { + string cat [urlencode $key] = [urlencode $val] + }] &] + } + dict set request url $url + if {$type ne ""} { + dict set request body $body + dict set request headers Content-Type $type + } + return $request +} + +proc www::request {method url request args} { + variable requestid + set request [bodybuilder $method $url $request {*}$args] + # Get a local copy of the requestid, because the requestcoro may need to + # perform a new request to obtain proxies, which would change requestid + set id [incr requestid] + set cmdline [list coroutine request$id requestcoro $method $request] + set coro [info coroutine] + if {$coro ne ""} { + {*}$cmdline [list $coro] + lassign [yield] data opts + } else { + variable result + {*}$cmdline [list set [namespace which -variable result]($id)] + vwait [namespace which -variable result]($id) + lassign $result($id) data opts + unset result($id) + } + if {[dict get $opts -code]} { + return -options [dict incr opts -level] $data + } + set code [dict get $opts status code] + if {$code in {101 200 201 202 204 207 304}} { + # 101 Switching protocols + # 200 OK + # 201 Created + # 202 Accepted + # 204 No Content + # 207 Multi-Status (WEBDAV) + # 304 Not Modified + return -options [dict incr opts -level] $data + } elseif {$code in {301 302 303 307 308}} { + # 301 Moved Permanently + # 302 Found + # 303 See Other + # 307 Temporary Redirect + # 308 Permanent Redirect + set redir [dict get $request maxredir] + if {$redir > 0} { + dict incr request maxredir -1 + } + if {$redir} { + if {$code eq "303"} { + set method GET + dict unset request body + # Remove any Content-Length headers + dict update request headers hdrs { + header replace hdrs Content-Length + } + } + set url [dict get $request url] + set location [header get [dict get $opts headers] location] + log "Redirected to: $location" + tailcall request $method [urljoin $url $location] $request + } + } elseif {$code eq "401" \ + && [header exists [dict get $opts headers] www-authenticate]} { + # 401 Unauthorized + set challenge [header get [dict get $opts headers] www-authenticate] + lassign [challenge $challenge] type args + # RFC 2068 10.4.2: If the request already included Authorization + # credentials, then the 401 response indicates that authorization + # has been refused for those credentials. + # RFC 2069 2.1.1: stale - A flag, indicating that the previous + # request from the client was rejected because the nonce value was + # stale. If stale is TRUE (in upper or lower case), the client may + # wish to simply retry the request with a new encrypted response, + # without reprompting the user for a new username and password. + set stale [expr {[dict exists $args stale] \ + && [string equal -nocase [dict get $args stale] true]}] + set auth [header get [dict get $request headers] Authorization] + if {$auth ne "" && !$stale} { + # Credentials must be incorrect + } elseif {$type eq "Digest" && [dict exists $request digest]} { + package require www::digest + lassign [dict get $request digest] user password + set body \ + [if {[dict exists $request body]} {dict get $request body}] + set uri [dict get $opts uri] + dict update request headers hdrs { + set cred \ + [digest::digest $args $user $password $method $uri $body] + header replace hdrs Authorization $cred + } + tailcall request $method [dict get $opts url] $request + } + } + set codegrp [string replace $code 1 2 XX] + set reason [dict get $opts status reason] + dict set opts -code 1 + dict set opts -errorcode [list WWW CODE $codegrp $code $reason] + return -options [dict incr opts -level] $data +} + +proc www::requestcoro {method request callback} { + variable config + variable headers + variable schemes + set url [dict get $request url] + set hdrs [dict get $request headers] + set cookies [lmap {n v} [cookies get $url] {string cat $n = $v}] + if {[llength $cookies]} { + header replace hdrs Cookie [join $cookies {; }] + } else { + header replace hdrs Cookie + } + set rec [parseurl $url] + set proxies [proxies $rec] + foreach n $proxies { + lassign $n keyword arg + set scheme [dict get $rec scheme] + switch $keyword { + PROXY - HTTP - HTTPS { + if {$keyword eq "HTTPS"} { + set version https + } else { + set version http + } + set transform [dict get $schemes $scheme command] + if {[llength $transform]} { + # If a transformation must be applied, an HTTP tunnel is + # needed via the CONNECT method + # Once the tunnel is established, the connection is to the + # remote server. Scheme, host and port must point there. + set host [dict get $rec host] + set port [dict get $rec port] + set transform \ + [list proxyinit $version $host $port $transform] + lassign [hostport $arg 8080] phost pport + set command [list connection new $phost $pport $transform] + # The resource is just the local path + set resource [dict get $rec resource] + } else { + # The connection is to the proxy, so the scheme, host and + # port must point to that for reuse + lassign [hostport $arg 8080] host port + set scheme $version + set transform [dict get $schemes $scheme command] + set command [list connection new $host $port $transform] + # The resource is the full remote path + set resource $url + } + } + SOCKS - SOCKS4 - SOCKS5 { + package require www::socks + if {$keyword eq "SOCKS5"} { + set version socks5 + } else { + set version socks4 + } + lassign [hostport [dict get $rec host] [dict get $rec port]] \ + host port + lassign [hostport $arg 1080] phost pport + set transform [dict get $schemes $scheme command] + set transform [list socksinit $version $host $port $transform] + set command [list connection new $phost $pport $transform] + set scheme $version+$scheme + set resource [dict get $rec resource] + } + default { + # DIRECT + lassign [hostport [dict get $rec host] [dict get $rec port]] \ + host port + set transform [dict get $schemes $scheme command] + set command [list connection new $host $port $transform] + set resource [dict get $rec resource] + } + } + + set conn [reuse $scheme $host $port $command] + + dict set rec method $method + dict set rec pipeline [dict get $config -pipeline] + if {[dict exists $request body]} { + header replace hdrs \ + Content-Length [string length [dict get $request body]] + dict set rec body [dict get $request body] + } + foreach key {timeout upgrade handler result} { + if {[dict exists $request $key]} { + dict set rec $key [dict get $request $key] + } + } + dict set rec headers [headers $hdrs] + dict set rec callback [list [info coroutine]] + try { + $conn request [dict replace $rec resource $resource] + } on ok {data opts} { + } trap {WWW CONNECT} {data opts} { + log "proxy $n failed: $data" + continue + } on error {data opts} { + log "requestcoro error: $data" + } + # log "requestcoro: $opts" + if {[dict exists $opts headers]} { + set cookies [header get [dict get $opts headers] set-cookie all] + if {[llength $cookies]} { + cookies store $url {*}$cookies + } + } + {*}$callback [list $data $opts] + return + } + log "All proxies exhausted: $proxies" + # Retry with http -> https ? + {*}$callback [list $data $opts] +} + +proc www::parseopts {optspec arglist} { + set request {headers {} maxredir 20} + # Call getopts twice to allow options to be specified before and after the url + set args [getopt arg [lassign [getopt arg $arglist $optspec] url] $optspec] + return [linsert $args 0 $url $request] +} + +proc www::get {args} { + set args [lassign [parseopts [stdopts] $args] url request] + if {[llength $args] % 2} { + throw {WWW ARGS} "expected key/value pairs" + } + request GET $url $request {*}$args +} + +proc www::head {args} { + set args [lassign [parseopts [stdopts] $args] url request] + if {[llength $args] % 2} { + throw {WWW ARGS} "expected key/value pairs" + } + request HEAD $url $request {*}$args +} + +proc www::post {args} { + request POST {*}[parseopts [stdopts [postopts]] $args] +} + +proc www::put {args} { + request PUT {*}[parseopts [stdopts [postopts]] $args] +} + +proc www::delete {args} { + request DELETE {*}[parseopts [stdopts [postopts]] $args] +} + +proc www::proxyinit {scheme host port cmd fd args} { + variable schemes + # Apply a transformation for the connection to the proxy, if necessary + set transform [dict get $schemes $scheme command] + if {[llength $transform]} {{*}$transform $fd {*}$args} + if {[llength $cmd]} { + # Create a proxyconnect object for the CONNECT transaction to the proxy + set obj [proxyconnect new $fd] + # Actually start the connection + try { + $obj connect $host:$port + } finally { + $obj destroy + } + # Apply the transformation on the tunneled connection to the server + {*}$cmd $fd $host + } +} + +proc www::socksinit {version host port cmd fd args} { + socks $version $fd $host $port + if {[llength $cmd]} { + {*}$cmd $fd {*}$args + } +} diff --git a/src/vfs/_vfscommon.vfs/modules/www/digest-2.1.tm b/src/vfs/_vfscommon.vfs/modules/www/digest-2.1.tm new file mode 100644 index 00000000..966f63a5 --- /dev/null +++ b/src/vfs/_vfscommon.vfs/modules/www/digest-2.1.tm @@ -0,0 +1,83 @@ +namespace eval www::digest { + variable noncecount +} + +# HTTP/1.1 401 Unauthorized +# WWW-Authenticate: Digest +# realm="testrealm@host.com", +# qop="auth,auth-int", +# nonce="dcd98b7102dd2f0e8b11d0f600bfb0c093", +# opaque="5ccc069c403ebaf9f0171e9517f40e41" + +proc www::digest::md5 {str} { + package require md5 + return [string tolower [::md5::md5 -hex $str]] +} + +proc www::digest::sha256 {str} { + package require sha256 + return [::sha2::sha256 -hex $str] +} + +proc www::digest::digest {challenge username password method uri {body ""}} { + variable noncecount + if {[dict exists $challenge algorithm]} { + set algorithm [dict get $challenge algorithm] + } else { + set algorithm MD5 + } + switch $algorithm { + MD5 - MD5-sess {set hash md5} + SHA-256 - SHA-256-sess {set hash sha256} + default { + error "unsupported algorithm: $algorithm" + } + } + set interlude [dict get $challenge nonce] + set keys {username realm nonce uri response} + if {[dict exists $challenge qop]} { + set qops [split [dict get $challenge qop] ,] + if {"auth" in $qops} { + set qop auth + } elseif {"auth-int" in $qops} { + set qop auth-int + } else { + error "unsupported qop: [join $qops {, }]" + } + set nonce [dict get $challenge nonce] + # Generate a random cnonce + set cnonce [format %08x [expr {int(rand() * 0x100000000)}]] + set nc [format %08X [incr noncecount($nonce)]] + append interlude : $nc : $cnonce : $qop + lappend keys qop nc cnonce + if {[dict exists $challenge algorithm]} {lappend keys algorithm} + if {[dict exists $challenge opaque]} {lappend keys opaque} + } else { + set qop auth + } + foreach n $keys { + dict set rc $n \ + [if {[dict exists $challenge $n]} {dict get $challenge $n}] + } + dict set rc username $username + dict set rc uri $uri + if {[dict exists $rc qop]} { + dict set rc qop $qop + dict set rc cnonce $cnonce + dict set rc nc $nc + } + set A1 [$hash $username:[dict get $challenge realm]:$password] + if {[string match {*-sess} $algorithm]} {append A1 : $nonce : $cnonce} + set A2 [$hash $method:$uri] + if {$qop eq "auth-int"} {append A2 : $body} + dict set rc response [$hash $A1:$interlude:$A2] + set authlist {} + dict for {key val} $rc { + if {$key ni {qop nc}} { + lappend authlist [format {%s="%s"} $key $val] + } else { + lappend authlist $key=$val + } + } + return "Digest [join $authlist ,]" +} diff --git a/src/vfs/_vfscommon.vfs/modules/www/http2-1.1.tm b/src/vfs/_vfscommon.vfs/modules/www/http2-1.1.tm new file mode 100644 index 00000000..aa2bda62 --- /dev/null +++ b/src/vfs/_vfscommon.vfs/modules/www/http2-1.1.tm @@ -0,0 +1,1551 @@ +# Helper library for adding http/2 support to www + +# https://httpbin.org/ + +package require www 2.7 + +# trace add execution fileevent enter entertrace +proc entertrace {cmd op} {puts $cmd} + +if {[package vsatisfies [package require tls] 1.8-]} { + # Override the encrypt proc from the www package to add the -alpn option + proc www::encrypt {sock host} { + variable tlscfg + tls::import $sock -servername $host -alpn {h2 http/1.1} {*}$tlscfg + } +} + +oo::class create www::http2helper { + method Contact {} { + my variable fd + if {![next]} {return 0} + # Wait for the TLS handshake to complete + fileevent $fd writable [list [info coroutine] handshake] + yield + fileevent $fd writable {} + # Check the ALPN negotiation result + if {[catch {dict get [tls::status $fd] alpn} alpn]} {set alpn ""} + if {$alpn eq "h2"} { + oo::objdefine [self] mixin http2 + my Startup {} + } + return 1 + } + + method PushRequest {} { + my variable waiting pending + set waiting [lassign $waiting request] + + if {[dict get $request scheme] eq "http"} { + dict lappend request upgrade h2c http2 + # Add the headers needed for an HTTP/2 upgrade + dict update request headers hdrs { + foreach {name value} [www::http2 headers] { + header append hdrs $name $value + } + } + } + + lappend pending [dict create Request $request Attempt 0] + return $request + } +} + +oo::define www::connection { + mixin -append www::http2helper +} + +namespace eval www::http2 { + variable defaultsettings { + tablesize 4096 + pushenable 1 + maxstreams 2147483647 + windowsize 65536 + maxframesize 16384 + maxtablesize 2147483647 + } + variable preferredsettings { + tablesize 65536 + pushenable 0 + maxstreams 100 + windowsize 1048576 + maxtablesize 262144 + } + variable errorcodes { + NO_ERROR + PROTOCOL_ERROR + INTERNAL_ERROR + FLOW_CONTROL_ERROR + SETTINGS_TIMEOUT + STREAM_CLOSED + FRAME_SIZE_ERROR + REFUSED_STREAM + CANCEL + COMPRESSION_ERROR + CONNECT_ERROR + ENHANCE_YOUR_CALM + INADEQUATE_SECURITY + HTTP_1_1_REQUIRED + } + variable fixed { + {""} + {:authority} + {:method GET} + {:method POST} + {:path /} + {:path /index.html} + {:scheme http} + {:scheme https} + {:status 200} + {:status 204} + {:status 206} + {:status 304} + {:status 400} + {:status 404} + {:status 500} + {accept-charset} + {accept-encoding "gzip, deflate"} + {accept-language} + {accept-ranges} + {accept} + {access-control-allow-origin} + {age} + {allow} + {authorization} + {cache-control} + {content-disposition} + {content-encoding} + {content-language} + {content-length} + {content-location} + {content-range} + {content-type} + {cookie} + {date} + {etag} + {expect} + {expires} + {from} + {host} + {if-match} + {if-modified-since} + {if-none-match} + {if-range} + {if-unmodified-since} + {last-modified} + {link} + {location} + {max-forwards} + {proxy-authenticate} + {proxy-authorization} + {range} + {referer} + {refresh} + {retry-after} + {server} + {set-cookie} + {strict-transport-security} + {transfer-encoding} + {user-agent} + {vary} + {via} + {www-authenticate} + } +} + +namespace eval www::http2::huffman { + namespace ensemble create -subcommands {decode encode} + variable map { + 1111111111000 \x00 + 11111111111111111011000 \x01 + 1111111111111111111111100010 \x02 + 1111111111111111111111100011 \x03 + 1111111111111111111111100100 \x04 + 1111111111111111111111100101 \x05 + 1111111111111111111111100110 \x06 + 1111111111111111111111100111 \x07 + 1111111111111111111111101000 \x08 + 111111111111111111101010 \x09 + 111111111111111111111111111100 \x0A + 1111111111111111111111101001 \x0B + 1111111111111111111111101010 \x0C + 111111111111111111111111111101 \x0D + 1111111111111111111111101011 \x0E + 1111111111111111111111101100 \x0F + 1111111111111111111111101101 \x10 + 1111111111111111111111101110 \x11 + 1111111111111111111111101111 \x12 + 1111111111111111111111110000 \x13 + 1111111111111111111111110001 \x14 + 1111111111111111111111110010 \x15 + 111111111111111111111111111110 \x16 + 1111111111111111111111110011 \x17 + 1111111111111111111111110100 \x18 + 1111111111111111111111110101 \x19 + 1111111111111111111111110110 \x1A + 1111111111111111111111110111 \x1B + 1111111111111111111111111000 \x1C + 1111111111111111111111111001 \x1D + 1111111111111111111111111010 \x1E + 1111111111111111111111111011 \x1F + 010100 \x20 + 1111111000 \x21 + 1111111001 \x22 + 111111111010 \X23 + 1111111111001 \x24 + 010101 \x25 + 11111000 \x26 + 11111111010 \x27 + 1111111010 \x28 + 1111111011 \x29 + 11111001 \x2A + 11111111011 \x2B + 11111010 \x2C + 010110 \x2D + 010111 \x2E + 011000 \x2F + 00000 \x30 + 00001 \x31 + 00010 \x32 + 011001 \x33 + 011010 \x34 + 011011 \x35 + 011100 \x36 + 011101 \x37 + 011110 \x38 + 011111 \x39 + 1011100 \x3A + 11111011 \x3B + 111111111111100 \x3C + 100000 \x3D + 111111111011 \x3E + 1111111100 \x3F + 1111111111010 \x40 + 100001 \x41 + 1011101 \x42 + 1011110 \x43 + 1011111 \x44 + 1100000 \x45 + 1100001 \x46 + 1100010 \x47 + 1100011 \x48 + 1100100 \x49 + 1100101 \x4A + 1100110 \x4B + 1100111 \x4C + 1101000 \x4D + 1101001 \x4E + 1101010 \x4F + 1101011 \x50 + 1101100 \x51 + 1101101 \x52 + 1101110 \x53 + 1101111 \x54 + 1110000 \x55 + 1110001 \x56 + 1110010 \x57 + 11111100 \x58 + 1110011 \x59 + 11111101 \x5A + 1111111111011 \x5B + 1111111111111110000 \x5C + 1111111111100 \x5D + 11111111111100 \x5E + 100010 \x5F + 111111111111101 \x60 + 00011 \x61 + 100011 \x62 + 00100 \x63 + 100100 \x64 + 00101 \x65 + 100101 \x66 + 100110 \x67 + 100111 \x68 + 00110 \x69 + 1110100 \x6A + 1110101 \x6B + 101000 \x6C + 101001 \x6D + 101010 \x6E + 00111 \x6F + 101011 \x70 + 1110110 \x71 + 101100 \x72 + 01000 \x73 + 01001 \x74 + 101101 \x75 + 1110111 \x76 + 1111000 \x77 + 1111001 \x78 + 1111010 \x79 + 1111011 \x7A + 111111111111110 \x7B + 11111111100 \x7C + 11111111111101 \x7D + 1111111111101 \x7E + 1111111111111111111111111100 \x7F + 11111111111111100110 \x80 + 1111111111111111010010 \x81 + 11111111111111100111 \x82 + 11111111111111101000 \x83 + 1111111111111111010011 \x84 + 1111111111111111010100 \x85 + 1111111111111111010101 \x86 + 11111111111111111011001 \x87 + 1111111111111111010110 \x88 + 11111111111111111011010 \x89 + 11111111111111111011011 \x8A + 11111111111111111011100 \x8B + 11111111111111111011101 \x8C + 11111111111111111011110 \x8D + 111111111111111111101011 \x8E + 11111111111111111011111 \x8F + 111111111111111111101100 \x90 + 111111111111111111101101 \x91 + 1111111111111111010111 \x92 + 11111111111111111100000 \x93 + 111111111111111111101110 \x94 + 11111111111111111100001 \x95 + 11111111111111111100010 \x96 + 11111111111111111100011 \x97 + 11111111111111111100100 \x98 + 111111111111111011100 \x99 + 1111111111111111011000 \x9A + 11111111111111111100101 \x9B + 1111111111111111011001 \x9C + 11111111111111111100110 \x9D + 11111111111111111100111 \x9E + 111111111111111111101111 \x9F + 1111111111111111011010 \xA0 + 111111111111111011101 \xA1 + 11111111111111101001 \xA2 + 1111111111111111011011 \xA3 + 1111111111111111011100 \xA4 + 11111111111111111101000 \xA5 + 11111111111111111101001 \xA6 + 111111111111111011110 \xA7 + 11111111111111111101010 \xA8 + 1111111111111111011101 \xA9 + 1111111111111111011110 \xAA + 111111111111111111110000 \xAB + 111111111111111011111 \xAC + 1111111111111111011111 \xAD + 11111111111111111101011 \xAE + 11111111111111111101100 \xAF + 111111111111111100000 \xB0 + 111111111111111100001 \xB1 + 1111111111111111100000 \xB2 + 111111111111111100010 \xB3 + 11111111111111111101101 \xB4 + 1111111111111111100001 \xB5 + 11111111111111111101110 \xB6 + 11111111111111111101111 \xB7 + 11111111111111101010 \xB8 + 1111111111111111100010 \xB9 + 1111111111111111100011 \xBA + 1111111111111111100100 \xBB + 11111111111111111110000 \xBC + 1111111111111111100101 \xBD + 1111111111111111100110 \xBE + 11111111111111111110001 \xBF + 11111111111111111111100000 \xC0 + 11111111111111111111100001 \xC1 + 11111111111111101011 \xC2 + 1111111111111110001 \xC3 + 1111111111111111100111 \xC4 + 11111111111111111110010 \xC5 + 1111111111111111101000 \xC6 + 1111111111111111111101100 \xC7 + 11111111111111111111100010 \xC8 + 11111111111111111111100011 \xC9 + 11111111111111111111100100 \xCA + 111111111111111111111011110 \xCB + 111111111111111111111011111 \xCC + 11111111111111111111100101 \xCD + 111111111111111111110001 \xCE + 1111111111111111111101101 \xCF + 1111111111111110010 \xD0 + 111111111111111100011 \xD1 + 11111111111111111111100110 \xD2 + 111111111111111111111100000 \xD3 + 111111111111111111111100001 \xD4 + 11111111111111111111100111 \xD5 + 111111111111111111111100010 \xD6 + 111111111111111111110010 \xD7 + 111111111111111100100 \xD8 + 111111111111111100101 \xD9 + 11111111111111111111101000 \xDA + 11111111111111111111101001 \xDB + 1111111111111111111111111101 \xDC + 111111111111111111111100011 \xDD + 111111111111111111111100100 \xDE + 111111111111111111111100101 \xDF + 11111111111111101100 \xE0 + 111111111111111111110011 \xE1 + 11111111111111101101 \xE2 + 111111111111111100110 \xE3 + 1111111111111111101001 \xE4 + 111111111111111100111 \xE5 + 111111111111111101000 \xE6 + 11111111111111111110011 \xE7 + 1111111111111111101010 \xE8 + 1111111111111111101011 \xE9 + 1111111111111111111101110 \xEA + 1111111111111111111101111 \xEB + 111111111111111111110100 \xEC + 111111111111111111110101 \xED + 11111111111111111111101010 \xEE + 11111111111111111110100 \xEF + 11111111111111111111101011 \xF0 + 111111111111111111111100110 \xF1 + 11111111111111111111101100 \xF2 + 11111111111111111111101101 \xF3 + 111111111111111111111100111 \xF4 + 111111111111111111111101000 \xF5 + 111111111111111111111101001 \xF6 + 111111111111111111111101010 \xF7 + 111111111111111111111101011 \xF8 + 1111111111111111111111111110 \xF9 + 111111111111111111111101100 \xFA + 111111111111111111111101101 \xFB + 111111111111111111111101110 \xFC + 111111111111111111111101111 \xFD + 111111111111111111111110000 \xFE + 11111111111111111111101110 \xFF + } + variable rmap [lreverse $map] + lappend map 111111111111111111111111111111 \x00 +} + +proc www::http2::huffman::decode {data} { + variable map + binary scan $data B* bits + append bits 111111111111111111111111111111 + set str [regsub \0001*$ [string map $map $bits] {}] + return [encoding convertfrom utf-8 $str] +} + +proc www::http2::huffman::encode {str {utf8 0}} { + variable rmap + if {!$utf8} {set str [encoding convertto utf-8 $str]} + set bits [string map $rmap $str] + append bits [string repeat 1 [expr {-[string length $bits] % 8}]] + return [binary format B* $bits] +} + +proc www::http2::errormessage {code} { + variable errorcodes + set str [lindex $errorcodes $code] + if {$str eq ""} {set str "UNKNOWN_ERROR_CODE_$code"} + return $str +} + +proc www::http2::errorcode {value} { + variable errorcodes + set code [lsearch -exact $errorcodes $value] + if {$code < 0 && $value ne "INTERNAL_ERROR"} { + tailcall errorcode INTERNAL_ERROR + } + return $code +} + +proc www::http2::integer {var cnt} { + upvar 1 $var data + set mask [expr {(1 << $cnt) - 1}] + binary scan $data cu integer + set integer [expr {$integer & $mask}] + set i 1 + if {$integer == $mask} { + while 1 { + binary scan [string index $data $i] cu next + set integer [expr {$integer + (($next & 0x7f) << 7 * ($i - 1))}] + incr i + if {($next & 0x80) == 0} break + } + } + set data [string range $data $i end] + return $integer +} + +proc www::http2::makeint {num cnt {flags 0}} { + set mask [expr {(1 << $cnt) - 1}] + if {$num < $mask} { + lappend rc [expr {$num | $flags << $cnt}] + } else { + lappend rc [expr {$mask | $flags << $cnt}] + set num [expr {$num - $mask}] + while {$num >= 128} { + lappend rc [expr {$num & 0x7f | 0x80}] + set num [expr {$num >> 7}] + } + lappend rc $num + } + return [binary format c* $rc] +} + +proc www::http2::makestr {str} { + set data [encoding convertto utf-8 $str] + set huff [huffman encode $data 1] + if {[string length $huff] < [string length $data]} { + return [makeint [string length $huff] 7 1]$huff + } else { + return [makeint [string length $data] 7 0]$data + } +} + +proc www::http2::strlen {str} { + set len [string length [encoding convertto utf-8 $str]] + return [expr {$len + [string length [makeint $len 7]]}] +} + +oo::class create www::http2 { + method Startup {headers} { + log "HTTP/2 connection: [self]" + namespace path [linsert [namespace path] 0 ::www::http2] + namespace upvar ::www::http2 \ + defaultsettings default preferredsettings prefs + my variable fd space limit + variable data "" stream {} laststream -1 lastreceived 0 + variable backlog {} continuation 0 concurrent 0 + # Connection windows start at 64k + set space(0) 65536 ;# Receiving window + set limit(0) 65536 ;# Sending window + # Initialize the header compression tables + variable context + dict set context compress \ + [dict create table $::www::http2::fixed size 0 maxsize 4096] + dict set context decompress \ + [dict create table $::www::http2::fixed size 0 maxsize 4096] + # Set initial local and remote settings + variable settings $default remote $default + fconfigure $fd -translation binary -buffering none -blocking 0 + # Send magic + log "[self] Startup: PRI * HTTP/2.0\\r\\n\\r\\nSM\\r\\n\\r\\n" + puts -nonewline $fd "PRI * HTTP/2.0\r\n\r\nSM\r\n\r\n" + my ChangeSettings $prefs + if {[header exists $headers upgrade]} { + # Upgrade from HTTP/1.1 to HTTP/2 + set request [my PopRequest] + # The HTTP/1.1 request that is sent prior to upgrade is assigned + # a stream identifier of 1 with default priority values. Stream 1 + # is implicitly "half-closed" from the client toward the server, + # since the request is completed as an HTTP/1.1 request. + # (RFC7540 3.2) + set laststream 1 + set coro [my StartStream 1 half_closed_local] + $coro request [dict get $request Request] upgrade + } + # Process any HTTP/2 frames the server may have sent along with the 101 + if {[my Trap my Frame]} { + # Set the connection window size to 16MB + my ResizeWindow 0 16777216 + fileevent $fd readable [callback Trap my Frame] + # Pick up any requests that have already been queued + my Process + } + } + + method ConnectionError {type msg} { + my variable lastreceived + log "ConnectionError $type $msg" + # Send GoAway message + my SendFrame 0 7 0b0 \ + [binary format IIa* $lastreceived [errorcode $type] $msg] + # After sending the GOAWAY frame for an error condition, the endpoint + # MUST close the TCP connection. (RFC7540 5.4.1) + if {$type ne "NO_ERROR"} {my destroy} + } + + method StreamError {sid type msg} { + log "StreamError ($sid): $type $msg" + # Send RST_STREAM message + my SendFrame $sid 3 0b0 [binary format I [errorcode $type]] + } + + method PackString {var} { + upvar 1 $var data + binary scan $data B encoded + set len [integer data 7] + set str [string range $data 0 [expr {$len - 1}]] + if {$encoded} {set str [huffman decode $str]} + set data [string range $data $len end] + return $str + } + + method Index {op name value} { + my variable context + set index [llength $::www::http2::fixed] + dict with context $op { + set table [linsert $table $index [list $name $value]] + incr size [expr {[strlen $name] + [strlen $value] + 32}] + } + return [my Evict $op] + } + + method Evict {op} { + my variable context + dict with context $op { + while {$size > $maxsize} { + lassign [lindex $table end] name value + set table [lrange $table 0 end-1] + incr size [expr {-([strlen $name] + [strlen $value] + 32)}] + } + } + return $table + } + + method ChangeSettings {request} { + my variable settings waitack + my SendFrame 0 4 0b0 [http2 settings $request $settings] + set waitack $request + } + + method ResizeWindow {stream size} { + my variable space + set incr [expr {$size - $space($stream)}] + if {$incr > 0} { + my SendFrame $stream 8 0b0 [binary format I $incr] + set space($stream) $size + } + } + + method Trap {args} { + try $args trap {WWW HTTP2 CONNECTIONERROR} {msg info} { + my ConnectionError [lindex [dict get $info -errorcode] 3] $msg + return 0 + } on error {msg info} { + log "Trap: $msg\ + ([dict get $info -errorcode])\n[dict get $info -errorinfo]" + my ConnectionError INTERNAL_ERROR $msg + return 0 + } + return 1 + } + + method Frame {} { + my variable fd stream data continuation + if {[eof $fd]} { + my destroy + return + } + append data [read $fd] + while {[string length $data] >= 9} { + binary scan $data IuXcub8Iu len type flags sid + set len [expr {$len >> 8}] + if {[string length $data] < 9 + $len} return + set payload [string range $data 9 [expr {9 + $len - 1}]] + if {$type} { + binary scan $payload H* hex + log [format {< (%s %d) %d %s %s} \ + [self] $sid $type [string reverse $flags] $hex] + } elseif {[binary scan $payload H40 hex]} { + log [format {< (%s %d) %d %s %s... <%d bytes>} [self] $sid \ + $type [string reverse $flags] $hex [string length $payload]] + } else { + binary scan $payload H* hex + log [format {< (%s %d) %d %s %s} \ + [self] $sid $type [string reverse $flags] $hex] + } + set data [string range $data [expr {9 + $len}] end] + + if {$continuation} { + # A receiver MUST treat the receipt of any other type of frame + # or a frame on a different stream as a connection error of + # type PROTOCOL_ERROR. (RFC7540 6.2) + if {$type != 9 || $sid != $continuation} { + throw {WWW HTTP2 CONNECTIONERROR PROTOCOL_ERROR} \ + "unexpected non-CONTINUATION frame or stream_id is invalid" + } + } + if {$sid} { + if {[dict exists $stream $sid coro]} { + [dict get $stream $sid coro] message $type $flags $payload + } else { + log "Message for closed stream $sid" + } + } else { + # Stream 0: connection + switch $type { + 4 { + # Settings + my Settings $flags $payload + } + 6 { + # Ping + my Ping $flags $payload + } + 7 { + # GoAway + my GoAway $flags $payload + } + 8 { + # WindowUpdate + my WindowUpdate 0 $payload + } + } + } + } + } + + method ClientStream {} { + my variable laststream + # Clients only use odd numbered streams + return [my StartStream [incr laststream 2]] + } + + method StartStream {sid {state idle}} { + my variable stream + set coro stream$sid + dict set stream $sid coro $coro + dict set stream $sid weight 16 + dict set stream $sid parent 0 + dict set stream $sid deps {} + dict set stream $sid state idle + coroutine $coro my Stream $sid $state + return $coro + } + + method Stream {sid state} { + my variable stream settings remote space limit backlog + set space($sid) [dict get $settings windowsize] + set limit($sid) [dict get $remote windowsize] + set result {} + set id {} + set promise 0 + set cmd list + my StateTransition $state + try { + while {[dict get $stream $sid state] ne "closed"} { + set args [lassign [yieldto {*}$cmd] event] + set cmd list + switch $event { + message { + my Message {*}$args + if {$promise} {set flags [lindex $args 1]} + } + promise { + my StateTransition reserved_remote + my Continuation {*}$args + set promise 1 + set flags [lindex $args 0] + } + request { + set tags [lassign $args request] + dict set result Request $request + if {"upgrade" ni $tags} {my Transmit $sid $request} + } + failed { + throw {*}$args + } + close { + break + } + } + if {$promise && [string index $flags 2]} { + # Push promise headers complete + # The headers received until now belong to the request + dict set result Request headers [dict get result headers] + dict unset result headers + # Check for some mandatory parts + foreach key {method scheme host resource} { + if {![dict exists result $key]} { + throw {WWW HTTP2 STREAMERROR PROTOCOL_ERROR} \ + "missing mandatory request header: $key" + } + } + + } + } + my Return $result + } trap {WWW DATA TIMEOUT} {msg info} { + my StreamError $sid CANCEL $msg + my Failed [dict get $info -errorcode] $msg $sid + } trap {WWW HTTP2 STREAMERROR} {msg info} { + set type [lindex [dict get $info -errorcode] 3] + my StreamError $sid $type $msg + my Failed [dict get $info -errorcode] $msg $sid + } on error {msg info} { + my StreamError $sid INTERNAL_ERROR $msg + my Failed [dict get $info -errorcode] $msg $sid + } finally { + # Cleanup + unset space($sid) limit($sid) + dict unset backlog $sid + dict unset stream $sid coro + my StateTransition closed + # Keep streams that have dependencies for load sharing purposes + for { + set num $sid + } { + [dict get $stream $sid state] eq "closed" \ + && [llength [dict get $stream $num deps]] == 0 + } { + set num $parent + } { + set parent [dict get $stream $num parent] + dict unset stream $num + if {$parent == 0} break + dict update stream $parent ref { + dict set ref deps \ + [lsearch -all -inline -exact -not [dict get $ref deps] $num] + } + } + } + } + + method StreamId {} { + upvar #1 sid sid + return $sid + } + + method Result {args} { + upvar #1 result result + if {[llength $args] > 1} { + dict set result {*}$args + } elseif {[llength $args] == 0} { + return $result + } elseif {[dict exists $result {*}$args]} { + return [dict get $result {*}$args] + } + return + } + + method Timeout {} { + my variable timeout + upvar #1 request request + if {[dict exists $request timeout]} { + return [dict get $request timeout] + } else { + return $timeout + } + } + + method Timedout {sid} { + my variable stream + if {[dict exists $stream $sid coro]} { + set coro [dict get $stream $sid coro] + $coro failed {WWW DATA TIMEOUT} "timeout waiting for a response" + } + } + + method Failed {code msg {sid 0}} { + if {$sid} { + set callback [dict get [my Result Request] callback] + set opts [dict create -code 1 -level 1 -errorcode $code] + $callback -options $opts $msg + } else { + my variable stream + set type INTERNAL_ERROR + foreach n1 $code n2 {WWW HTTP2 CONNECTIONERROR} { + if {$n1 eq $n2} continue + if {$n2 eq ""} {set type $n1} + break + } + my ConnectionError $type $msg + dict for {sid dict} $stream { + if {[dict exists $dict coro]} { + [dict get $dict coro] failed $code $msg + } + } + } + } + + method Message {type flags payload} { + switch $type { + 0 { + # Data + my Data $flags $payload + } + 1 { + # Headers + my Headers $flags $payload + } + 2 { + # Priority + my Priority $flags $payload + } + 3 { + # ResetStream + my ResetStream $flags $payload + } + 5 { + # PushPromise + my PushPromise $flags $payload + } + 8 { + # WindowUpdate + my WindowUpdate [my StreamId] $payload + } + 9 { + # Continuation + my Continuation $flags $payload + } + 4 - 6 - 7 { + # Settings + # Ping + # GoAway + throw {WWW HTTP2 CONNECTIONERROR PROTOCOL_ERROR} \ + "message may not be associated with an individual stream" + } + } + } + + method Data {flags data} { + set sid [my StreamId] + my ValidStates STREAM_CLOSED open half_closed_local + my variable space settings + if {[string index $flags 3]} { + binary scan $data cu padding + set data [string range $data 1 [expr {$len - $padding - 1}]] + } + my Progress $data + set diff [expr {-[string length $data]}] + if {[incr space($sid) $diff] < [dict get $settings windowsize] / 2} { + my ResizeWindow $sid [dict get $settings windowsize] + } + if {[incr space(0) $diff] < 1048576} { + my ResizeWindow 0 16777216 + } + if {[string index $flags 0]} { + # Check content-length header, if present? + # The body may have a different length due to encoding + # throw {WWW HTTP2 STREAMERROR PROTOCOL_ERROR} \ + # "content-length mismatch" + my EndStream + } + } + + method Headers {flags data} { + my ValidStates PROTOCOL_ERROR \ + idle reserved_remote open half_closed_local + my StateTransition idle open reserved_remote half_closed_local + if {[string index $flags 3]} { + # Padded + set len [string length $data] + if {[string index $flags 5]} { + # Priority + binary scan $data cuBXIucu padding excl dep weight + set data [string range $data 6 [expr {$len - $padding - 1}]] + my Prioritize [my StreamId] \ + [expr {$dep & 0x7fffffff}] $excl $weight + } else { + binary scan $data cu padding + set data [string range $data 1 [expr {$len - $padding - 1}]] + } + } elseif {[string index $flags 5]} { + # Priority + binary scan $data Iucu dep weight + set data [string range $data 5 end] + } + if {[string index $flags 0]} {my EndStream} + my Continuation $flags $data + } + + method Priority {flags data} { + binary scan $data BXIucu excl dep weight + my Prioritize [my StreamId] [expr {$dep & 0x7fffffff}] $excl $weight + } + + method ResetStream {flags data} { + my StateTransition closed + binary scan $data Iu code + log "Reset stream: Code = $code" + } + + method Settings {flags data} { + my variable settings remote waitack space limit + if {[string index $flags 0]} { + if {![info exists waitack]} { + # ERROR: There is no settings update pending + return + } + # Our settings update has been accepted + if {[dict exists $waitack windowsize]} { + # Adjust the window sizes for all existing streams + set diff [expr {[dict get $waitack windowsize] \ + - [dict get $settings windowsize]}] + foreach n [array names space] { + if {$n} {incr space($n) $diff} + } + } + set settings [dict merge $settings $waitack] + unset waitack + return + } + while {[binary scan $data SuIu id value] == 2} { + switch $id { + 1 { + # SETTINGS_HEADER_TABLE_SIZE + dict set remote tablesize $value + } + 2 { + # SETTINGS_ENABLE_PUSH + if {$value <= 1} { + dict set remote pushenable $value + } else { + throw {WWW HTTP2 CONNECTIONERROR PROTOCOL_ERROR} \ + "invalid value for SETTINGS_ENABLE_PUSH: $value" + } + } + 3 { + # SETTINGS_MAX_CONCURRENT_STREAMS + dict set remote maxstreams $value + } + 4 { + # SETTINGS_INITIAL_WINDOW_SIZE + set diff [expr {$value - [dict get $remote windowsize]}] + # Adjust all existing streams + foreach n [array names limit] { + if {$n} {incr limit($n) $diff} + } + dict set remote windowsize $value + } + 5 { + # SETTINGS_MAX_FRAME_SIZE + dict set remote maxframesize $value + } + 6 { + # SETTINGS_MAX_HEADER_LIST_SIZE + dict set remote maxtablesize $value + } + } + set data [string range $data 6 end] + } + if {$data ne ""} { + throw {WWW HTTP2 CONNECTIONERROR FRAME_SIZE_ERROR} \ + "frame length must be a multiple of 6 octets" + } + # Acknowledge the received settings + my SendFrame 0 4 0b1 + } + + method PushPromise {flags data} { + my variable lastreceived + my ValidStates PROTOCOL_ERROR open half_closed_local + if {[string index $flags 3]} { + set len [string length $data] + binary scan $data cuIu padding new + set data [string range $data 5 [expr {$len - $padding - 1}]] + } else { + binary scan $data Iu new + set data [string range $data 4 end] + } + # Streams initiated by the server MUST use even-numbered stream + # identifiers. The identifier of a newly established stream MUST be + # numerically greater than all streams that the initiating endpoint + # has opened or reserved. An endpoint that receives an unexpected + # stream identifier MUST respond with a connection error of type + # PROTOCOL_ERROR. (RFC7540 5.1.1) + if {$new % 2 || $new <= $lastreceived} { + throw {WWW HTTP2 CONNECTIONERROR PROTOCOL_ERROR} \ + "unexpected stream identifier: $new" + } + set lastreceived $new + set coro [my StartStream $new] + coro promise $flags $data + } + + method Ping {flags data} { + if {[string index $flags 0]} { + # Received ping ACK + } else { + # Received ping, send ACK + my SendFrame 0 6 0b1 $data + } + } + + method GoAway {flags data} { + binary scan $data IuIua* last code msg + log "GoAway: Code = [errormessage $code], Last stream = $last, $msg" + my SendFrame 0 7 0b0 [binary format II $last 0] + } + + method WindowUpdate {sid data} { + my variable limit backlog + # A WINDOW_UPDATE frame with a length other than 4 octets MUST be + # treated as a connection error of type FRAME_SIZE_ERROR (RFC7540 6.9) + if {[string length $data] != 4} { + throw {WWW HTTP2 CONNECTIONERROR FRAME_SIZE_ERROR} \ + "WINDOW_UPDATE frame must have a length of 4" + } + binary scan $data Iu incr + # A receiver MUST treat the receipt of a WINDOW_UPDATE frame with + # an flow-control window increment of 0 as a stream error of type + # PROTOCOL_ERROR ((RFC7540 6.9) + if {$incr == 0} { + if {$sid} { + throw {WWW HTTP2 STREAMERROR PROTOCOL_ERROR} \ + "flow-control window increment may not be 0" + } else { + throw {WWW HTTP2 CONNECTIONERROR PROTOCOL_ERROR} \ + "flow-control window increment may not be 0" + } + } + incr limit($sid) $incr + if {$sid} { + if {![dict exists $backlog $sid]} return + if {min($limit(0), $limit($sid)) == 0} return + } else { + if {[dict size $backlog] == 0} return + } + # Resume sending data, if necessary + fileevent $fd writable [callback Flow] + } + + method Continuation {flags data} { + my variable context continuation stream + # header block fragment (RFC7540 4.3) + set table [dict get $context decompress table] + set headers [my Result headers] + while {[string length $data]} { + binary scan $data B4 rep + if {[string index $rep 0]} { + # Indexed Header Field Representation (RFC7541 6.1) + set type HH + set int [integer data 7] + lassign [lindex $table $int] name value + } elseif {[string index $rep 1]} { + # Literal Header Field with Incremental Indexing (RFC7541 6.2) + set int [integer data 6] + if {$int == 0} { + # New name + set type MM + set name [my PackString data] + } else { + set type HM + set name [lindex $table $int 0] + } + set value [my PackString data] + # Unshare the table to prevent copy on write + set table {} + set table [my Index decompress $name $value] + } elseif {[string index $rep 2]} { + # Dynamic Table Size Update (RFC7541 6.3) + set maxsize [integer data 5] + dict set context decompress maxsize $maxsize + log "New max table size: $maxsize" + # Evict entries that cause the table to exceed the maximum size + my Evict decompress + continue + } elseif {[string index $rep 3]} { + # Literal Header Field Never Indexed (RFC7541 6.2.3) + set int [integer data 4] + if {$int == 0} { + # New name + set type xx + set name [my PackString data] + } else { + set type Hx + set name [lindex $table $int 0] + } + set value [my PackString data] + } else { + # Literal Header Field without Indexing (RFC7541 6.2.2) + set int [integer data 4] + if {$int == 0} { + # New name + set type -- + set name [my PackString data] + } else { + set type H- + set name [lindex $table $int 0] + } + set value [my PackString data] + } + log "$type $name: $value" + if {$name eq ":status"} { + # Any request or response that contains a pseudo-header field + # that appears in a header block after a regular header field + # MUST be treated as malformed. (RFC7540 8.1.2.1) + if {[llength $headers]} { + throw {WWW HTTP2 STREAMERROR PROTOCOL_ERROR} \ + "pseudo-header after a regular header: $name" + } + # HTTP/2.0 doesn't provide a version or reason + set dict {line "" version HTTP/2.0 reason ""} + dict set dict code $value + my Result status $dict + } elseif {[string match :* $name]} { + switch $name { + :authority {my Result host $value} + :method {my Result method $value} + :path {my Result resource $value} + :scheme {my Result scheme $value} + default { + # Endpoints MUST treat a request or response that + # contains undefined or invalid pseudo-header fields + # as malformed (RFC7540 8.1.2.1) + throw {WWW HTTP2 STREAMERROR PROTOCOL_ERROR} \ + "undefined pseudo-header field: $name" + } + } + # These pseudo-header fields are only allowed in a PushPromise + if {$sid % 2} { + throw {WWW HTTP2 STREAMERROR PROTOCOL_ERROR} \ + "invalid pseudo-header field: $name" + } + # Any request or response that contains a pseudo-header field + # that appears in a header block after a regular header field + # MUST be treated as malformed. (RFC7540 8.1.2.1) + if {[llength $headers]} { + throw {WWW HTTP2 STREAMERROR PROTOCOL_ERROR} \ + "pseudo-header after a regular header: $name" + } + } else { + lappend headers $name $value + } + } + my Result headers $headers + # Check END_HEADERS flag + if {[string index $flags 2] == 0} { + set continuation [my StreamId] + return + } + set continuation 0 + set enc [header get $headers content-encoding all -lowercase] + my Result Encoding [lmap name [lreverse $enc] { + set coro encodingcoro_$name + coroutine $coro {*}[encodingcmd $name] + set coro + }] + } + + method ValidStates {code args} { + set state [my StateTransition] + if {$state ni $args} { + throw [list WWW HTTP2 STREAMERROR $code] \ + "illegal frame type for the current state: $state" + } + } + + method StateTransition {args} { + my variable stream concurrent + set sid [my StreamId] + set state [dict get $stream $sid state] + set from $state + if {[llength $args] == 1} { + set state [lindex $args 0] + } elseif {[dict exists $args $state]} { + set state [dict get $args $state] + } + if {$state ne $from} { + # Update the number of concurrently active streams + set open {open half_closed_local half_closed_remote} + incr concurrent [expr {($state in $open) - ($from in $open)}] + log "State ($sid): $from -> $state\nActive streams = $concurrent" + dict set stream $sid state $state + } + return $state + } + + method EndStream {} { + upvar #1 id id + # Cancel the response timeout + after cancel $id + my StateTransition open half_closed_remote half_closed_local closed + } + + method Prioritize {sid dep excl weight} { + my variable stream + if {$dep == $sid} { + throw {WWW HTTP2 STREAMERROR PROTOCOL_ERROR} \ + "a stream cannot depend on itself" + # my StreamError $sid PROTOCOL_ERROR + return + } + set s [dict get $stream $dep parent] + while {$s} { + if {$s == $sid} { + # Prevent imminent dependency loop: "The formerly dependent + # stream is first moved to be dependent on the reprioritized + # stream's previous parent. The moved dependency retains its + # weight." (RFC7540 5.3.3) + my Prioritize $dep [dict get $stream $sid parent] 0 \ + [dict get $stream $dep weight] + break + } + set s [dict get $stream $s parent] + } + set parent [dict get $stream $sid parent] + if {$parent && $dep != $parent} { + dict update stream $parent ref { + # Remove the stream from the depency list of the old parent + dict set ref deps \ + [lsearch -all -inline -exact -not [dict get $ref deps] $sid] + } + } + if {$dep} { + if {$excl} { + set deps [dict get $stream $dep deps] + # This stream is the sole dependent stream of its parent + dict set stream $dep deps [list $sid] + # Add the old dependencies to this stream + dict update stream $sid ref { + foreach n $deps { + if {$n ni [dict get $ref deps]} { + dict lappend ref deps $n + } + } + } + } else { + dict update stream $dep ref { + if {$sid ni [dict get $ref deps]} { + dict lappend ref deps $sid + } + } + } + } elseif {$excl} { + set deps {} + dict for {ref data} $stream { + if {$ref != sid && [dict get $data parent] == 0} { + lappend deps $ref + dict set stream $ref parent $sid + } + } + dict set stream $sid deps $deps + } + dict set stream $sid parent $dep + dict set stream $sid weight $weight + } + + method Transmit {sid request} { + my variable fd remote + upvar #1 id id + set method [string toupper [dict get $request method]] + my StateTransition idle open reserved_local half_closed_remote + set rc [my Header :method $method] + if {$method ni {CONNECT}} { + # Don't expect repeated request for the same path; don't index it + append rc [my Header :path [dict get $request resource] 0] + append rc [my Header :scheme [dict get $request scheme]] + } + append rc [my Header :authority [dict get $request host]] + set headers [dict get $request headers] + # Do not include connection-specific header fields + set skip \ + {connection keep-alive proxy-connection transfer-encoding upgrade} + foreach n [header get $headers connection all] { + if {$n ni $skip} {lappend skip $n} + } + set size [string length $rc] + set end [expr {![dict exists $request body]}] + if {$end} { + my StateTransition \ + open half_closed_local half_closed_remote closed + } + # Don't index headers that likely have a different value every time + set dynamic {date if-none-match} + set type 1 + foreach {name value} $headers { + set name [string tolower $name] + if {$name in $skip} continue + if {$name eq "cookie"} { + # Compressing the Cookie Header Field (RFC7540 8.1.2.5) + set str "" + foreach val [split $value {;}] { + append str [my Header $name [string trim $val]] + } + } else { + set str [my Header $name $value [expr {$name ni $dynamic}]] + } + # Keep frame size below limits + set add [string length $str] + if {$size + $add > [dict get $remote maxframesize]} { + # Send the partial headers + my SendFrame $sid $type $end $rc + # Additional parts will be in a CONTINUATION frames + set type 9 + set end 0 + set rc "" + set size 0 + } + append rc $str + incr size $add + } + my SendFrame $sid $type [expr {$end | 0b100}] $rc + set id [after [my Timeout] [callback Timedout $sid]] + if {[dict exists $request body]} { + my Push $sid [dict get $request body] + } + } + + method Push {sid data} { + my variable backlog fd + dict update backlog $sid dict { + dict append dict data $data + dict incr dict done 0 + } + fileevent $fd writable [callback Flow] + } + + method Flow {} { + my variable fd backlog limit + set sid [my Balance] + if {$sid == 0} { + # No data to send, or no bandwidth left + fileevent $fd writable {} + return + } + dict with backlog $sid { + # Calculate the amount of data left to be sent + set len [expr {[string length $data] - $done}] + # Determine how much data to actually send + # Limit to 8k for load balancing + set max [expr {min($len, $limit(0), $limit($sid), 8192)}] + set end [expr {$max == $len}] + # Send the data frame + my SendFrame $sid 0 $end \ + [string range $data $done [expr {$done + $max - 1}]] + # Keep track of what has already been sent + incr done $max + } + # Update the flow-control window administration + incr limit(0) [expr {-$max}] + incr limit($sid) [expr {-$max}] + # Clean up when all data for the current stream has been sent + if {$end} { + dict unset backlog $sid + my StateTransition open half_closed_local half_closed_remote closed + } + } + + method Balance {} { + # Select a stream based on dependencies and weighting + my variable backlog limit stream + if {$limit(0) == 0} { + # All streams are blocked + return 0 + } + # Create a list of streams with data waiting and available bandwidth + set list [lmap n [dict keys $backlog] { + if {$limit($n)} {set n} else continue + }] + # Build a tree of streams and their weight + set weight {} + foreach n $list { + while {$n != 0} { + set parent [dict get $stream $n parent] + dict set weight $parent $n [dict get $stream $n weight] + set n $parent + } + } + # Walk down the tree and pick a branch based on their weight + set sid 0 + # Stop when a stream is found that has data to send + while {[dict exists $weight $sid] && $sid ni $list} { + set w 0 + set weights {} + dict for {num value} [dict get $weight $sid] { + lappend weights [list $num $w] + incr w $value + } + set v [expr {int(rand() * $w)}] + set index [lsearch -integer -index 1 -bisect $weights $v] + set sid [lindex $weights $index 0] + } + return $sid + } + + method Header {name value {add 1}} { + my variable context + set entry 0 + set table [dict get $context compress table] + set list [lsearch -all -exact -index 0 $table $name] + foreach n $list { + if {[lindex $table $n 1] eq $value} { + set entry $n + } + } + if {$entry} { + log "HH $name: $value" + return [makeint $entry 7 1] + } else { + if {[llength $list]} {set entry [lindex $list 0]} + if {$add} { + set type MM + set rc [makeint $entry 6 1] + my Index compress $name $value + } else { + set type -- + set rc [makeint $entry 4] + } + if {$entry == 0} { + append rc [makestr $name] + } else { + set type [string replace $type 0 0 H] + } + append rc [makestr $value] + log "$type $name: $value" + return $rc + } + } + + method SendFrame {sid type flags {data ""}} { + my variable fd + set flags [format %08b $flags] + binary scan $data H* hex + log [format {> (%s %d) %d %s %s} [self] $sid $type $flags $hex] + set len [string length $data] + set frame \ + [string range [binary format IcB8I $len $type $flags $sid] 1 end] + append frame $data + puts -nonewline $fd $frame + } + + method PushRequest {} { + # The fact that the http2 class is already mixed into the object means + # that no upgrade has to be requested for http requests + # Skip www::http2helper and go straight to www::connection + nextto www::connection + } + + # Override methods from www library + method Process {} { + my variable fd waiting pending concurrent settings + if {[llength $waiting] == 0} return + if {$concurrent >= [dict get $settings maxstreams]} return + # Process the next request + set waiting [lassign $waiting request] + lappend pending [dict create Request $request Attempt 0] + if {$fd eq ""} { + my Connect + } else { + my Request + } + } + + method Request {} { + my variable fd pending timeout id + if {[eof $fd]} { + my Connect + } + set pending [lassign $pending transaction] + set coro [my ClientStream] + $coro request [dict get $transaction Request] + my Process + } + + method request {data} { + nextto ::www::connection $data + } +} + +oo::objdefine www::http2 { + method settings {new old} { + set data "" + dict for {key val} $old { + incr parameter + if {[dict exists $new $key] && [dict get $new $key] != $val} { + append data [binary format SI $parameter [dict get $new $key]] + } + } + return $data + } + + method headers {} { + namespace upvar ::www::http2 \ + defaultsettings defs preferredsettings prefs + set settings [binary encode base64 [my settings $prefs $defs]] + return [list Connection HTTP2-Settings HTTP2-Settings $settings] + } +} diff --git a/src/vfs/_vfscommon.vfs/modules/www/license.terms b/src/vfs/_vfscommon.vfs/modules/www/license.terms new file mode 100644 index 00000000..10cf6885 --- /dev/null +++ b/src/vfs/_vfscommon.vfs/modules/www/license.terms @@ -0,0 +1,13 @@ +Copyright (c) 2021, Schelte Bron + +Permission to use, copy, modify, and/or distribute this software for any +purpose with or without fee is hereby granted, provided that the above +copyright notice and this permission notice appear in all copies. + +THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES +WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF +MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR +ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES +WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN +ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF +OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. diff --git a/src/vfs/_vfscommon.vfs/modules/www/proxypac-2.1.tm b/src/vfs/_vfscommon.vfs/modules/www/proxypac-2.1.tm new file mode 100644 index 00000000..64a87c58 --- /dev/null +++ b/src/vfs/_vfscommon.vfs/modules/www/proxypac-2.1.tm @@ -0,0 +1,826 @@ +#!/usr/bin/tclsh + +# This library can be used together with www 2.0+ to use a proxy based on a +# Proxy Auto Configure (pac) file: +# package require proxypac +# www configure -proxyfilter {proxypac } +# Example: http://pac.webdefence.global.blackspider.com:8082/proxy.pac + +package require www + +namespace eval www::proxypac { + variable oldpac {} + namespace export proxypac + + proc proxypac {pacurl url host} { + variable oldpac + if {[string equal -length [string length $url] $pacurl $url]} { + # The pac url itself must be reachable directly + return DIRECT + } + try { + if {$pacurl ne $oldpac} { + set data [www get $pacurl] + set oldpac $pacurl + parse $data + } + set proxies [execute FindProxyForURL $url $host] + return [lmap proxy [split $proxies {;}] { + if {[string is space $proxy]} continue + string trim $proxy + }] + } on error {err opts} { + www::log "Failed to auto-configure proxy: $err" + # In case of any error, use a direct connection + return [list DIRECT] + } + } + + proc validip {ipchars} { + set valid [lmap n [split $ipchars .] { + expr {[string is digit -strict $n] && $n < 256} + }] + return [expr {[join $valid ""] eq "1111"}] + } + + proc resolve {host} { + if {[catch {package require dns}]} return + set tok [dns::resolve $host] + dns::wait $tok + set result [lindex [dns::address $tok] 0] + dns::cleanup $tok + return $result + } +} + +if {[catch {package require duktape::oo 0.11}]} { + proc www::proxypac::parse {data} { + set code [convert [string map [list \r\n \n] $data]] + proxypacrun eval $code + } + + proc www::proxypac::execute {args} { + proxypacrun eval $args + } + + proc www::proxypac::convert {data} { + variable tokenlist + set p 0 + set re {/[/=*]?|[*]/|[+][+=]?|[*][*]?=?|-=?|<[<=]?|>>>|>[>=]?|%=?|&&?|[|][|]?|!=?=?|={1,3}|[][(),.{}"';\n?~^]|[ \t]+} + + set tokenlist [lmap n [regexp -all -indices -inline $re $data] { + lassign $n x1 x2 + set str [string range $data $p [expr {$x1 - 1}]] + set sep [string range $data $x1 $x2] + set p [expr {$x2 + 1}] + list $str $sep + }] + + set code [lmap line [block] { + set tabs [string length [lindex [regexp -inline ^\t* $line] 0]] + set indent [string repeat \t [expr {$tabs / 2}]] + append indent [string repeat " " [expr {$tabs % 2}]] + regsub ^\t* $line $indent + }] + return [join $code \n] + } + + proc www::proxypac::peek {{trim 1}} { + variable tokenlist + variable count + if {[incr count] > 20} { + fail "endless loop" + } + if {[llength $tokenlist] == 0} return + lassign [lindex $tokenlist 0] str tag + if {![string is space $tag] || !$trim} { + return [lindex $tokenlist 0] + } elseif {$str ne ""} { + if {[lindex $tokenlist 1 0] ne ""} { + return [lindex $tokenlist 0] + } + lset tokenlist 1 0 $str + } + set tokenlist [lrange $tokenlist 1 end] + tailcall peek + } + + proc www::proxypac::poke {str tag} { + variable tokenlist + lset tokenlist 0 [list $str $tag] + } + + proc www::proxypac::next {{trim 1}} { + variable tokenlist + variable count 0 + set tokenlist [lrange $tokenlist 1 end] + tailcall peek $trim + } + + proc www::proxypac::end {} { + variable tokenlist + return [expr {[llength $tokenlist] == 0}] + } + + proc www::proxypac::code {} { + lassign [peek] str tag + if {$str eq "" && $tag eq "\{"} { + next + lappend rc {*}[block] + lassign [peek] str tag + if {$tag ne "\}"} { + fail "expected \}" + } + next + } else { + lappend rc {*}[statement] + } + return $rc + } + + proc www::proxypac::block {} { + while {![end]} { + lassign [peek] str tag + switch $str { + {} { + if {$tag in {// /*}} { + comment + } + } + default { + set block [statement] + lappend rc {*}$block + } + } + lassign [peek] str tag + if {$tag eq "\}"} { + break + } + } + return $rc + } + + proc www::proxypac::comment {} { + variable tokenlist + variable count 0 + lassign [peek] str tag + if {$tag eq "//"} { + set end \n + } else { + set end "*/" + } + set nl [lsearch -exact -index 1 $tokenlist $end] + if {$nl < 0} {set nl end} + set tokenlist [lreplace $tokenlist 0 $nl] + } + + proc www::proxypac::statement {} { + lassign [peek] str tag + switch $str { + function { + if {![string is space $tag]} { + fail "expected white space" + } + set rc [function] + } + if { + set rc [ifelse] + } + return { + set rc [jsreturn] + } + var { + if {![string is space $tag]} { + fail "expected white space" + } + set rc [var] + } + for { + if {$tag ne "("} { + fail "expected (" + } + set rc [forloop] + } + default { + if {![regexp {^[\w$]+$} $str]} { + fail "unsupported JavaScript command: $str" + } elseif {$tag eq "="} { + set rc [assignment $str] + } elseif {$tag eq "("} { + set rc [list [funccall $str]] + } else { + fail "unsupported JavaScript command: $str (tag = $tag)" + } + } + } + lassign [peek] str tag + if {$tag eq ";"} { + lassign [next] str tag + } + return $rc + } + + proc www::proxypac::jsreturn {} { + lassign [peek] str tag + if {$str eq "" && $tag in {; \n}} { + return [list return] + } else { + poke "" $tag + return [list "return [expression]"] + } + } + + proc www::proxypac::expression {{top 1}} { + lassign [peek] str tag + set rc {} + set unary {} + set strcat 0 + while 1 { + if {$str eq "" && $tag in {+ - ! ~}} { + append unary $tag + lassign [next] str tag + continue + } + switch -regexp $str { + {^$} { + set op [lindex $rc end] + if {$op eq "=="} { + lset rc end eq + } elseif {$op eq "!="} { + lset rc end ne + } + if {$tag in {\" '}} { + set quote $tag + set strvar "" + while 1 { + lassign [next 0] str tag + if {$tag eq $quote} { + append strvar $str + break + } else { + append strvar $str $tag + } + } + lappend rc [format {{%s}} $strvar] + lassign [next] str tag + if {$str ne ""} { + fail "invalid expression" + } + set strcat 1 + } elseif {$tag in "("} { + next + lappend rc [format (%s) [expression 0]] + lassign [peek] str tag + if {$tag ne ")"} { + fail "expected )" + } + next + } + } + {^[\w$]+$} { + if {$tag eq "("} { + lappend rc [format {[%s]} [funccall $str]] + } elseif {$tag eq "\["} { + lappend rc [arrayelem $str] + } elseif {[string is double $str]} { + lappend rc $str + } elseif {[string tolower $str] in {true false}} { + lappend rc $str + } else { + lappend rc [format {$%s} $str] + } + } + default { + fail "expected expression" + } + } + lassign [peek] str tag + while {$tag eq "."} { + lset rc end [method [lindex $rc end]] + lassign [peek] str tag + } + if {$unary ne ""} { + lset rc end $unary[lindex $rc end] + set unary {} + } + switch $tag { + + - - - * - ** - / - % - + == - != - > - < - >= - <= - ? - : - + & - | - ^ - << - >> - && - || { + lappend rc $tag + } + === { + lappend rc == + } + !== { + lappend rc != + } + >>> { + lappend rc >> + } + default { + break + } + } + lassign [next] str tag + } + if {!$top} { + return [join $rc " "] + } elseif {[llength $rc] == 1} { + set rc [lindex $rc 0] + if {[string match {{*}} $rc]} { + return [list [string range $rc 1 end-1]] + } else { + return $rc + } + } elseif {!$strcat} { + return [format {[expr {%s}]} [join $rc " "]] + } + set cat {} + set expr {} + set rest [lassign $rc arg] + set strcat [string match {{*}} $arg] + if {$strcat} { + lappend cat $arg + } else { + lappend expr $arg + } + foreach {op arg} $rest { + if {$op ne "+" || !$strcat && ![string match {{*}} $arg]} { + lappend expr $op $arg + } else { + if {[llength $expr]} { + if {[llength $expr] > 1} { + lappend cat [format {[expr {%s}]} [join $expr]] + } else { + lappend cat [lindex $expr 0] + } + } + set expr {} + if {[string match {{*}} $arg]} { + set strcat 1 + lappend cat $arg + } else { + lappend expr $arg + } + } + } + if {[llength $expr]} { + if {[llength $expr] > 1} { + lappend cat [format {[expr {%s}]} [join $expr]] + } else { + lappend cat [lindex $expr 0] + } + } + return [format {[string cat %s]} [join $cat]] + } + + proc www::proxypac::function {} { + lassign [next] name tag + if {$tag ne "("} { + fail "expected open parenthesis" + } + set arglist {} + lassign [next] str tag + if {$str ne ""} { + while 1 { + lappend arglist $str + if {$tag eq ")"} break + if {$tag ne ","} { + fail "expected , or )" + } + lassign [next] str tag + } + } elseif {$tag ne ")"} { + fail "expected )" + } + lappend rc "proc $name [list $arglist] \{" + lassign [next] str tag + lappend rc {*}[indent [code]] + lappend rc "\}" + return $rc + } + + proc www::proxypac::funccall {name} { + set cmd $name + lassign [next] str tag + if {$str ne "" || $tag ne ")"} { + while 1 { + append cmd " " [expression] + lassign [peek] str tag + if {$tag eq ")"} break + if {$tag ne ","} { + fail "expected , or )" + } + next + } + } + next + return $cmd + } + + proc www::proxypac::ifelse {} { + lassign [peek] str tag + if {$tag ne "("} { + fail "expected (" + } + next + lappend rc [format "if {%s} \{" [expression 0]] + lassign [next] str tag + lappend rc {*}[indent [code]] + lassign [peek] str tag + if {$str eq "else"} { + lappend rc {\} else \{} + lassign [next] str tag + lappend rc {*}[indent [code]] + } + lappend rc "\}" + return $rc + } + + proc www::proxypac::forloop {} { + lassign [peek] str tag + if {$tag ne "("} { + fail "expected (" + } + lassign [next] name tag + if {$name eq "var" && [string is space $tag]} { + lassign [next] name tag + } + if {![regexp {^[\w$]+$} $name]} { + fail "expected identifier" + } + if {$tag eq "="} { + } elseif {[string is space $tag]} { + lassign [next] str tag + if {$str ni {in of} || ![string is space $tag]} { + fail "expected 'in' or 'of'" + } + if {$str eq "in"} { + set op keys + } else { + set op values + } + lassign [next] str tag + lappend rc [format "foreach %s \[dict %s $%s\] \{" $name $op $str] + if {$tag ne ")"} { + fail "expected )" + } + next + lappend rc {*}[indent [code]] + lappend rc "\}" + } + return $rc + } + + proc www::proxypac::method {obj} { + lassign [next] method tag + set cmd [format {%s %s} $method $obj] + if {$tag eq "("} { + lassign [next] str tag + if {$str ne "" || $tag ne ")"} { + while 1 { + append cmd " " [expression] + lassign [peek] str tag + if {$tag eq ")"} break + if {$tag ne ","} { + fail "expected , or )" + } + next + } + } + next + } + return [format {[%s]} $cmd] + } + + proc www::proxypac::assignment {name} { + lassign [next] str tag + switch $str { + new { + if {![string is space $tag]} { + fail "expected white space" + } + lassign [next] str tag + switch $str { + Array { + if {$tag ne "("} { + fail "expected (" + } + set cmd "dict create" + lassign [next] str tag + set index 0 + if {$str ne "" || $tag ne ")"} { + while 1 { + append cmd " " $index " " [expression] + incr index + lassign [peek] str tag + next + if {$tag eq ","} continue + if {$tag eq ")"} break + fail "expected , or )" + } + } else { + next + } + return [list [format {set %s [%s]} $name $cmd]] + } + default { + fail "$str objects are not supported" + } + } + } + {} { + if {$tag eq "\["} { + set cmd list + lassign [next] str tag + if {$str ne "" || $tag ne "]"} { + while 1 { + append cmd " " [expression] + lassign [peek] str tag + next + if {$tag eq ","} continue + if {$tag eq "\]"} break + fail "expected , or \]" + } + } + return [list [format {set %s [%s]} $name $cmd]] + } + } + } + return [list [format {set %s %s} $name [expression]]] + } + + proc www::proxypac::var {} { + lassign [next] str tag + if {![regexp {^[\w$]+$} $str]} { + fail "expected identifier" + } + if {$tag in {; \n}} return + return [assignment $str] + } + + proc www::proxypac::arrayelem {name} { + next + set sub [expression] + lassign [peek] str tag + if {$tag ne "\]"} { + fail "expected \]" + } + next + return [format {[dict get $%s %s]} $name $sub] + } + + proc www::proxypac::indent {list} { + return [lmap line $list {format \t%s $line}] + } + + proc www::proxypac::fail {str} { + error $str + } + + namespace eval www::proxypac { + interp create [namespace current]::proxypacrun + proxypacrun alias resolve [namespace which resolve] + proxypacrun alias validip [namespace which validip] + + proxypacrun eval { + proc substring {str start {end 0}} { + if {[llength [info level 0]] < 4} { + set end [string length $str] + } + if {$start < $end} { + return [string range $str $start [expr {$end - 1}]] + } else { + return [string range $str $end [expr {$start - 1}]] + } + } + + proc toLowerCase {str} { + return [string tolower $str] + } + + rename split tclsplit + proc split {str {separator ""} {limit 2147483647}} { + if {[llength [info level 0]] == 1} { + set list [list $str] + } elseif {$separator eq ""} { + set list [tclsplit $str ""] + } else { + set list {} + set p 0 + while {[set x [string first $separator $str $p]] >= 0} { + lappend list [string range $str $p [expr {$x - 1}]] + set p [expr {$x + [string length $separator]}] + } + lappend list [string range $str $p end] + } + set rc {} + set num 0 + foreach n $list { + if {$num >= $limit} break + dict set rc $num $n + incr num + } + return $rc + } + } + + proc jsfunction {name type args body} { + proxypacrun alias $name \ + apply [list $args $body [namespace current]] + # proxypacrun eval [list proc $name $args $body] + } + } +} else { + namespace eval www::proxypac { + duktape::oo::Duktape create js + + proc parse {data} { + js eval $data + } + + proc execute {args} { + js call {*}$args + } + + proc jsfunction {name type args body} { + js tcl-function $name $type $args $body + } + } +} + +namespace eval www::proxypac { + variable ipaddress "" + + jsfunction isPlainHostName boolean {host} { + return [expr {[string first . $host] < 0}] + } + + jsfunction dnsDomainIs boolean {host domain} { + set x [string first . $host] + return [expr {$x >= 0 && [string range $host $x end] eq $domain}] + } + + jsfunction localHostOrDomainIs boolean {host hostdom} { + return \ + [expr {$host eq $hostdom || $host eq [lindex [split $host .] 0]}] + } + + jsfunction isValidIpAddress boolean {ipchars} { + return [validip $ipchars] + } + + jsfunction isResolvable boolean {host} { + return [expr {[resolve $host] ne ""}] + } + + jsfunction isInNet boolean {host pattern mask} { + if {![validip $host]} { + set host [resolve $host] + if {$host eq ""} {return 0} + } + foreach ip1 [split $host .] ip2 [split $pattern .] m [split $mask .] { + if {($ip1 & $m) != ($ip2 & $m)} {return 0} + } + return 1 + } + + jsfunction dnsResolve string {host} { + return [resolve $host] + } + + jsfunction convert_addr integer {ipaddr} { + binary scan [binary format c4 [split $ipaddr .]] Iu addr + return $addr + } + + jsfunction myIpAddress string {} { + variable ipaddress + if {$ipaddress eq ""} { + try { + set fd "" + set fd [socket -server dummy -myaddr [info hostname] 0] + set ipaddress [lindex [fconfigure $fd -sockname] 0] + } on error {} { + set ipaddress 127.0.0.1 + } finally { + if {$fd ne ""} {close $fd} + } + } + return $ipaddress + } + + jsfunction dnsDomainLevels integer {host} { + return [regexp {[.]} $host] + } + + jsfunction shExpMatch boolean {str shexp} { + return [string match $shexp $str] + } + + jsfunction weekdayRange boolean {wd1 {wd2 ""} {gmt ""}} { + set weekdays {SUN MON TUE WED THU FRI SAT} + if {$wd2 eq "GMT"} { + set gmt 1 + set match [list $wd1] + } else { + set gmt [expr {$gmt eq "GMT"}] + set d1 [lsearch -exact $weekdays $wd1] + set d2 [lsearch -exact $weekdays $wd2] + if {$d1 < $d2} { + set match [lrange $weekdays $d1 $d2] + } else { + set match [list $wd1 $wd2] + } + } + set wd0 [clock format [clock seconds] -gmt $gmt -format %a] + return [expr {[string toupper $wd0] in $match}] + } + + jsfunction dateRange boolean {args} { + set gmt [expr {[lindex $args end] eq "GMT"}] + set len [expr {[llength $args] - $gmt}] + if {$len < 1} {return 0} + set now [clock seconds] + if {$len == 1} { + set arg [lindex $args 0] + if {![string is integer -strict $arg]} { + set mon [clock format $now -format %b -gmt $gmt] + return [expr {$arg eq [string toupper $mon]}] + } elseif {$arg < 32} { + set day [clock format $now -format %e -gmt $gmt] + return [expr {$arg == $day}] + } else { + set year [clock format $now -format %Y -gmt $gmt] + return [expr {$arg == $year}] + } + } + lassign [clock format $now -format {%Y %b} -gmt $gmt] year month + set d1 [list $year JAN 1 0 0 0] + set d2 [list $year DEC 31 23 59 59] + set middle [expr {$len / 2}] + for {set i 0} {$i < $middle} {incr i} { + set arg [lindex $args $i] + if {![string is integer -strict $arg]} { + lset d1 1 $arg + } elseif {$arg < 32} { + lset d1 2 $arg + if {$len <= 2} { + lset d1 1 $month + lset d2 1 $month + } + } else { + lset d1 0 $arg + } + } + for {set i $middle} {$i < $len} {incr i} { + set arg [lindex $args $i] + if {![string is integer -strict $arg]} { + lset d2 1 $arg + } elseif {$arg < 32} { + lset d2 2 $arg + } else { + lset d2 0 $arg + } + } + set time1 [clock scan [join $d1 :] -format %Y:%b:%d:%T -gmt $gmt] + set time2 [clock scan [join $d2 :] -format %Y:%b:%d:%T -gmt $gmt] + if {$time1 < $time2} { + return [expr {$now >= $time1 && $now <= $time2}] + } else { + return [expr {$now >= $time2 && $now <= $time1}] + } + } + + jsfunction timeRange boolean {args} { + set gmt [expr {[lindex $args end] eq "GMT"}] + set len [expr {[llength $args] - $gmt}] + if {$len < 1} { + return 0 + } elseif {$len > 6 || $len == 3 || $len == 5} { + return -code error "timeRange: bad number of arguments" + } + set t1 {0 0 0} + set t2 {23 59 59} + set n [expr {($len + 1) / 2}] + for {set i1 0; set i2 [expr {$len / 2}]} {$i1 < $n} {incr i1; incr i2} { + lset t1 $i1 [lindex $args $i1] + if {$i2 < $len} { + lset t2 $i1 [lindex $args $i2] + } + } + set time1 [clock scan [join $t1 :] -format %T -gmt $gmt] + set time2 [clock scan [join $t2 :] -format %T -gmt $gmt] + set now [clock seconds] + if {$time1 < $time2} { + return [expr {$now >= $time1 && $now <= $time2}] + } else { + return [expr {$now >= $time2 && $now <= $time1}] + } + } + + jsfunction alert undefined {} {} +} + +namespace import www::proxypac::* diff --git a/src/vfs/_vfscommon.vfs/modules/www/socks-1.0.tm b/src/vfs/_vfscommon.vfs/modules/www/socks-1.0.tm new file mode 100644 index 00000000..42a214e9 --- /dev/null +++ b/src/vfs/_vfscommon.vfs/modules/www/socks-1.0.tm @@ -0,0 +1,156 @@ +# SOCKS V4a: http://ftp.icm.edu.pl/packages/socks/socks4/SOCKS4.protocol +# SOCKS V5: RFC 1928 + +namespace eval www::socks { + variable username guest password guest + namespace ensemble create -map {socks4 {init socks4} socks5 {init socks5}} +} + +proc www::socks::command {sock data {count 2} {timeout 2000}} { + if {$data ne ""} { + puts -nonewline $sock $data + flush $sock + } + set coro [info coroutine] + if {[llength $coro]} { + set id [after $timeout [list $coro timeout]] + fileevent $sock readable [list $coro data] + } else { + fconfigure $sock -blocking 1 + set id {} + } + set resp {} + set len 0 + while {![eof $sock]} { + append resp [read $sock [expr {$count - $len}]] + set len [string length $resp] + if {$len >= $count} { + after cancel $id + return $resp + } + if {[llength $coro] == 0} continue + set event [yield] + if {$event eq "data"} continue + if {$event eq "timeout"} break + } + throw {SOCKS PROTOCOL ERROR} "did not get expected response from proxy" +} + +proc www::socks::init {version sock host port} { + # Make sure this is running in a coroutine + if {[llength [info coroutine]] == 0} { + return [coroutine $sock init $version $sock $host $port] + } + dict set cfg -translation [fconfigure $sock -translation] + dict set cfg -blocking [fconfigure $sock -blocking] + dict set event readable [fileevent $sock readable] + dict set event writable [fileevent $sock writable] + fileevent $sock writable {} + fconfigure $sock -translation binary -blocking 0 + if {[catch {$version $sock $host $port} result opts]} { + variable lasterror $result + } + fconfigure $sock {*}$cfg + dict for {ev cmd} $event { + fileevent $sock $ev $cmd + } + return -options [dict incr opts -level] $result +} + +proc www::socks::socks4 {sock host port} { + variable username + set ip4 [split $host .] + if {[llength $ip4] == 4 && [string is digit -strict [lindex $ip4 end]]} { + set data [binary format ccSc4a*x 4 1 $port $ip4 $username] + } else { + # SOCKS4a + set data [binary format ccSx3ca*xa*x 4 1 $port 1 $username $host] + } + binary scan [command $sock $data 8] cucuSc4 vn cd dstport dstip + if {$vn != 0} { + throw {SOCKS CONNECT VERSION} \ + "unsupported socks connection version: $vn" + } + if {$cd != 90} { + throw [list SOCKS CONNECT [format ERROR%02X $cd]] \ + "socks connection failed with error code $cd" + } + return [join $dstip .]:$dstport +} + +proc www::socks::socks5 {sock host port} { + fconfigure $sock -translation binary -blocking 0 + # Authenticate + set methods [list 0 2] + set data [binary format ccc* 5 [llength $methods] $methods] + binary scan [command $sock $data 2] cucu version method + + if {$method == 0} { + # No authentication required + } elseif {$method == 1} { + # GSS-API RFC 1961 + # Not implemented + throw {SOCKS AUTH UNKNOWN} "unsupported authentication method: $method" + } elseif {$method == 2} { + # Username/password RFC 1929 + authenticate $sock + } else { + throw {SOCKS AUTH NOTACCEPTED} "no acceptable authentication methods" + } + + # Connect + set data [binary format ccc 5 1 0] + set ip4 [split $host .] + if {[llength $ip4] == 1 && [llength [set ip6 [split $host :]]] >= 3} { + # IPv6 address + set x [lsearch -exact $ip6 {}] + if {$x >= 0} { + set ip6 [lsearch -inline -exact -all -not $ip6 {}] + set insert [lrepeat [expr {8 - [llength $ip6]}] 0] + set ip6 [linsert $ip6 $x {*}$insert] + } + append data [binary format cS8S 4 $ip6 $port] + } elseif {[llength $ip4] == 4 && [string is digit -strict [lindex $ip4 end]]} { + # IPv4 address + append data [binary format cc4S 1 $ip4 $port] + } else { + # hostname + append data [binary format cca*S 3 [string length $host] $host $port] + } + binary scan [command $sock $data 4 10000] ccxc version reply atyp + if {$reply != 0} { + throw [list SOCKS CONNECT [format ERROR%02X $reply]] \ + "socks connection failed with error code $reply" + } + switch $atyp { + 1 { + binary scan [command $sock {} 6] c4S dstip dstport + return [join $dstip .]:$dstport + } + 3 { + binary scan [command $sock {} 1] c len + binary scan [command $sock {} [expr {$len + 2}]] a${len}S dsthost dstport + return $dsthost:$dstport + } + 4 { + binary scan [command $sock {} 18] S8S dstip dstport + return format {[%s]:$d} [join $dstip :] $dstport + } + } +} + +proc www::socks::authenticate {sock} { + variable username + variable password + set data [binary format cca*ca* 1 \ + [string length $username] $username [string length $password] $password] + binary scan [command $sock 2] cucu version status + if {$version != 1} { + throw {SOCKS AUTH RFC1929 VERSION} \ + "unsupported username/password authentication version: $version" + } + if {$status != 0} { + throw {SOCKS AUTH RFC1929 STATUS} \ + "username/password authentication failed: $status" + } +} diff --git a/src/vfs/_vfscommon.vfs/modules/www/websocket-1.1.tm b/src/vfs/_vfscommon.vfs/modules/www/websocket-1.1.tm new file mode 100644 index 00000000..ef964048 --- /dev/null +++ b/src/vfs/_vfscommon.vfs/modules/www/websocket-1.1.tm @@ -0,0 +1,306 @@ +# Helper library for adding websocket support to www + +package require www 2.7 + +proc www::websocket {args} { + set opts {-upgrade {WebSocket www::WebSocket}} + set args [getopt arg $args { + -timeout:milliseconds {dict set opts -timeout $arg} + -auth:data {dict set opts -auth $arg} + -digest:cred {dict set opts -digest $arg} + -maxredir:cnt {dict set opts -maxredir $arg} + }] + if {[llength $args] < 1 || [llength $args] > 3} { + throw {WWW WEBSOCKET ARGS} {wrong # args:\ + should be "www::websocket url ?protocols? ?extensions?"} + } + lassign $args url protocols extensions + try { + set hdrs [WebSocket headers] + if {[llength $protocols]} { + lappend hdrs Sec-WebSocket-Protocol [join $protocols {, }] + } + if {[dict size $extensions]} { + set ext [join [lmap name [dict keys $extensions] { + set list [list $name] + if {[dict exists $extensions $name parameters]} { + lappend $list [dict get $extensions $name parameters] + } + join $list {; } + }] {, }] + lappend hdrs Sec-WebSocket-Extensions $ext + } + www get {*}$opts -headers $hdrs $url + } on ok {result info} { + if {[dict get $info status code] != 101} { + # The only correct response for a successful websocket connection + # is 101 Switching Protocols. Even 200 OK is not good. + set code [dict get $info status code] + set codegrp [string replace $code 1 2 XX] + set reason [dict get $info status reason] + dict set info -code 1 + dict set info -errorcode [list WWW CODE $codegrp $code $reason] + return -options [dict incr info -level] $result + } + set websock [dict get $info websocket] + set hdrs [dict get $info headers] + set protocol [if {[dict exists $hdrs sec-websocket-protocol]} { + dict get $hdrs sec-websocket-protocol + }] + if {[dict exists $hdrs sec-websocket-extensions]} { + set ext [header [$hdrs sec-websocket-extensions] *] + set mixins [lmap value [lreverse $ext] { + set list [lmap n [split $value {;}] {string trim $n}] + set params [lassign $list name] + dict set parameters $name $params + dict get $extensions $name implementation + }] + oo::objdefine $websock \ + mixin www::WSExtension {*}$mixins www::WebSocket + # Inform the extensions of their parameters, if any + $websock parameters $parameters + } + # Return the websocket object command (and the negotiated protocol) + return protocol $protocol [dict get $info websocket] + } +} + +namespace ensemble configure www \ + -subcommands [linsert [namespace ensemble configure www -subcommands] end websocket] + +oo::class create www::WebSocket { + method Startup {headers} { + my variable fd + variable callback {} + # This socket cannot be used for future connections + release [self] + fconfigure $fd -translation binary -buffering none -blocking 0 + # Return the websocket object to the caller + my Result websocket [self] + my Return [my PopRequest] + } + + method Read {} { + my variable fd + return [read $fd] + } + + method Write {data} { + my variable fd + puts -nonewline $fd $data + } + + method Handler {} { + my variable fd callback + fileevent $fd readable [list [info coroutine] data] + set data "" + set payload "" + while {![eof $fd]} { + yield + append data [my Read] + if {[binary scan $data B4Xcucu flags code len] != 3} continue + if {$len < 126} { + set pos 2 + } elseif {$len == 126} { + if {[binary scan $data x2Su len] != 1} continue + set pos 4 + } elseif {$len == 127} { + if {[binary scan $data x2Wu len] != 1} continue + set pos 10 + } else { + # Error: Messages from server to client should not be masked + my close 1002 + } + if {[string length $data] < $pos + $len} continue + set code [expr {$code & 0xf}] + set payload [string range $data $pos [expr {$pos + $len - 1}]] + set data [string range $data [expr {$pos + $len}] end] + if {$code == 0} { + append message $payload + } else { + set opcode $code + # Control frames MAY be injected in the middle of a + # fragmented message. (RFC6455 5.4) + # Control frames are identified by opcodes where the most + # significant bit of the opcode is 1. (RFC6455 5.5) + if {$code < 8} {set message $payload} + } + if {![string index $flags 0]} continue + if {$opcode < 8} { + my Receive $opcode $message $flags + } else { + my Receive $opcode $payload $flags + } + } + if {[dict exists $callback close]} { + # 1006 is designated for use in applications expecting a status + # code to indicate that the connection was closed abnormally, + # e.g., without sending or receiving a Close control frame. + {*}[dict get $callback close] close 1006 "eof on connection" + } + my destroy + } + + # Methods that can be overridden by extensions + + method Read {} { + my variable fd + return [read $fd] + } + + method Write {data} { + my variable fd + puts -nonewline $fd $data + } + + method Receive {opcode data flags} { + my variable callback + switch $opcode { + 1 { + if {[dict exists $callback text]} { + set str [encoding convertfrom utf-8 $data] + {*}[dict get $callback text] text $str + } else { + my close 1003 + } + } + 2 { + if {[dict exists $callback binary]} { + {*}[dict get $callback binary] binary $data + } else { + my close 1003 + } + } + 8 { + if {[dict exists $callback close]} { + if {[binary scan $data Sua* code reason] != 2} { + set code 1005 + set reason "" + } + {*}[dict get $callback close] close $code $reason + set callback {} + } + } + 9 { + if {[dict exists $callback ping]} { + {*}[dict get $callback ping] ping $data + } else { + my pong $data + } + } + 10 { + if {[dict exists $callback pong]} { + {*}[dict get $callback pong] pong $data + } + } + } + } + + method Transmit {opcode data {flags 1}} { + binary scan $data cu* bytes + # The requirement to use a strong source of entropy makes no sense + # So we'll just use Tcl's simple linear congruential generator + set key [expr {int(rand() * 0x100000000)}] + binary scan [binary format I $key] cu* mask + set length [llength $bytes] + # Apply the mask + set i 0 + set bytes [lmap n $bytes { + set m [lindex $mask [expr {$i & 3}]] + incr i + expr {$n ^ $m} + }] + set type \ + [expr {$opcode | "0b[string reverse [format %04s $flags]]0000"}] + set data [binary format c $type] + if {$length < 126} { + append data [binary format c [expr {$length | 0x80}]] + } elseif {$length < 65536} { + append data [binary format cS [expr {126 | 0x80}] $length] + } else { + append data [binary format cW [expr {127 | 0x80}] $length] + } + append data [binary format c*c* $mask $bytes] + my Write $data + } + + # Public methods + + method callback {types prefix} { + variable callback + set running [dict size $callback] + if {$prefix ne ""} { + foreach type $types { + dict set callback $type $prefix + } + } elseif {[llength $types]} { + set callback [dict remove $callback {*}$types] + } else { + set callback {} + } + if {[dict size $callback]} { + if {!$running} {coroutine websockcoro my Handler} + } else { + if {$running} {rename websockcoro ""} + } + } + + method text {str} { + my Transmit 1 [encoding convertto utf-8 $str] + } + + method binary {data} { + my Transmit 2 $data + } + + method close {{code 1005} {reason ""}} { + # 1005 is designated for use in applications expecting a status code + # to indicate that no status code was actually present. + set payload [if {$code != 1005} { + binary format Sa* $code [encoding convertto utf-8 $reason] + }] + my Transmit 8 $payload + # The client SHOULD wait for the server to close the connection but + # MAY close the connection at any time after sending and receiving + # a Close message, e.g., if it has not received a TCP Close from + # the server in a reasonable time period. + # my destroy + } + + method ping {{data ""}} { + my Transmit 9 $data + } + + method pong {{data ""}} { + my Transmit 10 $data + } +} + +oo::class create www::WSExtension { + method parameters {parameters} { + dict for {mixin params} $parameters { + nextto $mixin $params + } + } +} + +oo::objdefine www::WebSocket { + method key {} { + # Generate a websocket key containing base64-encoded random bytes + # This key is only intended to prevent a caching proxy from + # re-sending a previous WebSocket conversation, and does not + # provide any authentication, privacy or integrity. + # It is therefor not necessary to check the returned hash. + for {set i 0} {$i < 12} {incr i} { + lappend bytes [expr {int(rand() * 256)}] + } + return [binary encode base64 [binary format c* $bytes]] + } + + method headers {} { + return [list Sec-WebSocket-Key [my key] Sec-WebSocket-Version 13] + } +} + +www register ws 80 +www register wss 443 www::encrypt 1 diff --git a/src/vfs/punk9linux.vfs/lib_tcl9/tcllibc/critcl-rt.tcl b/src/vfs/punk9linux.vfs/lib_tcl9/tcllibc/critcl-rt.tcl new file mode 100644 index 00000000..01053a30 --- /dev/null +++ b/src/vfs/punk9linux.vfs/lib_tcl9/tcllibc/critcl-rt.tcl @@ -0,0 +1,381 @@ +# +# Critcl - build C extensions on-the-fly +# +# Copyright (c) 2001-2007 Jean-Claude Wippler +# Copyright (c) 2002-2007 Steve Landers +# +# See http://wiki.tcl.tk/critcl +# +# This is the Critcl runtime that loads the appropriate +# shared library when a package is requested +# + +namespace eval ::critcl::runtime {} + +proc ::critcl::runtime::loadlib {dir package version libname initfun tsrc mapping args} { + # XXX At least parts of this can be done by the package generator, + # XXX like listing the Tcl files to source. The glob here allows + # XXX code-injection after-the-fact, by simply adding a .tcl in + # XXX the proper place. + set path [file join $dir [MapPlatform $mapping]] + set ext [info sharedlibextension] + set lib [file join $path $libname$ext] + set provide [list] + + # Now the runtime equivalent of a series of 'preFetch' commands. + if {[llength $args]} { + set preload [file join $path preload$ext] + foreach p $args { + set prelib [file join $path $p$ext] + if {[file readable $preload] && [file readable $prelib]} { + lappend provide [list load $preload];# XXX Move this out of the loop, do only once. + lappend provide [list ::critcl::runtime::preload $prelib] + } + } + } + + lappend provide [list load $lib $initfun] + foreach t $tsrc { + lappend loadcmd "::critcl::runtime::Fetch \$dir [list $t]" + } + lappend provide "package provide $package $version" + package ifneeded $package $version [join $provide "\n"] + return +} + +proc ::critcl::runtime::preFetch {path ext dll} { + set preload [file join $path preload$ext] + if {![file readable $preload]} return + + set prelib [file join $path $dll$ext] + if {![file readable $prelib]} return + + load $preload ; # Defines next command. + ::critcl::runtime::preload $prelib + return +} + +proc ::critcl::runtime::Fetch {dir t} { + # The 'Ignore' disables compile & run functionality. + + # Background: If the regular critcl package is already loaded, and + # this prebuilt package uses its defining .tcl file also as a + # 'tsources' then critcl might try to collect data and build it + # because of the calls to its API, despite the necessary binaries + # already being present, just not in the critcl cache. That is + # redundant in the best case, and fails in the worst case (no + # compiler), preventing the use o a perfectly fine package. The + # 'ignore' call now tells critcl that it should ignore any calls + # made to it by the sourced files, and thus avoids that trouble. + + # The other case, the regular critcl package getting loaded after + # this prebuilt package is irrelevant. At that point the tsources + # were already run, and used the dummy procedures defined in the + # critcl-rt.tcl, which ignore the calls by definition. + + set t [file join $dir tcl $t] + ::critcl::Ignore $t + uplevel #0 [list source $t] + return +} + +proc ::critcl::runtime::precopy {dll} { + # This command is only used on Windows when preloading out of a + # VFS that doesn't support direct loading (usually, a Starkit) + # - we preserve the dll name so that dependencies are satisfied + # - The critcl::runtime::preload command is defined in the supporting + # "preload" package, implemented in "critcl/lib/critcl/critcl_c/preload.c" + + global env + if {[info exists env(TEMP)]} { + set dir $env(TEMP) + } elseif {[info exists env(TMP)]} { + set dir $env(TMP) + } elseif {[file exists $env(HOME)]} { + set dir $env(HOME) + } else { + set dir . + } + set dir [file join $dir TCL[pid]] + set i 0 + while {[file exists $dir]} { + append dir [incr i] + } + set new [file join $dir [file tail $dll]] + file mkdir $dir + file copy $dll $new + return $new +} + +proc ::critcl::runtime::MapPlatform {{mapping {}}} { + # A sibling of critcl::platform that applies the platform mapping + + set platform [::platform::generic] + set version $::tcl_platform(osVersion) + if {[string match "macosx-*" $platform]} { + # "normalize" the osVersion to match OSX release numbers + set v [split $version .] + set v1 [lindex $v 0] + set v2 [lindex $v 1] + incr v1 -4 + set version 10.$v1.$v2 + } else { + # Strip trailing non-version info + regsub -- {-.*$} $version {} version + } + foreach {config map} $mapping { + if {![string match $config $platform]} continue + set minver [lindex $map 1] + if {[package vcompare $version $minver] < 0} continue + set platform [lindex $map 0] + break + } + return $platform +} + +# Dummy implementation of the critcl package, if not present +if {![llength [info commands ::critcl::Ignore]]} { + namespace eval ::critcl {} + proc ::critcl::Ignore {args} { + namespace eval ::critcl::v {} + set ::critcl::v::ignore([file normalize [lindex $args 0]]) . + } +} +if {![llength [info commands ::critcl::api]]} { + namespace eval ::critcl {} + proc ::critcl::api {args} {} +} +if {![llength [info commands ::critcl::at]]} { + namespace eval ::critcl {} + proc ::critcl::at {args} {} +} +if {![llength [info commands ::critcl::cache]]} { + namespace eval ::critcl {} + proc ::critcl::cache {args} {} +} +if {![llength [info commands ::critcl::ccode]]} { + namespace eval ::critcl {} + proc ::critcl::ccode {args} {} +} +if {![llength [info commands ::critcl::ccommand]]} { + namespace eval ::critcl {} + proc ::critcl::ccommand {args} {} +} +if {![llength [info commands ::critcl::cdata]]} { + namespace eval ::critcl {} + proc ::critcl::cdata {args} {} +} +if {![llength [info commands ::critcl::cdefines]]} { + namespace eval ::critcl {} + proc ::critcl::cdefines {args} {} +} +if {![llength [info commands ::critcl::cflags]]} { + namespace eval ::critcl {} + proc ::critcl::cflags {args} {} +} +if {![llength [info commands ::critcl::cheaders]]} { + namespace eval ::critcl {} + proc ::critcl::cheaders {args} {} +} +if {![llength [info commands ::critcl::check]]} { + namespace eval ::critcl {} + proc ::critcl::check {args} {return 0} +} +if {![llength [info commands ::critcl::cinit]]} { + namespace eval ::critcl {} + proc ::critcl::cinit {args} {} +} +if {![llength [info commands ::critcl::clibraries]]} { + namespace eval ::critcl {} + proc ::critcl::clibraries {args} {} +} +if {![llength [info commands ::critcl::compiled]]} { + namespace eval ::critcl {} + proc ::critcl::compiled {args} {return 1} +} +if {![llength [info commands ::critcl::compiling]]} { + namespace eval ::critcl {} + proc ::critcl::compiling {args} {return 0} +} +if {![llength [info commands ::critcl::config]]} { + namespace eval ::critcl {} + proc ::critcl::config {args} {} +} +if {![llength [info commands ::critcl::cproc]]} { + namespace eval ::critcl {} + proc ::critcl::cproc {args} {} +} +if {![llength [info commands ::critcl::csources]]} { + namespace eval ::critcl {} + proc ::critcl::csources {args} {} +} +if {![llength [info commands ::critcl::debug]]} { + namespace eval ::critcl {} + proc ::critcl::debug {args} {} +} +if {![llength [info commands ::critcl::done]]} { + namespace eval ::critcl {} + proc ::critcl::done {args} {return 1} +} +if {![llength [info commands ::critcl::failed]]} { + namespace eval ::critcl {} + proc ::critcl::failed {args} {return 0} +} +if {![llength [info commands ::critcl::framework]]} { + namespace eval ::critcl {} + proc ::critcl::framework {args} {} +} +if {![llength [info commands ::critcl::include]]} { + namespace eval ::critcl {} + proc ::critcl::include {args} {} +} +if {![llength [info commands ::critcl::ldflags]]} { + namespace eval ::critcl {} + proc ::critcl::ldflags {args} {} +} +if {![llength [info commands ::critcl::license]]} { + namespace eval ::critcl {} + proc ::critcl::license {args} {} +} +if {![llength [info commands ::critcl::load]]} { + namespace eval ::critcl {} + proc ::critcl::load {args} {return 1} +} +if {![llength [info commands ::critcl::make]]} { + namespace eval ::critcl {} + proc ::critcl::make {args} {} +} +if {![llength [info commands ::critcl::meta]]} { + namespace eval ::critcl {} + proc ::critcl::meta {args} {} +} +if {![llength [info commands ::critcl::platform]]} { + namespace eval ::critcl {} + proc ::critcl::platform {args} {} +} +if {![llength [info commands ::critcl::preload]]} { + namespace eval ::critcl {} + proc ::critcl::preload {args} {} +} +if {![llength [info commands ::critcl::source]]} { + namespace eval ::critcl {} + proc ::critcl::source {args} {} +} +if {![llength [info commands ::critcl::tcl]]} { + namespace eval ::critcl {} + proc ::critcl::tcl {args} {} +} +if {![llength [info commands ::critcl::tk]]} { + namespace eval ::critcl {} + proc ::critcl::tk {args} {} +} +if {![llength [info commands ::critcl::tsources]]} { + namespace eval ::critcl {} + proc ::critcl::tsources {args} {} +} +if {![llength [info commands ::critcl::userconfig]]} { + namespace eval ::critcl {} + proc ::critcl::userconfig {args} {} +} + +# Define a clone of platform::generic, if needed +if {![llength [info commands ::platform::generic]]} { + namespace eval ::platform {} + proc ::platform::generic {} { + global tcl_platform + + set plat [string tolower [lindex $tcl_platform(os) 0]] + set cpu $tcl_platform(machine) + + switch -glob -- $cpu { + sun4* { + set cpu sparc + } + intel - + ia32* - + i*86* { + set cpu ix86 + } + x86_64 { + if {$tcl_platform(wordSize) == 4} { + # See Example <1> at the top of this file. + set cpu ix86 + } + } + ppc - + "Power*" { + set cpu powerpc + } + "arm*" { + set cpu arm + } + ia64 { + if {$tcl_platform(wordSize) == 4} { + append cpu _32 + } + } + } + + switch -glob -- $plat { + windows { + if {$tcl_platform(platform) == "unix"} { + set plat cygwin + } else { + set plat win32 + } + if {$cpu eq "amd64"} { + # Do not check wordSize, win32-x64 is an IL32P64 platform. + set cpu x86_64 + } + } + sunos { + set plat solaris + if {[string match "ix86" $cpu]} { + if {$tcl_platform(wordSize) == 8} { + set cpu x86_64 + } + } elseif {![string match "ia64*" $cpu]} { + # sparc + if {$tcl_platform(wordSize) == 8} { + append cpu 64 + } + } + } + darwin { + set plat macosx + # Correctly identify the cpu when running as a 64bit + # process on a machine with a 32bit kernel + if {$cpu eq "ix86"} { + if {$tcl_platform(wordSize) == 8} { + set cpu x86_64 + } + } + } + aix { + set cpu powerpc + if {$tcl_platform(wordSize) == 8} { + append cpu 64 + } + } + hp-ux { + set plat hpux + if {![string match "ia64*" $cpu]} { + set cpu parisc + if {$tcl_platform(wordSize) == 8} { + append cpu 64 + } + } + } + osf1 { + set plat tru64 + } + default { + set plat [lindex [split $plat _-] 0] + } + } + + return "${plat}-${cpu}" + } +} + + diff --git a/src/vfs/punk9linux.vfs/lib_tcl9/tcllibc/license.terms b/src/vfs/punk9linux.vfs/lib_tcl9/tcllibc/license.terms new file mode 100644 index 00000000..96651147 --- /dev/null +++ b/src/vfs/punk9linux.vfs/lib_tcl9/tcllibc/license.terms @@ -0,0 +1 @@ +<> diff --git a/src/vfs/punk9linux.vfs/lib_tcl9/tcllibc/linux-x86_64/tcllibc.so b/src/vfs/punk9linux.vfs/lib_tcl9/tcllibc/linux-x86_64/tcllibc.so new file mode 100644 index 00000000..dee52eee Binary files /dev/null and b/src/vfs/punk9linux.vfs/lib_tcl9/tcllibc/linux-x86_64/tcllibc.so differ diff --git a/src/vfs/punk9linux.vfs/lib_tcl9/tcllibc/pkgIndex.tcl b/src/vfs/punk9linux.vfs/lib_tcl9/tcllibc/pkgIndex.tcl new file mode 100644 index 00000000..03a1100a --- /dev/null +++ b/src/vfs/punk9linux.vfs/lib_tcl9/tcllibc/pkgIndex.tcl @@ -0,0 +1,2 @@ +if {![package vsatisfies [package provide Tcl] 9.0]} {return} +package ifneeded tcllibc 2.0 "[list proc __critcl_load__ {dir} { ; source [file join $dir critcl-rt.tcl] ; set path [file join $dir [::critcl::runtime::MapPlatform]] ; set ext [info sharedlibextension] ; set lib [file join $path "tcllibc$ext"] ; load $lib Tcllibc ; package provide tcllibc 2.0 ; catch {rename __critcl_load__ {}}}] ; [list __critcl_load__ $dir]" diff --git a/src/vfs/punk9linux.vfs/lib_tcl9/tcllibc/teapot.txt b/src/vfs/punk9linux.vfs/lib_tcl9/tcllibc/teapot.txt new file mode 100644 index 00000000..a0cd3d29 --- /dev/null +++ b/src/vfs/punk9linux.vfs/lib_tcl9/tcllibc/teapot.txt @@ -0,0 +1,21 @@ +Package tcllibc 2.0 +Meta platform linux-glibc2.22-x86_64 +Meta build::date 2025-08-20 +Meta generated::by {critcl 3.3} obermeier {critcl 3.3} obermeier +Meta generated::by {critcl 3.3} obermeier {critcl 3.3} obermeier +Meta generated::by {critcl 3.3} obermeier {critcl 3.3} obermeier +Meta generated::by {critcl 3.3} obermeier {critcl 3.3} obermeier +Meta generated::by {critcl 3.3} obermeier {critcl 3.3} obermeier +Meta generated::by {critcl 3.3} obermeier {critcl 3.3} obermeier +Meta generated::by {critcl 3.3} obermeier {critcl 3.3} obermeier +Meta generated::by {critcl 3.3} obermeier {critcl 3.3} obermeier +Meta generated::by {critcl 3.3} obermeier {critcl 3.3} obermeier +Meta generated::by {critcl 3.3} obermeier {critcl 3.3} obermeier +Meta generated::date critcl +Meta license BSD licensed. +Meta author {Andreas Kupries} +Meta require {Tcl 8.5 9} {Tcl 8.5 9} {Tcl 8.5 9} {Tcl 8.5 9} {Tcl 8.5 9} +Meta require {Tcl 8.5 9} {Tcl 8.5 9} {Tcl 8.5 9} {Tcl 8.5 9} {Tcl 8.5 9} +Meta require {Tcl 8.5 9} {Tcl 8.5 9} +Meta entrytclcommand {eval "[list proc __critcl_load__ {dir} { ; source [file join $dir critcl-rt.tcl] ; set path [file join $dir [::critcl::runtime::MapPlatform]] ; set ext [info sharedlibextension] ; set lib [file join $path "tcllibc$ext"] ; load $lib Tcllibc ; package provide tcllibc 2.0 ; catch {rename __critcl_load__ {}}}] ; [list __critcl_load__ $dir]"} +Meta included critcl-rt.tcl linux-x86_64/tcllibc.so diff --git a/src/vfs/punk9linux.vfs/lib_tcl9/tcllibc2.0/critcl-rt.tcl b/src/vfs/punk9linux.vfs/lib_tcl9/tcllibc2.0/critcl-rt.tcl new file mode 100644 index 00000000..01053a30 --- /dev/null +++ b/src/vfs/punk9linux.vfs/lib_tcl9/tcllibc2.0/critcl-rt.tcl @@ -0,0 +1,381 @@ +# +# Critcl - build C extensions on-the-fly +# +# Copyright (c) 2001-2007 Jean-Claude Wippler +# Copyright (c) 2002-2007 Steve Landers +# +# See http://wiki.tcl.tk/critcl +# +# This is the Critcl runtime that loads the appropriate +# shared library when a package is requested +# + +namespace eval ::critcl::runtime {} + +proc ::critcl::runtime::loadlib {dir package version libname initfun tsrc mapping args} { + # XXX At least parts of this can be done by the package generator, + # XXX like listing the Tcl files to source. The glob here allows + # XXX code-injection after-the-fact, by simply adding a .tcl in + # XXX the proper place. + set path [file join $dir [MapPlatform $mapping]] + set ext [info sharedlibextension] + set lib [file join $path $libname$ext] + set provide [list] + + # Now the runtime equivalent of a series of 'preFetch' commands. + if {[llength $args]} { + set preload [file join $path preload$ext] + foreach p $args { + set prelib [file join $path $p$ext] + if {[file readable $preload] && [file readable $prelib]} { + lappend provide [list load $preload];# XXX Move this out of the loop, do only once. + lappend provide [list ::critcl::runtime::preload $prelib] + } + } + } + + lappend provide [list load $lib $initfun] + foreach t $tsrc { + lappend loadcmd "::critcl::runtime::Fetch \$dir [list $t]" + } + lappend provide "package provide $package $version" + package ifneeded $package $version [join $provide "\n"] + return +} + +proc ::critcl::runtime::preFetch {path ext dll} { + set preload [file join $path preload$ext] + if {![file readable $preload]} return + + set prelib [file join $path $dll$ext] + if {![file readable $prelib]} return + + load $preload ; # Defines next command. + ::critcl::runtime::preload $prelib + return +} + +proc ::critcl::runtime::Fetch {dir t} { + # The 'Ignore' disables compile & run functionality. + + # Background: If the regular critcl package is already loaded, and + # this prebuilt package uses its defining .tcl file also as a + # 'tsources' then critcl might try to collect data and build it + # because of the calls to its API, despite the necessary binaries + # already being present, just not in the critcl cache. That is + # redundant in the best case, and fails in the worst case (no + # compiler), preventing the use o a perfectly fine package. The + # 'ignore' call now tells critcl that it should ignore any calls + # made to it by the sourced files, and thus avoids that trouble. + + # The other case, the regular critcl package getting loaded after + # this prebuilt package is irrelevant. At that point the tsources + # were already run, and used the dummy procedures defined in the + # critcl-rt.tcl, which ignore the calls by definition. + + set t [file join $dir tcl $t] + ::critcl::Ignore $t + uplevel #0 [list source $t] + return +} + +proc ::critcl::runtime::precopy {dll} { + # This command is only used on Windows when preloading out of a + # VFS that doesn't support direct loading (usually, a Starkit) + # - we preserve the dll name so that dependencies are satisfied + # - The critcl::runtime::preload command is defined in the supporting + # "preload" package, implemented in "critcl/lib/critcl/critcl_c/preload.c" + + global env + if {[info exists env(TEMP)]} { + set dir $env(TEMP) + } elseif {[info exists env(TMP)]} { + set dir $env(TMP) + } elseif {[file exists $env(HOME)]} { + set dir $env(HOME) + } else { + set dir . + } + set dir [file join $dir TCL[pid]] + set i 0 + while {[file exists $dir]} { + append dir [incr i] + } + set new [file join $dir [file tail $dll]] + file mkdir $dir + file copy $dll $new + return $new +} + +proc ::critcl::runtime::MapPlatform {{mapping {}}} { + # A sibling of critcl::platform that applies the platform mapping + + set platform [::platform::generic] + set version $::tcl_platform(osVersion) + if {[string match "macosx-*" $platform]} { + # "normalize" the osVersion to match OSX release numbers + set v [split $version .] + set v1 [lindex $v 0] + set v2 [lindex $v 1] + incr v1 -4 + set version 10.$v1.$v2 + } else { + # Strip trailing non-version info + regsub -- {-.*$} $version {} version + } + foreach {config map} $mapping { + if {![string match $config $platform]} continue + set minver [lindex $map 1] + if {[package vcompare $version $minver] < 0} continue + set platform [lindex $map 0] + break + } + return $platform +} + +# Dummy implementation of the critcl package, if not present +if {![llength [info commands ::critcl::Ignore]]} { + namespace eval ::critcl {} + proc ::critcl::Ignore {args} { + namespace eval ::critcl::v {} + set ::critcl::v::ignore([file normalize [lindex $args 0]]) . + } +} +if {![llength [info commands ::critcl::api]]} { + namespace eval ::critcl {} + proc ::critcl::api {args} {} +} +if {![llength [info commands ::critcl::at]]} { + namespace eval ::critcl {} + proc ::critcl::at {args} {} +} +if {![llength [info commands ::critcl::cache]]} { + namespace eval ::critcl {} + proc ::critcl::cache {args} {} +} +if {![llength [info commands ::critcl::ccode]]} { + namespace eval ::critcl {} + proc ::critcl::ccode {args} {} +} +if {![llength [info commands ::critcl::ccommand]]} { + namespace eval ::critcl {} + proc ::critcl::ccommand {args} {} +} +if {![llength [info commands ::critcl::cdata]]} { + namespace eval ::critcl {} + proc ::critcl::cdata {args} {} +} +if {![llength [info commands ::critcl::cdefines]]} { + namespace eval ::critcl {} + proc ::critcl::cdefines {args} {} +} +if {![llength [info commands ::critcl::cflags]]} { + namespace eval ::critcl {} + proc ::critcl::cflags {args} {} +} +if {![llength [info commands ::critcl::cheaders]]} { + namespace eval ::critcl {} + proc ::critcl::cheaders {args} {} +} +if {![llength [info commands ::critcl::check]]} { + namespace eval ::critcl {} + proc ::critcl::check {args} {return 0} +} +if {![llength [info commands ::critcl::cinit]]} { + namespace eval ::critcl {} + proc ::critcl::cinit {args} {} +} +if {![llength [info commands ::critcl::clibraries]]} { + namespace eval ::critcl {} + proc ::critcl::clibraries {args} {} +} +if {![llength [info commands ::critcl::compiled]]} { + namespace eval ::critcl {} + proc ::critcl::compiled {args} {return 1} +} +if {![llength [info commands ::critcl::compiling]]} { + namespace eval ::critcl {} + proc ::critcl::compiling {args} {return 0} +} +if {![llength [info commands ::critcl::config]]} { + namespace eval ::critcl {} + proc ::critcl::config {args} {} +} +if {![llength [info commands ::critcl::cproc]]} { + namespace eval ::critcl {} + proc ::critcl::cproc {args} {} +} +if {![llength [info commands ::critcl::csources]]} { + namespace eval ::critcl {} + proc ::critcl::csources {args} {} +} +if {![llength [info commands ::critcl::debug]]} { + namespace eval ::critcl {} + proc ::critcl::debug {args} {} +} +if {![llength [info commands ::critcl::done]]} { + namespace eval ::critcl {} + proc ::critcl::done {args} {return 1} +} +if {![llength [info commands ::critcl::failed]]} { + namespace eval ::critcl {} + proc ::critcl::failed {args} {return 0} +} +if {![llength [info commands ::critcl::framework]]} { + namespace eval ::critcl {} + proc ::critcl::framework {args} {} +} +if {![llength [info commands ::critcl::include]]} { + namespace eval ::critcl {} + proc ::critcl::include {args} {} +} +if {![llength [info commands ::critcl::ldflags]]} { + namespace eval ::critcl {} + proc ::critcl::ldflags {args} {} +} +if {![llength [info commands ::critcl::license]]} { + namespace eval ::critcl {} + proc ::critcl::license {args} {} +} +if {![llength [info commands ::critcl::load]]} { + namespace eval ::critcl {} + proc ::critcl::load {args} {return 1} +} +if {![llength [info commands ::critcl::make]]} { + namespace eval ::critcl {} + proc ::critcl::make {args} {} +} +if {![llength [info commands ::critcl::meta]]} { + namespace eval ::critcl {} + proc ::critcl::meta {args} {} +} +if {![llength [info commands ::critcl::platform]]} { + namespace eval ::critcl {} + proc ::critcl::platform {args} {} +} +if {![llength [info commands ::critcl::preload]]} { + namespace eval ::critcl {} + proc ::critcl::preload {args} {} +} +if {![llength [info commands ::critcl::source]]} { + namespace eval ::critcl {} + proc ::critcl::source {args} {} +} +if {![llength [info commands ::critcl::tcl]]} { + namespace eval ::critcl {} + proc ::critcl::tcl {args} {} +} +if {![llength [info commands ::critcl::tk]]} { + namespace eval ::critcl {} + proc ::critcl::tk {args} {} +} +if {![llength [info commands ::critcl::tsources]]} { + namespace eval ::critcl {} + proc ::critcl::tsources {args} {} +} +if {![llength [info commands ::critcl::userconfig]]} { + namespace eval ::critcl {} + proc ::critcl::userconfig {args} {} +} + +# Define a clone of platform::generic, if needed +if {![llength [info commands ::platform::generic]]} { + namespace eval ::platform {} + proc ::platform::generic {} { + global tcl_platform + + set plat [string tolower [lindex $tcl_platform(os) 0]] + set cpu $tcl_platform(machine) + + switch -glob -- $cpu { + sun4* { + set cpu sparc + } + intel - + ia32* - + i*86* { + set cpu ix86 + } + x86_64 { + if {$tcl_platform(wordSize) == 4} { + # See Example <1> at the top of this file. + set cpu ix86 + } + } + ppc - + "Power*" { + set cpu powerpc + } + "arm*" { + set cpu arm + } + ia64 { + if {$tcl_platform(wordSize) == 4} { + append cpu _32 + } + } + } + + switch -glob -- $plat { + windows { + if {$tcl_platform(platform) == "unix"} { + set plat cygwin + } else { + set plat win32 + } + if {$cpu eq "amd64"} { + # Do not check wordSize, win32-x64 is an IL32P64 platform. + set cpu x86_64 + } + } + sunos { + set plat solaris + if {[string match "ix86" $cpu]} { + if {$tcl_platform(wordSize) == 8} { + set cpu x86_64 + } + } elseif {![string match "ia64*" $cpu]} { + # sparc + if {$tcl_platform(wordSize) == 8} { + append cpu 64 + } + } + } + darwin { + set plat macosx + # Correctly identify the cpu when running as a 64bit + # process on a machine with a 32bit kernel + if {$cpu eq "ix86"} { + if {$tcl_platform(wordSize) == 8} { + set cpu x86_64 + } + } + } + aix { + set cpu powerpc + if {$tcl_platform(wordSize) == 8} { + append cpu 64 + } + } + hp-ux { + set plat hpux + if {![string match "ia64*" $cpu]} { + set cpu parisc + if {$tcl_platform(wordSize) == 8} { + append cpu 64 + } + } + } + osf1 { + set plat tru64 + } + default { + set plat [lindex [split $plat _-] 0] + } + } + + return "${plat}-${cpu}" + } +} + + diff --git a/src/vfs/punk9linux.vfs/lib_tcl9/tcllibc2.0/license.terms b/src/vfs/punk9linux.vfs/lib_tcl9/tcllibc2.0/license.terms new file mode 100644 index 00000000..96651147 --- /dev/null +++ b/src/vfs/punk9linux.vfs/lib_tcl9/tcllibc2.0/license.terms @@ -0,0 +1 @@ +<> diff --git a/src/vfs/punk9linux.vfs/lib_tcl9/tcllibc2.0/linux-x86_64/tcllibc.so b/src/vfs/punk9linux.vfs/lib_tcl9/tcllibc2.0/linux-x86_64/tcllibc.so new file mode 100644 index 00000000..dee52eee Binary files /dev/null and b/src/vfs/punk9linux.vfs/lib_tcl9/tcllibc2.0/linux-x86_64/tcllibc.so differ diff --git a/src/vfs/punk9linux.vfs/lib_tcl9/tcllibc2.0/pkgIndex.tcl b/src/vfs/punk9linux.vfs/lib_tcl9/tcllibc2.0/pkgIndex.tcl new file mode 100644 index 00000000..03a1100a --- /dev/null +++ b/src/vfs/punk9linux.vfs/lib_tcl9/tcllibc2.0/pkgIndex.tcl @@ -0,0 +1,2 @@ +if {![package vsatisfies [package provide Tcl] 9.0]} {return} +package ifneeded tcllibc 2.0 "[list proc __critcl_load__ {dir} { ; source [file join $dir critcl-rt.tcl] ; set path [file join $dir [::critcl::runtime::MapPlatform]] ; set ext [info sharedlibextension] ; set lib [file join $path "tcllibc$ext"] ; load $lib Tcllibc ; package provide tcllibc 2.0 ; catch {rename __critcl_load__ {}}}] ; [list __critcl_load__ $dir]" diff --git a/src/vfs/punk9linux.vfs/lib_tcl9/tcllibc2.0/teapot.txt b/src/vfs/punk9linux.vfs/lib_tcl9/tcllibc2.0/teapot.txt new file mode 100644 index 00000000..a0cd3d29 --- /dev/null +++ b/src/vfs/punk9linux.vfs/lib_tcl9/tcllibc2.0/teapot.txt @@ -0,0 +1,21 @@ +Package tcllibc 2.0 +Meta platform linux-glibc2.22-x86_64 +Meta build::date 2025-08-20 +Meta generated::by {critcl 3.3} obermeier {critcl 3.3} obermeier +Meta generated::by {critcl 3.3} obermeier {critcl 3.3} obermeier +Meta generated::by {critcl 3.3} obermeier {critcl 3.3} obermeier +Meta generated::by {critcl 3.3} obermeier {critcl 3.3} obermeier +Meta generated::by {critcl 3.3} obermeier {critcl 3.3} obermeier +Meta generated::by {critcl 3.3} obermeier {critcl 3.3} obermeier +Meta generated::by {critcl 3.3} obermeier {critcl 3.3} obermeier +Meta generated::by {critcl 3.3} obermeier {critcl 3.3} obermeier +Meta generated::by {critcl 3.3} obermeier {critcl 3.3} obermeier +Meta generated::by {critcl 3.3} obermeier {critcl 3.3} obermeier +Meta generated::date critcl +Meta license BSD licensed. +Meta author {Andreas Kupries} +Meta require {Tcl 8.5 9} {Tcl 8.5 9} {Tcl 8.5 9} {Tcl 8.5 9} {Tcl 8.5 9} +Meta require {Tcl 8.5 9} {Tcl 8.5 9} {Tcl 8.5 9} {Tcl 8.5 9} {Tcl 8.5 9} +Meta require {Tcl 8.5 9} {Tcl 8.5 9} +Meta entrytclcommand {eval "[list proc __critcl_load__ {dir} { ; source [file join $dir critcl-rt.tcl] ; set path [file join $dir [::critcl::runtime::MapPlatform]] ; set ext [info sharedlibextension] ; set lib [file join $path "tcllibc$ext"] ; load $lib Tcllibc ; package provide tcllibc 2.0 ; catch {rename __critcl_load__ {}}}] ; [list __critcl_load__ $dir]"} +Meta included critcl-rt.tcl linux-x86_64/tcllibc.so diff --git a/src/vfs/punk9linux.vfs/lib_tcl9/tcltls/pkgIndex.tcl b/src/vfs/punk9linux.vfs/lib_tcl9/tcltls/pkgIndex.tcl new file mode 100644 index 00000000..7a47789d --- /dev/null +++ b/src/vfs/punk9linux.vfs/lib_tcl9/tcltls/pkgIndex.tcl @@ -0,0 +1,16 @@ +if {[package vsatisfies [package present Tcl] 8.5-]} { + package ifneeded tls 1.7.23 [list apply {{dir} { + if {{shared} eq "static"} { + load {} Tls + } else { + load [file join $dir tcltls.so] Tls + } + + set tlsTclInitScript [file join $dir tls.tcl] + if {[file exists $tlsTclInitScript]} { + source $tlsTclInitScript + } + }} $dir] +} elseif {[package vsatisfies [package present Tcl] 8.4]} { + package ifneeded tls 1.7.23 [list load [file join $dir tcltls.so] Tls] +} diff --git a/src/vfs/punk9linux.vfs/lib_tcl9/tcltls/tcltls.so b/src/vfs/punk9linux.vfs/lib_tcl9/tcltls/tcltls.so new file mode 100644 index 00000000..18ddbf0d Binary files /dev/null and b/src/vfs/punk9linux.vfs/lib_tcl9/tcltls/tcltls.so differ diff --git a/src/vfs/punk9linux.vfs/lib_tcl9/tcltls/tls.tcl b/src/vfs/punk9linux.vfs/lib_tcl9/tcltls/tls.tcl new file mode 100644 index 00000000..e8a4ede6 --- /dev/null +++ b/src/vfs/punk9linux.vfs/lib_tcl9/tcltls/tls.tcl @@ -0,0 +1,398 @@ +# +# Copyright (C) 1997-2000 Matt Newman +# +namespace eval tls { + variable logcmd tclLog + variable debug 0 + + # Default flags passed to tls::import + variable defaults {} + + # Maps UID to Server Socket + variable srvmap + variable srvuid 0 + + # Over-ride this if you are using a different socket command + variable socketCmd + if {![info exists socketCmd]} { + set socketCmd [info command ::socket] + } + + # This is the possible arguments to tls::socket and tls::init + # The format of this is a list of lists + ## Each inner list contains the following elements + ### Server (matched against "string match" for 0/1) + ### Option name + ### Variable to add the option to: + #### sopts: [socket] option + #### iopts: [tls::import] option + ### How many arguments the following the option to consume + variable socketOptionRules { + {0 -async sopts 0} + {* -myaddr sopts 1} + {0 -myport sopts 1} + {* -type sopts 1} + {* -cadir iopts 1} + {* -cafile iopts 1} + {* -cert iopts 1} + {* -certfile iopts 1} + {* -cipher iopts 1} + {* -command iopts 1} + {* -dhparams iopts 1} + {* -key iopts 1} + {* -keyfile iopts 1} + {* -password iopts 1} + {* -request iopts 1} + {* -require iopts 1} + {* -autoservername discardOpts 1} + {* -servername iopts 1} + {* -ssl2 iopts 1} + {* -ssl3 iopts 1} + {* -tls1 iopts 1} + {* -tls1.1 iopts 1} + {* -tls1.2 iopts 1} + {* -tls1.3 iopts 1} + } + + # tls::socket and tls::init options as a humane readable string + variable socketOptionsNoServer + variable socketOptionsServer + + # Internal [switch] body to validate options + variable socketOptionsSwitchBody +} + +proc tls::_initsocketoptions {} { + variable socketOptionRules + variable socketOptionsNoServer + variable socketOptionsServer + variable socketOptionsSwitchBody + + # Do not re-run if we have already been initialized + if {[info exists socketOptionsSwitchBody]} { + return + } + + # Create several structures from our list of options + ## 1. options: a text representation of the valid options for the current + ## server type + ## 2. argSwitchBody: Switch body for processing arguments + set options(0) [list] + set options(1) [list] + set argSwitchBody [list] + foreach optionRule $socketOptionRules { + set ruleServer [lindex $optionRule 0] + set ruleOption [lindex $optionRule 1] + set ruleVarToUpdate [lindex $optionRule 2] + set ruleVarArgsToConsume [lindex $optionRule 3] + + foreach server [list 0 1] { + if {![string match $ruleServer $server]} { + continue + } + + lappend options($server) $ruleOption + } + + switch -- $ruleVarArgsToConsume { + 0 { + set argToExecute { + lappend @VAR@ $arg + set argsArray($arg) true + } + } + 1 { + set argToExecute { + incr idx + if {$idx >= [llength $args]} { + return -code error "\"$arg\" option must be followed by value" + } + set argValue [lindex $args $idx] + lappend @VAR@ $arg $argValue + set argsArray($arg) $argValue + } + } + default { + return -code error "Internal argument construction error" + } + } + + lappend argSwitchBody $ruleServer,$ruleOption [string map [list @VAR@ $ruleVarToUpdate] $argToExecute] + } + + # Add in the final options + lappend argSwitchBody {*,-*} {return -code error "bad option \"$arg\": must be one of $options"} + lappend argSwitchBody default break + + # Set the final variables + set socketOptionsNoServer [join $options(0) {, }] + set socketOptionsServer [join $options(1) {, }] + set socketOptionsSwitchBody $argSwitchBody +} + +proc tls::initlib {dir dll} { + # Package index cd's into the package directory for loading. + # Irrelevant to unixoids, but for Windows this enables the OS to find + # the dependent DLL's in the CWD, where they may be. + set cwd [pwd] + catch {cd $dir} + if {[string equal $::tcl_platform(platform) "windows"] && + ![string equal [lindex [file system $dir] 0] "native"]} { + # If it is a wrapped executable running on windows, the openssl + # dlls must be copied out of the virtual filesystem to the disk + # where Windows will find them when resolving the dependency in + # the tls dll. We choose to make them siblings of the executable. + package require starkit + set dst [file nativename [file dirname $starkit::topdir]] + foreach sdll [glob -nocomplain -directory $dir -tails *eay32.dll] { + catch {file delete -force $dst/$sdll} + catch {file copy -force $dir/$sdll $dst/$sdll} + } + } + set res [catch {uplevel #0 [list load [file join [pwd] $dll]]} err] + catch {cd $cwd} + if {$res} { + namespace eval [namespace parent] {namespace delete tls} + return -code $res $err + } + rename tls::initlib {} +} + + +# +# Backwards compatibility, also used to set the default +# context options +# +proc tls::init {args} { + variable defaults + variable socketOptionsNoServer + variable socketOptionsServer + variable socketOptionsSwitchBody + + tls::_initsocketoptions + + # Technically a third option should be used here: Options that are valid + # only a both servers and non-servers + set server -1 + set options $socketOptionsServer + + # Validate arguments passed + set initialArgs $args + set argc [llength $args] + + array set argsArray [list] + for {set idx 0} {$idx < $argc} {incr idx} { + set arg [lindex $args $idx] + switch -glob -- $server,$arg $socketOptionsSwitchBody + } + + set defaults $initialArgs +} +# +# Helper function - behaves exactly as the native socket command. +# +proc tls::socket {args} { + variable socketCmd + variable defaults + variable socketOptionsNoServer + variable socketOptionsServer + variable socketOptionsSwitchBody + + tls::_initsocketoptions + + set idx [lsearch $args -server] + if {$idx != -1} { + set server 1 + set callback [lindex $args [expr {$idx+1}]] + set args [lreplace $args $idx [expr {$idx+1}]] + + set usage "wrong # args: should be \"tls::socket -server command ?options? port\"" + set options $socketOptionsServer + } else { + set server 0 + + set usage "wrong # args: should be \"tls::socket ?options? host port\"" + set options $socketOptionsNoServer + } + + # Combine defaults with current options + set args [concat $defaults $args] + + set argc [llength $args] + set sopts {} + set iopts [list -server $server] + + array set argsArray [list] + for {set idx 0} {$idx < $argc} {incr idx} { + set arg [lindex $args $idx] + switch -glob -- $server,$arg $socketOptionsSwitchBody + } + + if {$server} { + if {($idx + 1) != $argc} { + return -code error $usage + } + set uid [incr ::tls::srvuid] + + set port [lindex $args [expr {$argc-1}]] + lappend sopts $port + #set sopts [linsert $sopts 0 -server $callback] + set sopts [linsert $sopts 0 -server [list tls::_accept $iopts $callback]] + #set sopts [linsert $sopts 0 -server [list tls::_accept $uid $callback]] + } else { + if {($idx + 2) != $argc} { + return -code error $usage + } + + set host [lindex $args [expr {$argc-2}]] + set port [lindex $args [expr {$argc-1}]] + + # If an "-autoservername" option is found, honor it + if {[info exists argsArray(-autoservername)] && $argsArray(-autoservername)} { + if {![info exists argsArray(-servername)]} { + set argsArray(-servername) $host + lappend iopts -servername $host + } + } + + lappend sopts $host $port + } + # + # Create TCP/IP socket + # + set chan [eval $socketCmd $sopts] + if {!$server && [catch { + # + # Push SSL layer onto socket + # + eval [list tls::import] $chan $iopts + } err]} { + set info ${::errorInfo} + catch {close $chan} + return -code error -errorinfo $info $err + } + return $chan +} + +# tls::_accept -- +# +# This is the actual accept that TLS sockets use, which then calls +# the callback registered by tls::socket. +# +# Arguments: +# iopts tls::import opts +# callback server callback to invoke +# chan socket channel to accept/deny +# ipaddr calling IP address +# port calling port +# +# Results: +# Returns an error if the callback throws one. +# +proc tls::_accept { iopts callback chan ipaddr port } { + log 2 [list tls::_accept $iopts $callback $chan $ipaddr $port] + + set chan [eval [list tls::import $chan] $iopts] + + lappend callback $chan $ipaddr $port + if {[catch { + uplevel #0 $callback + } err]} { + log 1 "tls::_accept error: ${::errorInfo}" + close $chan + error $err $::errorInfo $::errorCode + } else { + log 2 "tls::_accept - called \"$callback\" succeeded" + } +} +# +# Sample callback for hooking: - +# +# error +# verify +# info +# +proc tls::callback {option args} { + variable debug + + #log 2 [concat $option $args] + + switch -- $option { + "error" { + foreach {chan msg} $args break + + log 0 "TLS/$chan: error: $msg" + } + "verify" { + # poor man's lassign + foreach {chan depth cert rc err} $args break + + array set c $cert + + if {$rc != "1"} { + log 1 "TLS/$chan: verify/$depth: Bad Cert: $err (rc = $rc)" + } else { + log 2 "TLS/$chan: verify/$depth: $c(subject)" + } + if {$debug > 0} { + return 1; # FORCE OK + } else { + return $rc + } + } + "info" { + # poor man's lassign + foreach {chan major minor state msg} $args break + + if {$msg != ""} { + append state ": $msg" + } + # For tracing + upvar #0 tls::$chan cb + set cb($major) $minor + + log 2 "TLS/$chan: $major/$minor: $state" + } + default { + return -code error "bad option \"$option\":\ + must be one of error, info, or verify" + } + } +} + +proc tls::xhandshake {chan} { + upvar #0 tls::$chan cb + + if {[info exists cb(handshake)] && \ + $cb(handshake) == "done"} { + return 1 + } + while {1} { + vwait tls::${chan}(handshake) + if {![info exists cb(handshake)]} { + return 0 + } + if {$cb(handshake) == "done"} { + return 1 + } + } +} + +proc tls::password {} { + log 0 "TLS/Password: did you forget to set your passwd!" + # Return the worlds best kept secret password. + return "secret" +} + +proc tls::log {level msg} { + variable debug + variable logcmd + + if {$level > $debug || $logcmd == ""} { + return + } + set cmd $logcmd + lappend cmd $msg + uplevel #0 $cmd +} + diff --git a/src/vfs/punk9linux.vfs/lib_tcl9/tdom/libtcl9tdom0.9.6.so b/src/vfs/punk9linux.vfs/lib_tcl9/tdom/libtcl9tdom0.9.6.so new file mode 100644 index 00000000..05c453e9 Binary files /dev/null and b/src/vfs/punk9linux.vfs/lib_tcl9/tdom/libtcl9tdom0.9.6.so differ diff --git a/src/vfs/punk9linux.vfs/lib_tcl9/tdom/libtdomstub.a b/src/vfs/punk9linux.vfs/lib_tcl9/tdom/libtdomstub.a new file mode 100644 index 00000000..d218420c Binary files /dev/null and b/src/vfs/punk9linux.vfs/lib_tcl9/tdom/libtdomstub.a differ diff --git a/src/vfs/punk9linux.vfs/lib_tcl9/tdom/pkgIndex.tcl b/src/vfs/punk9linux.vfs/lib_tcl9/tdom/pkgIndex.tcl new file mode 100644 index 00000000..73b864af --- /dev/null +++ b/src/vfs/punk9linux.vfs/lib_tcl9/tdom/pkgIndex.tcl @@ -0,0 +1,12 @@ +# +# Tcl package index file +# +if {[package vsatisfies [package provide Tcl] 9.0-]} { + package ifneeded tdom 0.9.6 \ + "[list load [file join $dir libtcl9tdom0.9.6.so]]; + [list source [file join $dir tdom.tcl]]" +} else { + package ifneeded tdom 0.9.6 \ + "[list load [file join $dir libtdom0.9.6.so]]; + [list source [file join $dir tdom.tcl]]" +} diff --git a/src/vfs/punk9linux.vfs/lib_tcl9/tdom/tdom.tcl b/src/vfs/punk9linux.vfs/lib_tcl9/tdom/tdom.tcl new file mode 100644 index 00000000..3e815932 --- /dev/null +++ b/src/vfs/punk9linux.vfs/lib_tcl9/tdom/tdom.tcl @@ -0,0 +1,1101 @@ +#---------------------------------------------------------------------------- +# Copyright (c) 1999 Jochen Loewer (loewerj@hotmail.com) +#---------------------------------------------------------------------------- +# +# $Id$ +# +# +# The higher level functions of tDOM written in plain Tcl. +# +# +# The contents of this file are subject to the Mozilla Public License +# Version 2.0 (the "License"); you may not use this file except in +# compliance with the License. You may obtain a copy of the License at +# http://www.mozilla.org/MPL/ +# +# Software distributed under the License is distributed on an "AS IS" +# basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the +# License for the specific language governing rights and limitations +# under the License. +# +# The Original Code is tDOM. +# +# The Initial Developer of the Original Code is Jochen Loewer +# Portions created by Jochen Loewer are Copyright (C) 1998, 1999 +# Jochen Loewer. All Rights Reserved. +# +# Contributor(s): +# Rolf Ade (rolf@pointsman.de): 'fake' nodelists/live childNodes +# +# written by Jochen Loewer +# April, 1999 +# +#---------------------------------------------------------------------------- + +package require tdom + +#---------------------------------------------------------------------------- +# setup namespaces for additional Tcl level methods, etc. +# +#---------------------------------------------------------------------------- +namespace eval ::dom { + namespace eval domDoc { + } + namespace eval domNode { + } + namespace eval DOMImplementation { + } + namespace eval xpathFunc { + } + namespace eval xpathFuncHelper { + } +} + +namespace eval ::tdom { + variable extRefHandlerDebug 0 + variable useForeignDTD "" + variable utf8bom 0 + + namespace export xmlOpenFile xmlReadFile xmlReadFileForSimple \ + extRefHandler baseURL +} + +#---------------------------------------------------------------------------- +# hasFeature (DOMImplementation method) +# +# +# @in url the URL, where to get the XML document +# +# @return document object +# @exception XML parse errors, ... +# +#---------------------------------------------------------------------------- +proc ::dom::DOMImplementation::hasFeature { dom feature {version ""} } { + + switch $feature { + xml - + XML { + if {($version == "") || ($version == "1.0")} { + return 1 + } + } + } + return 0 + +} + +#---------------------------------------------------------------------------- +# load (DOMImplementation method) +# +# requests a XML document via http using the given URL and +# builds up a DOM tree in memory returning the document object +# +# +# @in url the URL, where to get the XML document +# +# @return document object +# @exception XML parse errors, ... +# +#---------------------------------------------------------------------------- +proc ::dom::DOMImplementation::load { dom url } { + + error "Sorry, load method not implemented yet!" + +} + +#---------------------------------------------------------------------------- +# isa (docDoc method, for [incr tcl] compatibility) +# +# +# @in className +# +# @return 1 iff inherits from the given class +# +#---------------------------------------------------------------------------- +proc ::dom::domDoc::isa { doc className } { + + if {$className == "domDoc"} { + return 1 + } + return 0 +} + +#---------------------------------------------------------------------------- +# info (domDoc method, for [incr tcl] compatibility) +# +# +# @in subcommand +# @in args +# +#---------------------------------------------------------------------------- +proc ::dom::domDoc::info { doc subcommand args } { + + switch $subcommand { + class { + return "domDoc" + } + inherit { + return "" + } + heritage { + return "domDoc {}" + } + default { + error "domDoc::info subcommand $subcommand not yet implemented!" + } + } +} + +#---------------------------------------------------------------------------- +# importNode (domDoc method) +# +# Document Object Model (Core) Level 2 method +# +# +# @in subcommand +# @in args +# +#---------------------------------------------------------------------------- +proc ::dom::domDoc::importNode { doc importedNode deep } { + + if {$deep || ($deep == "-deep")} { + set node [$importedNode cloneNode -deep] + } else { + set node [$importedNode cloneNode] + } + return $node +} + +#---------------------------------------------------------------------------- +# isa (domNode method, for [incr tcl] compatibility) +# +# +# @in className +# +# @return 1 iff inherits from the given class +# +#---------------------------------------------------------------------------- +proc ::dom::domNode::isa { doc className } { + + if {$className == "domNode"} { + return 1 + } + return 0 +} + +#---------------------------------------------------------------------------- +# info (domNode method, for [incr tcl] compatibility) +# +# +# @in subcommand +# @in args +# +#---------------------------------------------------------------------------- +proc ::dom::domNode::info { doc subcommand args } { + + switch $subcommand { + class { + return "domNode" + } + inherit { + return "" + } + heritage { + return "domNode {}" + } + default { + error "domNode::info subcommand $subcommand not yet implemented!" + } + } +} + +#---------------------------------------------------------------------------- +# isWithin (domNode method) +# +# tests, whether a node object is nested below another tag +# +# +# @in tagName the nodeName of an elment node +# +# @return 1 iff node is nested below a element with nodeName tagName +# 0 otherwise +# +#---------------------------------------------------------------------------- +proc ::dom::domNode::isWithin { node tagName } { + + while {[$node parentNode] != ""} { + set node [$node parentNode] + if {[$node nodeName] == $tagName} { + return 1 + } + } + return 0 +} + +#---------------------------------------------------------------------------- +# tagName (domNode method) +# +# same a nodeName for element interface +# +#---------------------------------------------------------------------------- +proc ::dom::domNode::tagName { node } { + + if {[$node nodeType] == "ELEMENT_NODE"} { + return [$node nodeName] + } + return -code error "NOT_SUPPORTED_ERR not an element!" +} + +#---------------------------------------------------------------------------- +# simpleTranslate (domNode method) +# +# applies simple translation rules similar to Cost's simple +# translations to a node +# +# +# @in output_var +# @in trans_specs +# +#---------------------------------------------------------------------------- +proc ::dom::domNode::simpleTranslate { node output_var trans_specs } { + + upvar $output_var output + + if {[$node nodeType] == "TEXT_NODE"} { + append output [cgiQuote [$node nodeValue]] + return + } + set found 0 + + foreach {match action} $trans_specs { + + if {[catch { + if {!$found && ([$node selectNode self::$match] != "") } { + set found 1 + } + } err]} { + if {![string match "NodeSet expected for parent axis!" $err]} { + error $err + } + } + if {$found && ($action != "-")} { + set stop 0 + foreach {type value} $action { + switch $type { + prefix { append output [subst $value] } + tag { append output <$value> } + start { append output [eval $value] } + stop { set stop 1 } + } + } + if {!$stop} { + foreach child [$node childNodes] { + simpleTranslate $child output $trans_specs + } + } + foreach {type value} $action { + switch $type { + suffix { append output [subst $value] } + end { append output [eval $value] } + tag { append output } + } + } + return + } + } + foreach child [$node childNodes] { + simpleTranslate $child output $trans_specs + } +} + +#---------------------------------------------------------------------------- +# a DOM conformant 'live' childNodes +# +# @return a 'nodelist' object (it is just the normal node) +# +#---------------------------------------------------------------------------- +proc ::dom::domNode::childNodesLive { node } { + + return $node +} + +#---------------------------------------------------------------------------- +# item method on a 'nodelist' object +# +# @return a 'nodelist' object (it is just a normal +# +#---------------------------------------------------------------------------- +proc ::dom::domNode::item { nodeListNode index } { + + return [lindex [$nodeListNode childNodes] $index] +} + +#---------------------------------------------------------------------------- +# length method on a 'nodelist' object +# +# @return a 'nodelist' object (it is just a normal +# +#---------------------------------------------------------------------------- +proc ::dom::domNode::length { nodeListNode } { + + return [llength [$nodeListNode childNodes]] +} + +#---------------------------------------------------------------------------- +# appendData on a 'CharacterData' object +# +#---------------------------------------------------------------------------- +proc ::dom::domNode::appendData { node arg } { + + set type [$node nodeType] + if {($type != "TEXT_NODE") && ($type != "CDATA_SECTION_NODE") && + ($type != "COMMENT_NODE") + } { + return -code error "NOT_SUPPORTED_ERR: node is not a cdata node" + } + set oldValue [$node nodeValue] + $node nodeValue [append oldValue $arg] +} + +#---------------------------------------------------------------------------- +# deleteData on a 'CharacterData' object +# +#---------------------------------------------------------------------------- +proc ::dom::domNode::deleteData { node offset count } { + + set type [$node nodeType] + if {($type != "TEXT_NODE") && ($type != "CDATA_SECTION_NODE") && + ($type != "COMMENT_NODE") + } { + return -code error "NOT_SUPPORTED_ERR: node is not a cdata node" + } + incr offset -1 + set before [string range [$node nodeValue] 0 $offset] + incr offset + incr offset $count + set after [string range [$node nodeValue] $offset end] + $node nodeValue [append before $after] +} + +#---------------------------------------------------------------------------- +# insertData on a 'CharacterData' object +# +#---------------------------------------------------------------------------- +proc ::dom::domNode::insertData { node offset arg } { + + set type [$node nodeType] + if {($type != "TEXT_NODE") && ($type != "CDATA_SECTION_NODE") && + ($type != "COMMENT_NODE") + } { + return -code error "NOT_SUPPORTED_ERR: node is not a cdata node" + } + incr offset -1 + set before [string range [$node nodeValue] 0 $offset] + incr offset + set after [string range [$node nodeValue] $offset end] + $node nodeValue [append before $arg $after] +} + +#---------------------------------------------------------------------------- +# replaceData on a 'CharacterData' object +# +#---------------------------------------------------------------------------- +proc ::dom::domNode::replaceData { node offset count arg } { + + set type [$node nodeType] + if {($type != "TEXT_NODE") && ($type != "CDATA_SECTION_NODE") && + ($type != "COMMENT_NODE") + } { + return -code error "NOT_SUPPORTED_ERR: node is not a cdata node" + } + incr offset -1 + set before [string range [$node nodeValue] 0 $offset] + incr offset + incr offset $count + set after [string range [$node nodeValue] $offset end] + $node nodeValue [append before $arg $after] +} + +#---------------------------------------------------------------------------- +# substringData on a 'CharacterData' object +# +# @return part of the node value (text) +# +#---------------------------------------------------------------------------- +proc ::dom::domNode::substringData { node offset count } { + + set type [$node nodeType] + if {($type != "TEXT_NODE") && ($type != "CDATA_SECTION_NODE") && + ($type != "COMMENT_NODE") + } { + return -code error "NOT_SUPPORTED_ERR: node is not a cdata node" + } + set endOffset {[expr $offset + $count - 1]} + return [string range [$node nodeValue] $offset $endOffset] +} + +#---------------------------------------------------------------------------- +# coerce2number +# +#---------------------------------------------------------------------------- +proc ::dom::xpathFuncHelper::coerce2number { type value } { + switch $type { + empty { return 0 } + number - + string { return $value } + attrvalues { return [lindex $value 0] } + nodes { return [[lindex $value 0] selectNodes number()] } + attrnodes { return [lindex $value 1] } + } +} + +#---------------------------------------------------------------------------- +# coerce2string +# +#---------------------------------------------------------------------------- +proc ::dom::xpathFuncHelper::coerce2string { type value } { + switch $type { + empty { return "" } + number - + string { return $value } + attrvalues { return [lindex $value 0] } + nodes { return [[lindex $value 0] selectNodes string()] } + attrnodes { return [lindex $value 1] } + } +} + +#---------------------------------------------------------------------------- +# function-available +# +#---------------------------------------------------------------------------- +proc ::dom::xpathFunc::function-available { ctxNode pos + nodeListType nodeList args} { + + if {[llength $args] != 2} { + error "function-available(): wrong # of args!" + } + foreach { arg1Typ arg1Value } $args break + set str [::dom::xpathFuncHelper::coerce2string $arg1Typ $arg1Value ] + switch $str { + boolean - + ceiling - + concat - + contains - + count - + current - + document - + element-available - + false - + floor - + format-number - + generate-id - + id - + key - + last - + lang - + local-name - + name - + namespace-uri - + normalize-space - + not - + number - + position - + round - + starts-with - + string - + string-length - + substring - + substring-after - + substring-before - + sum - + translate - + true - + unparsed-entity-uri { + return [list bool true] + } + default { + set TclXpathFuncs [info procs ::dom::xpathFunc::*] + if {[lsearch -exact $TclXpathFuncs $str] != -1} { + return [list bool true] + } else { + return [list bool false] + } + } + } +} + +#---------------------------------------------------------------------------- +# element-available +# +# This is not strictly correct. The XSLT namespace may be bound +# to another prefix (and the prefix 'xsl' may be bound to another +# namespace). Since the expression context isn't available at the +# moment at tcl coded XPath functions, this couldn't be done better +# than this "works in the 'normal' cases" version. +#---------------------------------------------------------------------------- +proc ::dom::xpathFunc::element-available { ctxNode pos + nodeListType nodeList args} { + + if {[llength $args] != 2} { + error "element-available(): wrong # of args!" + } + foreach { arg1Typ arg1Value } $args break + set str [::dom::xpathFuncHelper::coerce2string $arg1Typ $arg1Value ] + # The XSLT recommendation says: "The element-available + # function returns true if and only if the expanded-name + # is the name of an instruction." The following xsl + # elements are not in the category instruction. + # xsl:attribute-set + # xsl:decimal-format + # xsl:include + # xsl:key + # xsl:namespace-alias + # xsl:output + # xsl:param + # xsl:strip-space + # xsl:preserve-space + # xsl:template + # xsl:import + # xsl:otherwise + # xsl:sort + # xsl:stylesheet + # xsl:transform + # xsl:with-param + # xsl:when + switch $str { + xsl:apply-templates - + xsl:apply-imports - + xsl:call-template - + xsl:element - + xsl:attribute - + xsl:text - + xsl:processing-instruction - + xsl:comment - + xsl:copy - + xsl:value-of - + xsl:number - + xsl:for-each - + xsl:if - + xsl:choose - + xsl:variable - + xsl:copy-of - + xsl:message - + xsl:fallback { + return [list bool true] + } + default { + return [list bool false] + } + } +} + +#---------------------------------------------------------------------------- +# system-property +# +# This is not strictly correct. The XSLT namespace may be bound +# to another prefix (and the prefix 'xsl' may be bound to another +# namespace). Since the expression context isn't available at the +# moment at tcl coded XPath functions, this couldn't be done better +# than this "works in the 'normal' cases" version. +#---------------------------------------------------------------------------- +proc ::dom::xpathFunc::system-property { ctxNode pos + nodeListType nodeList args } { + + if {[llength $args] != 2} { + error "system-property(): wrong # of args!" + } + foreach { arg1Typ arg1Value } $args break + set str [::dom::xpathFuncHelper::coerce2string $arg1Typ $arg1Value ] + switch $str { + xsl:version { + return [list number 1.0] + } + xsl:vendor { + return [list string "Jochen Loewer (loewerj@hotmail.com), Rolf Ade (rolf@pointsman.de) et. al."] + } + xsl:vendor-url { + return [list string "http://www.tdom.org"] + } + default { + return [list string ""] + } + } +} + +#---------------------------------------------------------------------------- +# IANAEncoding2TclEncoding +# +#---------------------------------------------------------------------------- + +# As of version 8.3.4 tcl supports +# cp860 cp861 cp862 cp863 tis-620 cp864 cp865 cp866 gb12345 cp949 +# cp950 cp869 dingbats ksc5601 macCentEuro cp874 macUkraine jis0201 +# gb2312 euc-cn euc-jp iso8859-10 macThai jis0208 iso2022-jp +# macIceland iso2022 iso8859-13 iso8859-14 jis0212 iso8859-15 cp737 +# iso8859-16 big5 euc-kr macRomania macTurkish gb1988 iso2022-kr +# macGreek ascii cp437 macRoman iso8859-1 iso8859-2 iso8859-3 ebcdic +# macCroatian koi8-r iso8859-4 iso8859-5 cp1250 macCyrillic iso8859-6 +# cp1251 koi8-u macDingbats iso8859-7 cp1252 iso8859-8 cp1253 +# iso8859-9 cp1254 cp1255 cp850 cp1256 cp932 identity cp1257 cp852 +# macJapan cp1258 shiftjis utf-8 cp855 cp936 symbol cp775 unicode +# cp857 +# +# Just add more mappings (and mail them to the tDOM mailing list, please). + +proc ::tdom::IANAEncoding2TclEncoding {IANAName} { + + # First the most widespread encodings with there + # preferred MIME name, to speed lookup in this + # usual cases. Later the official names and the + # aliases. + # + # For "official names for character sets that may be + # used in the Internet" see + # http://www.iana.org/assignments/character-sets + # (that's the source for the encoding names below) + # + # Matching is case-insensitive + + switch [string tolower $IANAName] { + "us-ascii" {return ascii} + "utf-8" {return utf-8} + "utf-16" {return unicode} + "iso-8859-1" {return iso8859-1} + "iso-8859-2" {return iso8859-2} + "iso-8859-3" {return iso8859-3} + "iso-8859-4" {return iso8859-4} + "iso-8859-5" {return iso8859-5} + "iso-8859-6" {return iso8859-6} + "iso-8859-7" {return iso8859-7} + "iso-8859-8" {return iso8859-8} + "iso-8859-9" {return iso8859-9} + "iso-8859-10" {return iso8859-10} + "iso-8859-13" {return iso8859-13} + "iso-8859-14" {return iso8859-14} + "iso-8859-15" {return iso8859-15} + "iso-8859-16" {return iso8859-16} + "iso-2022-kr" {return iso2022-kr} + "euc-kr" {return euc-kr} + "iso-2022-jp" {return iso2022-jp} + "koi8-r" {return koi8-r} + "shift_jis" {return shiftjis} + "euc-jp" {return euc-jp} + "gb2312" {return gb2312} + "big5" {return big5} + "cp866" {return cp866} + "cp1250" {return cp1250} + "cp1253" {return cp1253} + "cp1254" {return cp1254} + "cp1255" {return cp1255} + "cp1256" {return cp1256} + "cp1257" {return cp1257} + + "windows-1251" - + "cp1251" {return cp1251} + + "windows-1252" - + "cp1252" {return cp1252} + + "iso_8859-1:1987" - + "iso-ir-100" - + "iso_8859-1" - + "latin1" - + "l1" - + "ibm819" - + "cp819" - + "csisolatin1" {return iso8859-1} + + "iso_8859-2:1987" - + "iso-ir-101" - + "iso_8859-2" - + "iso-8859-2" - + "latin2" - + "l2" - + "csisolatin2" {return iso8859-2} + + "iso_8859-5:1988" - + "iso-ir-144" - + "iso_8859-5" - + "iso-8859-5" - + "cyrillic" - + "csisolatincyrillic" {return iso8859-5} + + "ms_kanji" - + "csshiftjis" {return shiftjis} + + "csiso2022kr" {return iso2022-kr} + + "ibm866" - + "csibm866" {return cp866} + + default { + # There are much more encoding names out there + # It's only laziness, that let me stop here. + error "Unrecognized encoding name '$IANAName'" + } + } +} + +#---------------------------------------------------------------------------- +# xmlOpenFileWorker +# +#---------------------------------------------------------------------------- +proc ::tdom::xmlOpenFileWorker {filename {encodingString {}} {forSimple 0} {forRead 0}} { + variable utf8bom + + # This partly (mis-)use the encoding of a channel handed to [dom + # parse -channel ..] as a marker: if the channel encoding is utf-8 + # then behind the scene Tcl_Read() is used, otherwise + # Tcl_ReadChars(). This is used for the encodings understood (and + # checked) by the used expat implementation: utf-8 and utf-16 (in + # either byte order). + # + # The -translation auto used used in the fconfigure commands which + # set the encoding isn't strictly necessary in case the parser is + # expat (because it handles that internally) but it is the right + # thing for the simple parser. + + set fd [open $filename] + + if {$encodingString != {}} { + upvar $encodingString encString + } + + # The autodetection of the encoding follows + # XML Recomendation, Appendix F + + fconfigure $fd -translation binary + if {![binary scan [read $fd 4] "H8" firstBytes]} { + # very short (< 4 Bytes) file, that means not a well-formed + # XML at all (the shortes possible would be <[a-zA-Z]/>). + # Don't report that here but let the parser do that. + seek $fd 0 start + set encString UTF-8 + return $fd + } + + # First check for BOM + switch [string range $firstBytes 0 3] { + "feff" { + # feff: UTF-16, big-endian BOM + if {$forSimple || $forRead} { + if {[package vsatisfies [package provide Tcl] 9-]} { + seek $fd 2 start + fconfigure $fd -encoding utf-16be -translation auto + } else { + error "UTF-16be is not supported" + } + } else { + seek $fd 0 start + set encString UTF-16be + fconfigure $fd -encoding utf-8 -translation auto + } + return $fd + } + "fffe" { + # ffef: UTF-16, little-endian BOM + set encString UTF-16le + if {$forSimple || $forRead} { + seek $fd 2 start + if {[package vsatisfies [package provide Tcl] 9-]} { + fconfigure $fd -encoding utf-16le -translation auto + } else { + fconfigure $fd -encoding unicode -translation auto + } + } else { + seek $fd 0 start + fconfigure $fd -encoding utf-8 -translation auto + } + return $fd + } + } + + if {$utf8bom} { + # According to the Unicode standard + # (http://www.unicode.org/versions/Unicode5.0.0/ch02.pdf) the + # "[u]se of a BOM is neither required nor recommended for + # UTF-8". Nevertheless such files exits. If the programmer + # explcitely enables this by setting ::tdom::utf8bom to true + # this is handled here. + if {[string range $firstBytes 0 5] eq "efbbbf"} { + set encString UTF-8 + seek $fd 3 start + fconfigure $fd -encoding utf-8 -translation auto + return $fd + } + } + + # If the entity has a XML Declaration, the first four characters + # must be "" $head] + if {$closeIndex == -1} { + error "Weird XML data or not XML data at all" + } + + seek $fd 0 start + set xmlDeclaration [read $fd [expr {$closeIndex + 5}]] + # extract the encoding information + set pattern {^[^>]+encoding=[\x20\x9\xd\xa]*["']([^ "']+)['"]} + # emacs: " + if {![regexp $pattern $head - encStr]} { + # Probably something like . + # Without encoding declaration this must be UTF-8 + set encoding utf-8 + set encString UTF-8 + } else { + set encoding [IANAEncoding2TclEncoding $encStr] + set encString $encStr + } + } + "0000003c" - + "0000003c" - + "3c000000" - + "00003c00" { + # UCS-4 + error "UCS-4 not supported" + } + "003c003f" { + # UTF-16, big-endian, no BOM + if {$forSimple || $forRead} { + if {[package vsatisfies [package provide Tcl] 9-]} { + set encoding utf-16be + } else { + error "UTF-16be is not supported by the simple parser" + } + } else { + set encoding utf-8 + } + seek $fd 0 start + set encString UTF-16be + } + "3c003f00" { + # UTF-16, little-endian, no BOM + if {$forSimple || $forRead} { + if {[package vsatisfies [package provide Tcl] 9-]} { + set encoding utf-16le + } else { + set encoding unicode + } + } else { + set encoding utf-8 + } + seek $fd 0 start + set encString UTF-16le + } + "4c6fa794" { + # EBCDIC in some flavor + if {[package vsatisfies [package provide Tcl] 9-]} { + seek $fd 0 start + set encoding ebcdic + } else { + error "EBCDIC not supported" + } + } + default { + # UTF-8 without an encoding declaration + seek $fd 0 start + set encoding utf-8 + set encString "UTF-8" + } + } + fconfigure $fd -encoding $encoding -translation auto + return $fd +} + +#---------------------------------------------------------------------------- +# xmlOpenFile +# +#---------------------------------------------------------------------------- +proc ::tdom::xmlOpenFile {filename {encodingString {}}} { + + if {$encodingString != {}} { + upvar $encodingString encString + } + + set fd [xmlOpenFileWorker $filename encString] + return $fd +} + +#---------------------------------------------------------------------------- +# xmlReadFile +# +#---------------------------------------------------------------------------- +proc ::tdom::xmlReadFile {filename {encodingString {}}} { + + if {$encodingString != {}} { + upvar $encodingString encString + } + + set fd [xmlOpenFileWorker $filename encString 0 1] + set data [read $fd [file size $filename]] + close $fd + return $data +} + +#---------------------------------------------------------------------------- +# xmlReadFileForSimple +# +#---------------------------------------------------------------------------- +proc ::tdom::xmlReadFileForSimple {filename {encodingString {}}} { + + if {$encodingString != {}} { + upvar $encodingString encString + } + + set fd [xmlOpenFileWorker $filename encString 1] + set data [read $fd [file size $filename]] + close $fd + return $data +} + +#---------------------------------------------------------------------------- +# extRefHandler +# +# A very simple external entity resolver, included for convenience. +# Depends on the tcllib package uri and resolves only file URLs. +# +#---------------------------------------------------------------------------- + +if {![catch {package require uri}]} { + proc ::tdom::extRefHandler {base systemId publicId} { + variable extRefHandlerDebug + variable useForeignDTD + + if {$extRefHandlerDebug} { + puts stderr "::tdom::extRefHandler called with:" + puts stderr "\tbase: '$base'" + puts stderr "\tsystemId: '$systemId'" + puts stderr "\tpublicId: '$publicId'" + } + if {$systemId == ""} { + if {$useForeignDTD != ""} { + set systemId $useForeignDTD + } else { + error "::tdom::useForeignDTD does\ + not point to the foreign DTD" + } + } + set absolutURI [uri::resolve $base $systemId] + array set uriData [uri::split $absolutURI] + switch $uriData(scheme) { + file { + if {$::tcl_platform(platform) eq "windows"} { + # Strip leading / for drive based paths + if {[string match /?:* $uriData(path)]} { + set uriData(path) [string range $uriData(path) 1 end] + } + } + # FIXME - path should be URL-decoded + return [list string $absolutURI [xmlReadFile $uriData(path)]] + } + default { + error "can only handle file URI's" + } + } + } +} + +#---------------------------------------------------------------------------- +# baseURL +# +# A simple convenience proc which returns an absolute URL for a given +# filename. +# +#---------------------------------------------------------------------------- +proc ::tdom::baseURL {path} { + # FIXME - path components need to be URL-encoded + + # Note [file join] will return path as is if it is already absolute. + # Also on Windows, it will change \ -> /. This is necessary because + # file URIs must always use /, never \. + set path [file join [pwd] $path] + + if {$::tcl_platform(platform) ne "windows"} { + return "file://$path" + } else { + if {[string match //* $path]} { + # UNC path + return "file:$path" + } else { + # Drive based path + return "file:///$path" + } + } +} + +namespace eval ::tdom::json { + namespace export asDict +} + +# The argument node may be an element node as well as a document node. +proc ::tdom::json::asDict {node} { + return [nodesAsDict [$node childNodes] [$node jsonType]] +} + +proc ::tdom::json::nodesAsDict {nodes parentType} { + set result "" + foreach n $nodes { + set children [$n childNodes] + set jsonType [$n jsonType] + set childrendValue [nodesAsDict $children $jsonType] + + switch $jsonType { + OBJECT { + if {[$n nodeName] ne "objectcontainer" || $parentType eq "OBJECT"} { + lappend result [$n nodeName] + } + lappend result $childrendValue + } + NONE { + lappend result [$n nodeName] $childrendValue + } + ARRAY { + if {[$n nodeName] ne "arraycontainer" || $parentType eq "OBJECT"} { + lappend result [$n nodeName] + } + lappend result $childrendValue + } + default { + set op [expr {[llength $nodes] > 1 ? "lappend" : "set"} ] + $op result [$n nodeValue] + } + } + } + return $result +} + +namespace eval ::tDOM { + variable extRefHandlerDebug 0 + variable useForeignDTD "" + + namespace export xmlOpenFile xmlReadFile xmlReadFileForSimple \ + extRefHandler baseURL +} + +foreach ::tdom::cmd { + xmlOpenFile + xmlReadFile + xmlReadFileForSimple + extRefHandler + baseURL + IANAEncoding2TclEncoding +} { + interp alias {} ::tDOM::$::tdom::cmd {} ::tdom::$::tdom::cmd +} + +# EOF diff --git a/src/vfs/punk9linux.vfs/lib_tcl9/thread3.0.2/libtcl9thread3.0.2.so b/src/vfs/punk9linux.vfs/lib_tcl9/thread3.0.2/libtcl9thread3.0.2.so new file mode 100644 index 00000000..942beddf Binary files /dev/null and b/src/vfs/punk9linux.vfs/lib_tcl9/thread3.0.2/libtcl9thread3.0.2.so differ diff --git a/src/vfs/punk9linux.vfs/lib_tcl9/thread3.0.2/pkgIndex.tcl b/src/vfs/punk9linux.vfs/lib_tcl9/thread3.0.2/pkgIndex.tcl new file mode 100644 index 00000000..a6a7a228 --- /dev/null +++ b/src/vfs/punk9linux.vfs/lib_tcl9/thread3.0.2/pkgIndex.tcl @@ -0,0 +1,55 @@ +# -*- tcl -*- +# Tcl package index file, version 1.1 +# + +# Tcl 8.7 interps are only supported on 32-bit platforms. +# Lower than that is never supported. Bye! +if {![package vsatisfies [package provide Tcl] 9.0] + && ((![package vsatisfies [package provide Tcl] 8.7]) + || ($::tcl_platform(pointerSize)!=4))} { + return +} + +# All Tcl 8.7+ interps can [load] thread 3.0.2 +# +# For interps that are not thread-enabled, we still call [package ifneeded]. +# This is contrary to the usual convention, but is a good idea because we +# cannot imagine any other version of thread that might succeed in a +# thread-disabled interp. There's nothing to gain by yielding to other +# competing callers of [package ifneeded Thread]. On the other hand, +# deferring the error has the advantage that a script calling +# [package require Thread] in a thread-disabled interp gets an error message +# about a thread-disabled interp, instead of the message +# "can't find package thread". + +package ifneeded [string tolower thread] 3.0.2 \ + [list load [file join $dir libtcl9thread3.0.2.so] [string totitle thread]] +package ifneeded [string totitle thread] 3.0.2 \ + [list package require -exact [string tolower thread] 3.0.2] + +# package ttrace uses some support machinery. + +# In Tcl 8.7+ interps; use [::apply] + +package ifneeded ttrace 3.0.2 [list ::apply {{dir} { + if {[info exists ::env(TCL_THREAD_LIBRARY)] && + [file readable $::env(TCL_THREAD_LIBRARY)/ttrace.tcl]} { + source $::env(TCL_THREAD_LIBRARY)/ttrace.tcl + } elseif {[file readable [file join $dir .. lib ttrace.tcl]]} { + source [file join $dir .. lib ttrace.tcl] + } elseif {[file readable [file join $dir ttrace.tcl]]} { + source [file join $dir ttrace.tcl] + } elseif {[file exists //zipfs:/lib/thread/ttrace.tcl] || + ![catch {zipfs mount [file join $dir libtcl9thread3.0.2.so] //zipfs:/lib/thread}]} { + source //zipfs:/lib/thread/ttrace.tcl + } + if {[namespace which ::ttrace::update] ne ""} { + ::ttrace::update + } +}} $dir] +package ifneeded Ttrace 3.0.2 \ + [list package require -exact ttrace 3.0.2] + + + + diff --git a/src/vfs/punk9linux.vfs/lib_tcl9/thread3.0.2/thread3.0.2/libtcl9thread3.0.2.so b/src/vfs/punk9linux.vfs/lib_tcl9/thread3.0.2/thread3.0.2/libtcl9thread3.0.2.so new file mode 100644 index 00000000..942beddf Binary files /dev/null and b/src/vfs/punk9linux.vfs/lib_tcl9/thread3.0.2/thread3.0.2/libtcl9thread3.0.2.so differ diff --git a/src/vfs/punk9linux.vfs/lib_tcl9/thread3.0.2/thread3.0.2/pkgIndex.tcl b/src/vfs/punk9linux.vfs/lib_tcl9/thread3.0.2/thread3.0.2/pkgIndex.tcl new file mode 100644 index 00000000..a6a7a228 --- /dev/null +++ b/src/vfs/punk9linux.vfs/lib_tcl9/thread3.0.2/thread3.0.2/pkgIndex.tcl @@ -0,0 +1,55 @@ +# -*- tcl -*- +# Tcl package index file, version 1.1 +# + +# Tcl 8.7 interps are only supported on 32-bit platforms. +# Lower than that is never supported. Bye! +if {![package vsatisfies [package provide Tcl] 9.0] + && ((![package vsatisfies [package provide Tcl] 8.7]) + || ($::tcl_platform(pointerSize)!=4))} { + return +} + +# All Tcl 8.7+ interps can [load] thread 3.0.2 +# +# For interps that are not thread-enabled, we still call [package ifneeded]. +# This is contrary to the usual convention, but is a good idea because we +# cannot imagine any other version of thread that might succeed in a +# thread-disabled interp. There's nothing to gain by yielding to other +# competing callers of [package ifneeded Thread]. On the other hand, +# deferring the error has the advantage that a script calling +# [package require Thread] in a thread-disabled interp gets an error message +# about a thread-disabled interp, instead of the message +# "can't find package thread". + +package ifneeded [string tolower thread] 3.0.2 \ + [list load [file join $dir libtcl9thread3.0.2.so] [string totitle thread]] +package ifneeded [string totitle thread] 3.0.2 \ + [list package require -exact [string tolower thread] 3.0.2] + +# package ttrace uses some support machinery. + +# In Tcl 8.7+ interps; use [::apply] + +package ifneeded ttrace 3.0.2 [list ::apply {{dir} { + if {[info exists ::env(TCL_THREAD_LIBRARY)] && + [file readable $::env(TCL_THREAD_LIBRARY)/ttrace.tcl]} { + source $::env(TCL_THREAD_LIBRARY)/ttrace.tcl + } elseif {[file readable [file join $dir .. lib ttrace.tcl]]} { + source [file join $dir .. lib ttrace.tcl] + } elseif {[file readable [file join $dir ttrace.tcl]]} { + source [file join $dir ttrace.tcl] + } elseif {[file exists //zipfs:/lib/thread/ttrace.tcl] || + ![catch {zipfs mount [file join $dir libtcl9thread3.0.2.so] //zipfs:/lib/thread}]} { + source //zipfs:/lib/thread/ttrace.tcl + } + if {[namespace which ::ttrace::update] ne ""} { + ::ttrace::update + } +}} $dir] +package ifneeded Ttrace 3.0.2 \ + [list package require -exact ttrace 3.0.2] + + + + diff --git a/src/vfs/punk9linux.vfs/modules_tcl9/Thread-3.0b1.tm b/src/vfs/punk9linux.vfs/modules_tcl9/Thread-3.0b1.tm deleted file mode 100644 index 71484d78..00000000 Binary files a/src/vfs/punk9linux.vfs/modules_tcl9/Thread-3.0b1.tm and /dev/null differ diff --git a/src/vfs/punk9linux.vfs/modules_tcl9/Thread/platform/linux_x86_64_tcl9-3.0b1.tm b/src/vfs/punk9linux.vfs/modules_tcl9/Thread/platform/linux_x86_64_tcl9-3.0b1.tm deleted file mode 100644 index 05c4ca44..00000000 Binary files a/src/vfs/punk9linux.vfs/modules_tcl9/Thread/platform/linux_x86_64_tcl9-3.0b1.tm and /dev/null differ diff --git a/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/tcltls1.7.23/pkgIndex.tcl b/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/tcltls1.7.23/pkgIndex.tcl new file mode 100644 index 00000000..bd922120 --- /dev/null +++ b/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/tcltls1.7.23/pkgIndex.tcl @@ -0,0 +1,16 @@ +if {[package vsatisfies [package present Tcl] 8.5-]} { + package ifneeded tls 1.7.23 [list apply {{dir} { + if {{shared} eq "static"} { + load {} Tls + } else { + load [file join $dir tcltls.dll] Tls + } + + set tlsTclInitScript [file join $dir tls.tcl] + if {[file exists $tlsTclInitScript]} { + source $tlsTclInitScript + } + }} $dir] +} elseif {[package vsatisfies [package present Tcl] 8.4]} { + package ifneeded tls 1.7.23 [list load [file join $dir tcltls.dll] Tls] +} diff --git a/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/tcltls1.7.23/tcltls.dll b/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/tcltls1.7.23/tcltls.dll new file mode 100644 index 00000000..69ba6042 Binary files /dev/null and b/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/tcltls1.7.23/tcltls.dll differ diff --git a/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/tcltls1.7.23/tls.tcl b/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/tcltls1.7.23/tls.tcl new file mode 100644 index 00000000..e8a4ede6 --- /dev/null +++ b/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/tcltls1.7.23/tls.tcl @@ -0,0 +1,398 @@ +# +# Copyright (C) 1997-2000 Matt Newman +# +namespace eval tls { + variable logcmd tclLog + variable debug 0 + + # Default flags passed to tls::import + variable defaults {} + + # Maps UID to Server Socket + variable srvmap + variable srvuid 0 + + # Over-ride this if you are using a different socket command + variable socketCmd + if {![info exists socketCmd]} { + set socketCmd [info command ::socket] + } + + # This is the possible arguments to tls::socket and tls::init + # The format of this is a list of lists + ## Each inner list contains the following elements + ### Server (matched against "string match" for 0/1) + ### Option name + ### Variable to add the option to: + #### sopts: [socket] option + #### iopts: [tls::import] option + ### How many arguments the following the option to consume + variable socketOptionRules { + {0 -async sopts 0} + {* -myaddr sopts 1} + {0 -myport sopts 1} + {* -type sopts 1} + {* -cadir iopts 1} + {* -cafile iopts 1} + {* -cert iopts 1} + {* -certfile iopts 1} + {* -cipher iopts 1} + {* -command iopts 1} + {* -dhparams iopts 1} + {* -key iopts 1} + {* -keyfile iopts 1} + {* -password iopts 1} + {* -request iopts 1} + {* -require iopts 1} + {* -autoservername discardOpts 1} + {* -servername iopts 1} + {* -ssl2 iopts 1} + {* -ssl3 iopts 1} + {* -tls1 iopts 1} + {* -tls1.1 iopts 1} + {* -tls1.2 iopts 1} + {* -tls1.3 iopts 1} + } + + # tls::socket and tls::init options as a humane readable string + variable socketOptionsNoServer + variable socketOptionsServer + + # Internal [switch] body to validate options + variable socketOptionsSwitchBody +} + +proc tls::_initsocketoptions {} { + variable socketOptionRules + variable socketOptionsNoServer + variable socketOptionsServer + variable socketOptionsSwitchBody + + # Do not re-run if we have already been initialized + if {[info exists socketOptionsSwitchBody]} { + return + } + + # Create several structures from our list of options + ## 1. options: a text representation of the valid options for the current + ## server type + ## 2. argSwitchBody: Switch body for processing arguments + set options(0) [list] + set options(1) [list] + set argSwitchBody [list] + foreach optionRule $socketOptionRules { + set ruleServer [lindex $optionRule 0] + set ruleOption [lindex $optionRule 1] + set ruleVarToUpdate [lindex $optionRule 2] + set ruleVarArgsToConsume [lindex $optionRule 3] + + foreach server [list 0 1] { + if {![string match $ruleServer $server]} { + continue + } + + lappend options($server) $ruleOption + } + + switch -- $ruleVarArgsToConsume { + 0 { + set argToExecute { + lappend @VAR@ $arg + set argsArray($arg) true + } + } + 1 { + set argToExecute { + incr idx + if {$idx >= [llength $args]} { + return -code error "\"$arg\" option must be followed by value" + } + set argValue [lindex $args $idx] + lappend @VAR@ $arg $argValue + set argsArray($arg) $argValue + } + } + default { + return -code error "Internal argument construction error" + } + } + + lappend argSwitchBody $ruleServer,$ruleOption [string map [list @VAR@ $ruleVarToUpdate] $argToExecute] + } + + # Add in the final options + lappend argSwitchBody {*,-*} {return -code error "bad option \"$arg\": must be one of $options"} + lappend argSwitchBody default break + + # Set the final variables + set socketOptionsNoServer [join $options(0) {, }] + set socketOptionsServer [join $options(1) {, }] + set socketOptionsSwitchBody $argSwitchBody +} + +proc tls::initlib {dir dll} { + # Package index cd's into the package directory for loading. + # Irrelevant to unixoids, but for Windows this enables the OS to find + # the dependent DLL's in the CWD, where they may be. + set cwd [pwd] + catch {cd $dir} + if {[string equal $::tcl_platform(platform) "windows"] && + ![string equal [lindex [file system $dir] 0] "native"]} { + # If it is a wrapped executable running on windows, the openssl + # dlls must be copied out of the virtual filesystem to the disk + # where Windows will find them when resolving the dependency in + # the tls dll. We choose to make them siblings of the executable. + package require starkit + set dst [file nativename [file dirname $starkit::topdir]] + foreach sdll [glob -nocomplain -directory $dir -tails *eay32.dll] { + catch {file delete -force $dst/$sdll} + catch {file copy -force $dir/$sdll $dst/$sdll} + } + } + set res [catch {uplevel #0 [list load [file join [pwd] $dll]]} err] + catch {cd $cwd} + if {$res} { + namespace eval [namespace parent] {namespace delete tls} + return -code $res $err + } + rename tls::initlib {} +} + + +# +# Backwards compatibility, also used to set the default +# context options +# +proc tls::init {args} { + variable defaults + variable socketOptionsNoServer + variable socketOptionsServer + variable socketOptionsSwitchBody + + tls::_initsocketoptions + + # Technically a third option should be used here: Options that are valid + # only a both servers and non-servers + set server -1 + set options $socketOptionsServer + + # Validate arguments passed + set initialArgs $args + set argc [llength $args] + + array set argsArray [list] + for {set idx 0} {$idx < $argc} {incr idx} { + set arg [lindex $args $idx] + switch -glob -- $server,$arg $socketOptionsSwitchBody + } + + set defaults $initialArgs +} +# +# Helper function - behaves exactly as the native socket command. +# +proc tls::socket {args} { + variable socketCmd + variable defaults + variable socketOptionsNoServer + variable socketOptionsServer + variable socketOptionsSwitchBody + + tls::_initsocketoptions + + set idx [lsearch $args -server] + if {$idx != -1} { + set server 1 + set callback [lindex $args [expr {$idx+1}]] + set args [lreplace $args $idx [expr {$idx+1}]] + + set usage "wrong # args: should be \"tls::socket -server command ?options? port\"" + set options $socketOptionsServer + } else { + set server 0 + + set usage "wrong # args: should be \"tls::socket ?options? host port\"" + set options $socketOptionsNoServer + } + + # Combine defaults with current options + set args [concat $defaults $args] + + set argc [llength $args] + set sopts {} + set iopts [list -server $server] + + array set argsArray [list] + for {set idx 0} {$idx < $argc} {incr idx} { + set arg [lindex $args $idx] + switch -glob -- $server,$arg $socketOptionsSwitchBody + } + + if {$server} { + if {($idx + 1) != $argc} { + return -code error $usage + } + set uid [incr ::tls::srvuid] + + set port [lindex $args [expr {$argc-1}]] + lappend sopts $port + #set sopts [linsert $sopts 0 -server $callback] + set sopts [linsert $sopts 0 -server [list tls::_accept $iopts $callback]] + #set sopts [linsert $sopts 0 -server [list tls::_accept $uid $callback]] + } else { + if {($idx + 2) != $argc} { + return -code error $usage + } + + set host [lindex $args [expr {$argc-2}]] + set port [lindex $args [expr {$argc-1}]] + + # If an "-autoservername" option is found, honor it + if {[info exists argsArray(-autoservername)] && $argsArray(-autoservername)} { + if {![info exists argsArray(-servername)]} { + set argsArray(-servername) $host + lappend iopts -servername $host + } + } + + lappend sopts $host $port + } + # + # Create TCP/IP socket + # + set chan [eval $socketCmd $sopts] + if {!$server && [catch { + # + # Push SSL layer onto socket + # + eval [list tls::import] $chan $iopts + } err]} { + set info ${::errorInfo} + catch {close $chan} + return -code error -errorinfo $info $err + } + return $chan +} + +# tls::_accept -- +# +# This is the actual accept that TLS sockets use, which then calls +# the callback registered by tls::socket. +# +# Arguments: +# iopts tls::import opts +# callback server callback to invoke +# chan socket channel to accept/deny +# ipaddr calling IP address +# port calling port +# +# Results: +# Returns an error if the callback throws one. +# +proc tls::_accept { iopts callback chan ipaddr port } { + log 2 [list tls::_accept $iopts $callback $chan $ipaddr $port] + + set chan [eval [list tls::import $chan] $iopts] + + lappend callback $chan $ipaddr $port + if {[catch { + uplevel #0 $callback + } err]} { + log 1 "tls::_accept error: ${::errorInfo}" + close $chan + error $err $::errorInfo $::errorCode + } else { + log 2 "tls::_accept - called \"$callback\" succeeded" + } +} +# +# Sample callback for hooking: - +# +# error +# verify +# info +# +proc tls::callback {option args} { + variable debug + + #log 2 [concat $option $args] + + switch -- $option { + "error" { + foreach {chan msg} $args break + + log 0 "TLS/$chan: error: $msg" + } + "verify" { + # poor man's lassign + foreach {chan depth cert rc err} $args break + + array set c $cert + + if {$rc != "1"} { + log 1 "TLS/$chan: verify/$depth: Bad Cert: $err (rc = $rc)" + } else { + log 2 "TLS/$chan: verify/$depth: $c(subject)" + } + if {$debug > 0} { + return 1; # FORCE OK + } else { + return $rc + } + } + "info" { + # poor man's lassign + foreach {chan major minor state msg} $args break + + if {$msg != ""} { + append state ": $msg" + } + # For tracing + upvar #0 tls::$chan cb + set cb($major) $minor + + log 2 "TLS/$chan: $major/$minor: $state" + } + default { + return -code error "bad option \"$option\":\ + must be one of error, info, or verify" + } + } +} + +proc tls::xhandshake {chan} { + upvar #0 tls::$chan cb + + if {[info exists cb(handshake)] && \ + $cb(handshake) == "done"} { + return 1 + } + while {1} { + vwait tls::${chan}(handshake) + if {![info exists cb(handshake)]} { + return 0 + } + if {$cb(handshake) == "done"} { + return 1 + } + } +} + +proc tls::password {} { + log 0 "TLS/Password: did you forget to set your passwd!" + # Return the worlds best kept secret password. + return "secret" +} + +proc tls::log {level msg} { + variable debug + variable logcmd + + if {$level > $debug || $logcmd == ""} { + return + } + set cmd $logcmd + lappend cmd $msg + uplevel #0 $cmd +} +