diff --git a/bin/runtime.cmd b/bin/runtime.cmd new file mode 100644 index 00000000..6b1a49d3 --- /dev/null +++ b/bin/runtime.cmd @@ -0,0 +1,1171 @@ +: "punk MULTISHELL - shebangless polyglot for Tcl Perl sh bash cmd pwsh powershell" + "[rename set S;proc Hide x {proc $x args {}};Hide :]" + "\$(function : {<#pwsh#>})" + "perlhide" + qw^ +set -- "$@" "a=[Hide <#;Hide set;S 1 list]"; set -- : "$@";$1 = @' +: heredoc1 - hide from powershell using @ and squote above. close sqote for unix shells + ' \ +: .bat/.cmd launch section, leading colon hides from cmd, trailing slash hides next line from tcl + \ +: "[Hide @GOTO; Hide =begin; Hide @REM] #not necessary but can help avoid errs in testing" + +: << 'HEREDOC1B_HIDE_FROM_BASH_AND_SH' +: STRONG SUGGESTION: DO NOT MODIFY FIRST LINE OF THIS SCRIPT - except for first double quoted section. +: shebang line is not required on unix or windows and will reduce functionality and/or portability. +: Even comment lines can be part of the functionality of this script (both on unix and windows) - modify with care. +@GOTO :skip_perl_pod_start ^; +=begin excludeperl +: skip_perl_pod_start +: Continuation char at end of this line and rem with curly-braces used to exlude Tcl from the whole cmd block \ +: { +@REM ############################################################################################################################ +@REM THIS IS A POLYGLOT SCRIPT - supporting payloads in Tcl, bash, (some sh) and/or powershelll (powershell.exe or pwsh.exe) +@REM It should remain portable between unix-like OSes & windows if the proper structure is maintained. +@REM ############################################################################################################################ +@REM Change the value of nextshell to one of the supported types, and add code within payload sections for tcl,sh,bash,powershell as appropriate. +@REM This wrapper can be edited manually (carefully!) - or bash,tcl,perl,powershell scripts can be wrapped using the Tcl-based punkshell system +@REM e.g from within a running punkshell: dev scriptwrap.multishell -outputfolder +@REM Call with sh, bash, perl, or tclsh. (powershell untested on unix) +@REM Due to lack of shebang (#! line) Unix-like systems will hopefully default to a flavour of sh that can divert to bash if the script is called without an interpreter - but it may depend on the shell in use when called. +@REM If you find yourself really wanting/needing to add a shebang line - do so on the basis that the script will exist on unix-like systems only. +@REM in batch scripts - array syntax with square brackets is a simulation of arrays or associative arrays. +@REM note that many shells linked as sh do not support substition syntax and may fail - e.g dash etc - generally bash should be used in this context +@SETLOCAL EnableExtensions EnableDelayedExpansion +@SET "validshelltypes= pwsh____________ powershell______ sh______________ wslbash_________ bash____________ tcl_____________ perl____________ none____________" +@REM for batch - only win32 is relevant - but other scripts on other platforms also parse the nextshell block to determine next shell to launch +@REM nextshellpath and nextshelltype indices (underscore-padded to 16wide) are "other" plus those returned by Tcl platform pkg e.g win32,linux,freebsd,macosx +@REM The horrible underscore-padded fixed-widths are to keep the batch labels aligned whilst allowing values to be set +@REM If more than 64 chars needed for a target, it can still be done but overall script padding may need checking/adjusting +@REM Supporting more explicit oses than those listed may also require script padding adjustment +: <> +@SET "nextshellpath[win32___________]=powershell______________________________________________________" +@SET "nextshelltype[win32___________]=powershell______" +@SET "nextshellpath[dragonflybsd____]=/usr/bin/env bash_______________________________________________" +@SET "nextshelltype[dragonflybsd____]=bash____________" +@SET "nextshellpath[freebsd_________]=/usr/bin/env bash_______________________________________________" +@SET "nextshelltype[freebsd_________]=bash____________" +@SET "nextshellpath[netbsd__________]=/usr/bin/env bash_______________________________________________" +@SET "nextshelltype[netbsd__________]=bash____________" +@SET "nextshellpath[linux___________]=/usr/bin/env bash_______________________________________________" +@SET "nextshelltype[linux___________]=bash____________" +@SET "nextshellpath[macosx__________]=/usr/bin/env bash_______________________________________________" +@SET "nextshelltype[macosx__________]=bash____________" +@SET "nextshellpath[other___________]=/usr/bin/env bash_______________________________________________" +@SET "nextshelltype[other___________]=bash____________" +: <> +@rem asadmin is for automatic elevation to administrator. Separate window will be created (seems unavoidable with current elevation mechanism) and user will still get security prompt (probably reasonable). +: <> +@SET "asadmin=0" +: <> +@REM @ECHO nextshelltype is %nextshelltype[win32___________]% +@REM @SET "selected_shelltype=%nextshelltype[win32___________]%" +@SET "selected_shelltype=%nextshelltype[win32___________]%" +@REM @ECHO selected_shelltype %selected_shelltype% +@CALL :stringTrimTrailingUnderscores %selected_shelltype% selected_shelltype_trimmed +@REM @ECHO selected_shelltype_trimmed %selected_shelltype_trimmed% +@SET "selected_shellpath=%nextshellpath[win32___________]%" +@CALL :stringTrimTrailingUnderscores %selected_shellpath% selected_shellpath_trimmed +@CALL SET "keyRemoved=%%validshelltypes:!selected_shelltype!=%%" +@REM @ECHO keyremoved %keyRemoved% +@REM Note that 'powershell' e.g v5 is just a fallback for when pwsh is not available +@REM ## ### ### ### ### ### ### ### ### ### ### ### ### ### +@REM -- cmd/batch file section (ignored on unix but should be left in place) +@REM -- This section intended mainly to launch the next shell (and to escalate privileges if necessary) +@REM -- Avoid customising this if you are not familiar with batch scripting. cmd/batch script can be useful, but is probably the least expressive language and most error prone. +@REM -- For example - as this file needs to use unix-style lf line-endings - the label scanner is susceptible to the 512Byte boundary issue: https://www.dostips.com/forum/viewtopic.php?t=8988#p58888 +@REM -- This label issue can be triggered/abused in files with crlf line endings too - but it is less likely to happen accidentaly. +@REm -- See also: https://stackoverflow.com/questions/4094699/how-does-the-windows-command-interpreter-cmd-exe-parse-scripts/4095133#4095133 +@REM ############################################################################################################################ +@REM -- Due to this issue -seemingly trivial edits of the batch file section can break the script! (for Windows anyway) +@REM -- Even something as simple as adding or removing an @REM +@REM -- From within punkshell - use: +@REM -- deck scriptwrap.checkfile +@REM -- to check your templates or final wrapped scripts for byte boundary issues +@REM -- It will report any labels that are on boundaries +@REM -- This is why the nextshell value above is a 2 digit key instead of a string - so that editing the value doesn't change the byte offsets. +@REM -- Editing your sh,bash,tcl,pwsh payloads is much less likely to cause an issue. There is the possibility of the final batch :exit_multishell label spanning a boundary - so testing using deck scriptwrap.checkfile is still recommended. +@REM -- Alternatively, as you should do anyway - test the final script on windows +@REM -- Aside from adding comments/whitespace to tweak the location of labels - you can try duplicating the label (e.g just add the label on a line above) but this is not guaranteed to work in all situations. +@REM -- '@REM' is a safer comment mechanism than a leading colon - which is used sparingly here. +@REM -- A colon anywhere in the script that happens to land on a 512 Byte boundary (from file start or from a callsite) could be misinterpreted as a label +@REM -- It is unknown what versions of cmd interpreters behave this way - and deck scriptwrap.checkfile doesn't check all such boundaries. +@REm -- For this reason, batch labels should be chosen to be relatively unlikely to collide with other strings in the file, and simple names such as :exit or :end should probably be avoided +@REM ############################################################################################################################ +@REM -- custom windows payloads should be in powershell,tclsh (or sh/bash if available) code sections +@REM ## ### ### ### ### ### ### ### ### ### ### ### ### ### +@SET "winpath=%~dp0" +@SET "fname=%~nx0" +@REM @ECHO fname %fname% +@REM @ECHO winpath %winpath% +@REM @ECHO commandlineascalled %0 +@REM @ECHO commandlineresolved %~f0 +@CALL :getNormalizedScriptTail nftail +@REM @ECHO normalizedscripttail %nftail% +@CALL :getFileTail %0 clinetail +@REM @ECHO clinetail %clinetail% +@CALL :stringToUpper %~nx0 capscripttail +@REM @ECHO capscriptname: %capscripttail% + +@IF "%nftail%"=="%capscripttail%" ( + @ECHO forcing asadmin=1 due to file name on filesystem being uppercase + @SET "asadmin=1" +) else ( + @CALL :stringToUpper %clinetail% capcmdlinetail + @REM @ECHO capcmdlinetail !capcmdlinetail! + IF "%clinetail%"=="!capcmdlinetail!" ( + @ECHO forcing asadmin=1 due to cmdline scriptname in uppercase + @set "asadmin=1" + ) +) +@SET "vbsGetPrivileges=%temp%\punk_bat_elevate_%fname%.vbs" +@SET arglist=%* +@SET "qstrippedargs=args%arglist%" +@SET "qstrippedargs=%qstrippedargs:"=%" +@IF "is%qstrippedargs:~4,13%"=="isPUNK-ELEVATED" ( + GOTO :gotPrivileges +) +@IF !asadmin!==1 ( + net file 1>NUL 2>NUL + @IF '!errorlevel!'=='0' ( GOTO :gotPrivileges ) else ( GOTO :getPrivileges ) +) +@REM padding +@REM padding +@REM padding +@REM padding +@REM padding +@REM padding +@REM padding +@REM padding +@REM padding +@REM padding +@REM padding +@REM padding +@GOTO skip_privileges +:getPrivileges +@IF "is%qstrippedargs:~4,13%"=="isPUNK-ELEVATED" (echo PUNK-ELEVATED & shift /1 & goto :gotPrivileges ) +@ECHO Set UAC = CreateObject^("Shell.Application"^) > "%vbsGetPrivileges%" +@ECHO args = "PUNK-ELEVATED " >> "%vbsGetPrivileges%" +@ECHO For Each strArg in WScript.Arguments >> "%vbsGetPrivileges%" +@ECHO args = args ^& strArg ^& " " >> "%vbsGetPrivileges%" +@ECHO Next >> "%vbsGetPrivileges%" +@ECHO UAC.ShellExecute "%~dp0%~n0%~x0", args, "", "runas", 1 >> "%vbsGetPrivileges%" +@ECHO Launching script in new window due to administrator elevation +@"%SystemRoot%\System32\WScript.exe" "%vbsGetPrivileges%" %* +@EXIT /B + +:gotPrivileges +@REM setlocal & pushd . +@PUSHD . +@cd /d %~dp0 +@IF "is%qstrippedargs:~4,13%"=="isPUNK-ELEVATED" ( + @DEL "%vbsGetPrivileges%" 1>nul 2>nul + @SET arglist=%arglist:~14% +) + +:skip_privileges +@SET need_ps1=0 +@REM we want the ps1 to exist even if the nextshell isn't powershell +@if not exist "%~dp0%~n0.ps1" ( + @SET need_ps1=1 +) ELSE ( + fc "%~dp0%~n0%~x0" "%~dp0%~n0.ps1" >nul || goto different + @REM @ECHO "files same" + @SET need_ps1=0 +) +@GOTO :pscontinue +:different +@REM @ECHO "files differ" +@SET need_ps1=1 +:pscontinue +@IF !need_ps1!==1 ( + COPY "%~dp0%~n0%~x0" "%~dp0%~n0.ps1" >NUL +) +@REM avoid using CALL to launch pwsh,tclsh etc - it will intercept some args such as /? +@IF "!selected_shelltype_trimmed!"=="none" ( + SET selected_shelltype_trimmed=pwsh +) +@IF "!selected_shelltype_trimmed!"=="pwsh" ( + REM pwsh vs powershell hasn't been tested because we didn't need to copy cmd to ps1 this time + REM test availability of preferred option of powershell7+ pwsh + pwsh -nop -nol -c set-executionpolicy -Scope Process Unrestricted 2>NUL; write-host "statusmessage: pwsh-found" >NUL + SET pwshtest_exitcode=!errorlevel! + REM ECHO pwshtest_exitcode !pwshtest_exitcode! + REM fallback to powershell if pwsh failed + IF !pwshtest_exitcode!==0 ( + pwsh -nop -nol -c set-executionpolicy -Scope Process Unrestricted; "%~dp0%~n0.ps1" %arglist% + SET task_exitcode=!errorlevel! + ) ELSE ( + REM TODO prompt user with option to call script to install pwsh using winget + REM powershell -nop -nol -c set-executionpolicy -Scope Process Unrestricted; "%~dp0%~n0.ps1" %arglist% + powershell -nop -nol -ExecutionPolicy Bypass -c "%~dp0%~n0.ps1" %arglist% + SET task_exitcode=!errorlevel! + ) +) ELSE ( + IF "!selected_shelltype_trimmed!"=="powershell" ( + powershell -nop -nol -ExecutionPolicy Bypass -c "%~dp0%~n0.ps1" %arglist% + SET task_exitcode=!errorlevel! + ) ELSE ( + IF "!selected_shelltype_trimmed!"=="wslbash" ( + CALL :getWslPath %winpath% wslpath + REM ECHO wslfullpath "!wslpath!%fname%" + %selected_shellpath_trimmed% "!wslpath!%fname%" %arglist% + SET task_exitcode=!errorlevel! + ) ELSE ( + REM perl or tcl or sh or bash + IF NOT "x%keyRemoved%"=="x%validshelltypes%" ( + REM sh on windows uses /c/ instead of /mnt/c - at least if using msys. Todo, review what is the norm on windows with and without msys2,cygwin,wsl + REM and what logic if any may be needed. For now sh with /c/xxx seems to work the same as sh with c:/xxx + REM The compound statement with trailing call is required to stop batch termination confirmation, whilst still capturing exitcode + @ECHO HERE "!selected_shelltype_trimmed!" "!selected_shellpath_trimmed!" + %selected_shellpath_trimmed% "%~dp0%fname%" %arglist% & SET task_exitcode=!errorlevel! & Call; + ) ELSE ( + ECHO %fname% has invalid nextshelltype value %selected_shelltype% valid options are %validshelltypes% + SET task_exitcode=66 + @REM boundary padding + GOTO :exit_multishell + ) + ) + ) +) +@REM batch file library functions +@REM boundary padding +@GOTO :endlib + +:getWslPath +@SETLOCAL + @SET "_path=%~p1" + @SET "name=%~nx1" + @SET "drive=%~d1" + @SET "rtrn=%~2" + @REM Although drive letters on windows are normally upper case wslbash seems to expect lower case drive letters + @CALL :stringToLower %drive ldrive + @SET "result=/mnt/%ldrive:~0,1%%_path:\=/%%name%" +@ENDLOCAL & ( + @if "%~2" neq "" ( + SET "%rtrn%=%result%" + ) ELSE ( + ECHO %result% + ) +) +@EXIT /B + +:getFileTail +@REM return tail of file without any normalization e.g c:/punkshell/bin/Punk.cmd returns Punk.cmd even if file is punk.cmd +@REM we can't use things such as %~nx1 as it can change capitalisation +@REM This function is designed explicitly to preserve capitalisation +@REM accepts full paths with either / or \ as delimiters - or +@SETLOCAL + @SET "rtrn=%~2" + @SET "arg=%~1" + @REM @SET "result=%_arg:*/=%" + @REM @SET "result=%~1" + @SET LF=^ + + + : The above 2 empty lines are important. Don't remove + @CALL :stringContains "!arg!" "\" hasBackSlash + @IF "!hasBackslash!"=="true" ( + @for %%A in ("!LF!") do @( + @FOR /F %%B in ("!arg:\=%%~A!") do @set "result=%%B" + ) + ) ELSE ( + @CALL :stringContains "!arg!" "/" hasForwardSlash + @IF "!hasForwardSlash!"=="true" ( + @FOR %%A in ("!LF!") do @( + @FOR /F %%B in ("!arg:/=%%~A!") do @set "result=%%B" + ) + ) ELSE ( + @set "result=%arg%" + ) + ) +@ENDLOCAL & ( + @if "%~2" neq "" ( + @SET "%rtrn%=%result%" + ) ELSE ( + @ECHO %result% + ) +) +@EXIT /B +@REM boundary padding +@REM boundary padding +:getNormalizedScriptTail +@SETLOCAL + @SET "result=%~nx0" + @SET "rtrn=%~1" +@ENDLOCAL & ( + @IF "%~1" neq "" ( + @SET "%rtrn%=%result%" + ) ELSE ( + @ECHO %result% + ) +) +@EXIT /B + +:getNormalizedFileTailFromPath +@REM warn via echo, and do not set return variable if path not found +@REM note that %~nx1 does not preserve case of provided path - hence the name 'normalized' +@REM boundary padding +@REM boundary padding +@REM boundary padding +@REM boundary padding +@SETLOCAL + @CALL :stringContains %~1 "\" hasBackSlash + @CALL :stringContains %~1 "/" hasForwardSlash + @IF "%hasBackslash%-%hasForwardslash%"=="false-false" ( + @SET "P=%cd%%~1" + @CALL :getNormalizedFileTailFromPath "!P!" ftail2 + @SET "result=!ftail2!" + ) else ( + @IF EXIST "%~1" ( + @SET "result=%~nx1" + ) else ( + @ECHO error getNormalizedFileTailFromPath file not found: %~1 + @EXIT /B 1 + ) + ) + @SET "rtrn=%~2" +@ENDLOCAL & ( + @IF "%~2" neq "" ( + SET "%rtrn%=%result%" + ) ELSE ( + @ECHO getNormalizedFileTailFromPath %1 result: %result% + ) +) +@EXIT /B + +:stringContains +@REM usage: @CALL:stringContains string needle returnvarname +@SETLOCAL + @SET "rtrn=%~3" + @SET "string=%~1" + @SET "needle=%~2" + @IF "!string:%needle%=!"=="!string!" @( + @SET "result=false" + ) ELSE ( + @SET "result=true" + ) +@ENDLOCAL & ( + @IF "%~3" neq "" ( + @SET "%rtrn%=%result%" + ) ELSE ( + @ECHO stringContains %string% %needle% result: %result% + ) +) +@EXIT /B +@REM boundary padding +@REM boundary padding +:stringToUpper +@SETLOCAL + @SET "rtrn=%~2" + @SET "string=%~1" + @SET "capstring=%~1" + @FOR %%A in (A B C D E F G H I J K L M N O P Q R S T U V W X Y Z) DO @( + @SET "capstring=!capstring:%%A=%%A!" + ) + @SET "result=!capstring!" +@ENDLOCAL & ( + @IF "%~2" neq "" ( + @SET "%rtrn%=%result%" + ) ELSE ( + @ECHO stringToUpper %string% result: %result% + ) +) +@EXIT /B +:stringToLower +@SETLOCAL + @SET "rtrn=%~2" + @SET "string=%~1" + @SET "retstring=%~1" + @FOR %%A in (a b c d e f g h i j k l m n o p q r s t u v w x y z) DO @( + @SET "retstring=!retstring:%%A=%%A!" + ) + @SET "result=!retstring!" +@ENDLOCAL & ( + @IF "%~2" neq "" ( + @SET "%rtrn%=%result%" + ) ELSE ( + @ECHO stringToLower %string% result: %result% + ) +) +@EXIT /B +@REM boundary padding +@REM boundary padding +:stringTrimTrailingUnderscores +@SETLOCAL + @SET "rtrn=%~2" + @SET "string=%~1" + @SET "trimstring=%~1" + @REM trim up to 63 underscores from the end of a string using string substitution + @SET "trimstring=%trimstring%###" + @SET "trimstring=%trimstring:________________________________###=###%" + @SET "trimstring=%trimstring:________________###=###%" + @SET "trimstring=%trimstring:________###=###%" + @SET "trimstring=%trimstring:____###=###%" + @SET "trimstring=%trimstring:__###=###%" + @SET "trimstring=%trimstring:_###=###%" + @SET "trimstring=%trimstring:###=%" + @SET "result=!trimstring!" +@ENDLOCAL & ( + @IF "%~2" neq "" ( + @SET "%rtrn%=%result%" + ) ELSE ( + @ECHO stringTrimTrailingUnderscores %string% result: %result% + ) +) +@EXIT /B +:isNumeric +@SETLOCAL + @SET "notnumeric="&FOR /F "delims=0123456789" %%i in ("%1") do set "notnumeric=%%i" + @IF defined notnumeric ( + @SET "result=false" + ) else ( + @SET "result=true" + ) + @SET "rtrn=%~2" +@ENDLOCAL & ( + @IF "%~2" neq "" ( + @SET "%rtrn%=%result%" + ) ELSE ( + @ECHO %result% + ) +) +@EXIT /B + +:endlib +: \ +@REM padding +@REM padding +@REM @SET taskexit_code=!errorlevel! & goto :exit_multishell +@GOTO :exit_multishell +# } +# -*- tcl -*- +# ## ### ### ### ### ### ### ### ### ### ### ### ### ### +# -- tcl script section +# -- This is a punk multishell file +# -- Primary payload target is Tcl, with sh,bash,powershell as helpers +# -- but it may equally be used with any of these being the primary script. +# -- It is tuned to run when called as a batch file, a tcl script a sh/bash script or a pwsh/powershell script +# -- i.e it is a polyglot file. +# -- The specific layout including some lines that appear just as comments is quite sensitive to change. +# -- It can be called on unix or windows platforms with or without the interpreter being specified on the commandline. +# -- e.g ./filename.polypunk.cmd in sh or bash +# -- e.g tclsh filename.cmd +# -- +# ## ### ### ### ### ### ### ### ### ### ### ### ### ### +rename set ""; rename S set; set k {-- "$@" "a}; if {[info exists ::env($k)]} {unset ::env($k)} ;# tidyup and restore +Hide :exit_multishell;Hide {<#};Hide '@ +namespace eval ::punk::multishell { + set last_script_root [file dirname [file normalize ${::argv0}/__]] + set last_script [file dirname [file normalize [info script]/__]] + if {[info exists ::argv0] && + $last_script eq $last_script_root + } { + set ::punk::multishell::is_main($last_script) 1 ;#run as executable/script - likely desirable to launch application and return an exitcode + } else { + set ::punk::multishell::is_main($last_script) 0 ;#sourced - likely to be being used as a library - no launch, no exit. Can use return. + } + if {"::punk::multishell::is_main" ni [info commands ::punk::multishell::is_main]} { + proc ::punk::multishell::is_main {{script_name {}}} { + if {$script_name eq ""} { + set script_name [file dirname [file normalize [info script]/--]] + } + if {![info exists ::punk::multishell::is_main($script_name)]} { + #e.g a .dll or something else unanticipated + puts stderr "Warning punk::multishell didn't recognize info script result: $script_name - will treat as if sourced and return instead of exiting" + puts stderr "Info: script_root: [file dirname [file normalize ${::argv0}/__]]" + return 0 + } + return [set ::punk::multishell::is_main($script_name)] + } + } +} +# -- --- --- --- --- --- --- --- --- --- --- --- --- ---begin Tcl Payload +#puts "script : [info script]" +#puts "argcount : $::argc" +#puts "argvalues: $::argv" +#puts "argv0 : $::argv0" +# -- --- --- --- --- --- --- --- --- --- --- --- + +# +puts stderr "No tcl code for this script. Try another program such as perl or bash" +# + +# +# + +# +# + + +# +# + + +# -- --- --- --- --- --- --- --- --- --- --- --- +# -- Best practice is to always return or exit above, or just by leaving the below defaults in place. +# -- If the multishell script is modified to have Tcl below the Tcl Payload section, +# -- then Tcl bracket balancing needs to be carefully managed in the shell and powershell sections below. +# -- Only the # in front of the two relevant if statements below needs to be removed to enable Tcl below +# -- but the sh/bash 'then' and 'fi' would also need to be uncommented. +# -- This facility left in place for experiments on whether configuration payloads etc can be appended +# -- to tail of file - possibly binary with ctrl-z char - but utility is dependent on which other interpreters/shells +# -- can be made to ignore/cope with such data. +if {[::punk::multishell::is_main]} { + exit 0 +} else { + return +} +# -- --- --- --- --- --- --- --- --- --- --- --- --- ---end Tcl Payload +# end hide from unix shells \ +HEREDOC1B_HIDE_FROM_BASH_AND_SH +# csh/tcsh/sh/bash use oldschool backticks and sed lowest common denominator \ +echo "script: `echo $0 | sed 's/^-//'`" +# csh/tcsh/sh/bash use oldschool backticks and sed lowest common denominator \ +echo "shell: " `ps -p $$ | awk '$1 != "PID" {print $(NF)}' | tr -d '()' | sed -E 's/^.*\/|^-//'` +#csh/tcsh diversion \ +test "$argv[*]" != "[*]" && ( /usr/bin/env bash $argv[*]; exit ) +#other non-bash diversion \ +test `ps -p $$ | awk '$1 != "PID" {print $(NF)}' | tr -d '()' | sed -E 's/^.*\/|^-//'` != "bash" && /usr/bin/env bash $0 +#review \ +test `ps -p $$ | awk '$1 != "PID" {print $(NF)}' | tr -d '()' | sed -E 's/^.*\/|^-//'` != "bash" && exit +# sh/bash \ +shift && set -- "${@:1:$#-1}" + +#echo "shell:" `ps -o args= $$ | sed -E 's/^.*\/|^-//' | awk '{print $1}'` +#------------------------------------------------------ +# -- This if block only needed if Tcl didn't exit or return above. +if false==false # else { + then + : # +# ## ### ### ### ### ### ### ### ### ### ### ### ### ### +# -- sh/bash script section +# -- leave as is if all that is required is launching the Tcl payload" +# -- +# -- Note that sh/bash script isn't called when running a .bat/.cmd from cmd.exe on windows by default +# -- adjust the %nextshell% value above +# -- if sh/bash scripting needs to run on windows too. +# -- +# ## ### ### ### ### ### ### ### ### ### ### ### ### ### + +if [[ "$OSTYPE" == "linux"* ]]; then + os="linux" +elif [[ "$OSTYPE" == "darwin"* ]]; then + os="macosx" +elif [[ "$OSTYPE" == "freebsd"* ]]; then + os="freebsd" +elif [[ "$OSTYPE" == "dragonflybsd"* ]]; then + os="dragonflybsd" +elif [[ "$OSTYPE" == "netbsd"* ]]; then + os="netbsd" +elif [[ "$OSTYPE" == "win32" ]]; then + os="win32" +elif [[ "$OSTYPE" == "msys" ]]; then + echo MSYS + os="win32" + #review - need ps/sed/awk to determine shell? + interp = `ps -p $$ | awk '$1 != "PID" {print $(NF)}' | tr -d '()' | sed -E 's/^.*\/|^-//'` + #use 'command -v' (shell builtin preferred over external which) + shellpath=`command -v $interp` + shellfolder="${shellpath%/*}" #avoid dependency on basename or dirname + #"c:/windows/system32/" is quite likely in the path ahead of msys,git etc. + #This breaks calls to various unix utils such as sed etc (wsl related?) + export PATH="$shellfolder${PATH:+:${PATH}}" +else + #os="$OSTYPE" + os="other" +fi +echo ostype: $OSTYPE +shellconfigline=$( sed -n "/: <>/{:a;n;/: <>/q;p;ba}" "$0" | grep $os) +#echo $shellconfigline; +if [[ $shellconfigline == *"nextshelltype"* ]]; then + echo "found config for os $os" + split1="${shellconfigline#*=}" #remove everything through the first '=' + #echo "split1: $split1" + pathraw="${split1%%\"*}" #take everything before the quote - use %% to get longest match + pathraw="${pathraw//\"/}" #remove quote + nextshellpath="${pathraw/%_*/}" #remove trailing underscores (% = must match at end) + #echo "nextshellpath: $nextshellpath" + split2="${split1#*=}" + #echo "split2: $split2" + split2="${split2//\"/}" + nextshelltype="${split2/%_*/}" + echo "nextshelltype: $nextshelltype" +else + echo "unable to find config for os $os" + echo "shellconfigline: $shellconfigline" + nextshellpath="" + nextshelltype="" +fi +exitcode=0 +#-- sh/bash launches nextscript here instead of shebang line at top +if [[ "$nextshelltype" != "bash" && "$nextshelltype" != "none" ]]; then + #echo bash launching subshell of type $nextshelltype $nextshellpath on "$0" + #/usr/bin/env tclsh "$0" "$@" + ${nextshellpath} "$0" "$@" + + exitcode=$? + #echo "sh/bash reporting exitcode: ${exitcode}" + exit $exitcode + #-- override exitcode example + #exit 66 +else + #already in bash - don't launch another process or we would loop + #echo "bash payload" + : +fi +# -- --- --- --- --- --- --- --- --- --- --- --- --- ---begin sh Payload +#printf "start of bash or sh code" + +# + +wdir="$(pwd)"; [ "$(pwd)" = "/" ] && wdir="" +case "$0" in + /*) scriptpath="${0}";; + *) scriptpath="$wdir/${0#./}";; +esac +scriptdir="${scriptpath%/*}" +scriptdir=$(realpath $scriptdir) +scriptpath=$(realpath $scriptpath) +basename=$(basename "$scriptpath") #e.g fetchruntime.bash +scriptroot="${basename%.*}" #e.g "fetchruntime" + +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 + 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 + 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" + fi + os="linux" +elif [[ "$OSTYPE" == "darwin"* ]]; then + os="macosx" + #assumed to be Mach-O 'universal binaries' for both x86-64 and arm? - REVIEW + url="${url_kitbase}/macosx/tclkit-902-Darwin64-dyn" + archdir="${scriptdir}/runtime/macosx/" + output="${archdir}/tclkit-902-Darwin64-dyn" + runtime_available=1 +elif [[ "$OSTYPE" == "freebsd"* ]]; then + os="freebsd" +elif [[ "$OSTYPE" == "dragonflybsd"* ]]; then + os="dragonflybsd" +elif [[ "$OSTYPE" == "netbsd"* ]]; then + os="netbsd" +elif [[ "$OSTYPE" == "win32" ]]; then + os="win32" + url="${url_kitbase}/win32-x86_64/tclsh902z.exe" + archdir="${scriptdir}/runtime/win32-x86_64/" + output="${archdir}/tcsh902z.exe" + runtime_available=1 +elif [[ "$OSTYPE" == "msys" ]]; then + echo MSYS + os="win32" + #use 'command -v' (shell builtin preferred over external which) + interp = `ps -p $$ | awk '$1 != "PID" {print $(NF)}' | tr -d '()' | sed -E 's/^.*\/|^-//'` + shellpath=`command -v $interp` + shellfolder="${shellpath%/*}" #avoid dependency on basename or dirname + #"c:/windows/system32/" is quite likely in the path ahead of msys,git etc. + #This breaks calls to various unix utils such as sed etc (wsl related?) + export PATH="$shellfolder${PATH:+:${PATH}}" + url="${url_kitbase}/win32-x86_64/tclsh902z.exe" + archdir="${scriptdir}/runtime/win32-x86_64" + output="${archdir}/tclsh902z.exe" + runtime_available=1 +else + #os="$OSTYPE" + os="other" +fi + +case "$1" in + "fetch") + + if [[ "$runtime_available" -eq 1 ]]; then + #test win32 + mkdir -p $archdir + echo "Attempting to download $url" + #wget $url -O $output + curl -SL --output "$output" "$url" + if [[ $? -eq 0 ]]; then + echo "File downloaded to $output" + chmod +x $output + else + echo "Error: Failed to download to $output" + fi + else + echo "No runtime currently available for $os" + fi + ;; + "list") + 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." + 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" + shift + echo "args: $@" + $activeruntime_fullpath "$@" + ;; + *) + echo "Usage: $0 {fetch|list|run}" + exit 1 + ;; +esac + +# + +# +# + +# -- --- --- --- --- --- --- --- +# +#-- sh/bash launches Tcl here instead of shebang line at top +#-- use exec to use exitcode (if any) directly from the tcl script +#exec /usr/bin/env tclsh "$0" "$@" +#-- alternative - can run sh/bash script after the tcl call. +#/usr/bin/env tclsh "$0" "$@" +#exitcode=$? +#echo "sh/bash reporting tcl exitcode: ${exitcode}" +#-- override exitcode example +#exit 66 +# +# -- --- --- --- --- --- --- --- + +# +# + + +#printf "sh/bash done \n" +# -- --- --- --- --- --- --- --- --- --- --- --- --- ---end sh Payload +#------------------------------------------------------ +fi +exit ${exitcode} +# ## ### ### ### ### ### ### ### ### ### ### ### ### ### +# -- Perl script section +# -- leave the script below as is, if all that is required is launching the Tcl payload" +# -- +# -- Note that perl script isn't called by default when simply running this script by name +# -- adjust the nextshell value at the top of the script to point to perl +# -- +# ## ### ### ### ### ### ### ### ### ### ### ### ### ### +=cut +#!/user/bin/perl +my $exit_code = 0; +use Cwd qw(abs_path); +my $scriptname = abs_path($0); +#print "perl $scriptname\n"; +my $os = "$^O"; +if ($os eq "MSWin32") { + $os = "win32"; +} elsif ($os eq "darwin") { + $os = "macosx"; +} +print "os $os\n"; +# -- --- --- --- --- --- --- --- --- --- --- --- --- ---begin perl Payload +#use ExtUtils::Installed; +#my $installed = ExtUtils::Installed->new(); +#my @modules = $installed->modules(); +#print "Modules:\n"; +#foreach my $m (@modules) { +# print "$m\n"; +#} +# -- --- --- + + + +my $i =1; +foreach my $a(@ARGV) { + print "Arg # $i: $a\n"; +} + +# +print STDERR "No perl code for this script. Try another program such as tcl or bash"; +# + +# +# + + + +# -- --- --- --- --- --- --- --- +# +#$exit_code=system("tclsh", $scriptname, @ARGV); +#print "perl reporting tcl exitcode: $exit_code"; +# +# -- --- --- --- --- --- --- --- + +# +# + + +# -- --- --- --- --- --- --- --- --- --- --- --- --- ---end perl Payload +exit $exit_code; +__END__ + +# end hide sh/bash/perl block from Tcl +# This comment with closing brace should stay in place whether if commented or not } +#------------------------------------------------------ +# begin hide powershell-block from Tcl - only needed if Tcl didn't exit or return above +if 0 { +: end heredoc1 - end hide from powershell \ +'@ +# ## ### ### ### ### ### ### ### ### ### ### ### ### ### +# -- powershell/pwsh section +# -- Do not edit if current file is the .ps1 +# -- Edit the corresponding .cmd and it will autocopy +# -- unbalanced braces { } here *even in comments* will cause problems if there was no Tcl exit or return above +# -- custom script should generally go below the begin_powershell_payload line +# ## ### ### ### ### ### ### ### ### ### ### ### ### ### +function GetScriptName { $myInvocation.ScriptName } +$scriptname = GetScriptName +function GetDynamicParamDictionary { + [CmdletBinding()] + param( + [Parameter(ValueFromPipeline=$true, Mandatory=$true)] + [string] $CommandName + ) + + begin { + # Get a list of params that should be ignored (they're common to all advanced functions) + $CommonParameterNames = [System.Runtime.Serialization.FormatterServices]::GetUninitializedObject([type] [System.Management.Automation.Internal.CommonParameters]) | + Get-Member -MemberType Properties | + Select-Object -ExpandProperty Name + } + + process { + # Create the dictionary that this scriptblock will return: + $DynParamDictionary = New-Object System.Management.Automation.RuntimeDefinedParameterDictionary + + # Convert to object array and get rid of Common params: + (Get-Command $CommandName | select -exp Parameters).GetEnumerator() | + Where-Object { $CommonParameterNames -notcontains $_.Key } | + ForEach-Object { + $DynamicParameter = New-Object System.Management.Automation.RuntimeDefinedParameter ( + $_.Key, + $_.Value.ParameterType, + $_.Value.Attributes + ) + $DynParamDictionary.Add($_.Key, $DynamicParameter) + } + + # Return the dynamic parameters + return $DynParamDictionary + } +} +# GetDynamicParamDictionary +# - This can make it easier to share a single set of param definitions between functions +# - sample usage +#function ParameterDefinitions { +# param( +# [Parameter(Mandatory)][string] $myargument +# ) +#} +#function psmain { +# [CmdletBinding()] +# param() +# dynamicparam { GetDynamicParamDictionary ParameterDefinitions } +# process { +# #called once with $PSBoundParameters dictionary +# #can be used to validate arguments, or set a simpler variable name for access +# switch ($PSBoundParameters.keys) { +# 'myargumentname' { +# Set-Variable -Name $_ -Value $PSBoundParameters."$_" +# } +# #... +# } +# foreach ($boundparam in $PSBoundParameters.GetEnumerator()) { +# #... +# } +# } +# end { +# #Main function logic +# Write-Host "myargumentname value is: $myargumentname" +# #myotherfunction @PSBoundParameters +# } +#} +#psmain @args +#"Timestamp : {0,10:yyyy-MM-dd HH:mm:ss}" -f $(Get-Date) | write-host +#"Script Name : {0}" -f $scriptname | write-host +#"Powershell Version: {0}" -f $PSVersionTable.PSVersion.Major | write-host +#"powershell args : {0}" -f ($args -join ", ") | write-host +# -- --- --- --- +$startTag = ": <>" +$endTag = ": <>" +$fileContent = Get-Content $scriptname -Raw +$pattern = "(?s)$startTag(.*?)$endTag" +$matches = [regex]::Matches($fileContent,$pattern) +$admininfo = $matches[0].Groups[1].Value +$asadmin = 0 +if ($matches.count) { + $asadmin = $admininfo.Contains("asadmin=1") + if ($asadmin) { + if (-not ([Security.Principal.WindowsPrincipal][Security.Principal.WindowsIdentity]::GetCurrent()).IsInRole([Security.Principal.WindowsBuiltInRole]::Administrator)) { + # If not elevated, relaunch with elevated privileges + # -Wait e.g for starting a service or other operations which remainder of script may depend on + $arguments = @("-NoProfile", "-NoExit", "-ExecutionPolicy", "Bypass") + $arguments += @("-File", $($MyInvocation.MyCommand.Path)) + $arguments += $args + if ($PSVersionTable.PSEdition -eq 'Core') { + Start-Process -FilePath "pwsh.exe" -ArgumentList $arguments -Wait -Verb RunAs + } else { + Start-Process -FilePath "powershell.exe" -ArgumentList $arguments -Wait -Verb RunAs + } + Exit # Exit the current non-elevated process + } + } +} +# -- --- --- --- --- --- --- --- --- --- --- --- --- ---begin powershell Payload + +# + + +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-Object -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 + } +} +function ParameterDefinitions { + param( + [Parameter(ValueFromRemainingArguments=$true)] $opts + ) +} + +function psmain { + [CmdletBinding()] + #Empty param block (extra params can be added) + param( + [Parameter(Mandatory=$false)][string] $action + ) + dynamicparam { + if ($action -eq 'list') { + } elseif ($action -eq 'fetch') { + #GetDynamicParamDictionary ParameterDefinitions + $parameterAttribute = [System.Management.Automation.ParameterAttribute]@{ + ParameterSetName = "fetchruntime" + Mandatory = $false + } + $attributeCollection = [System.Collections.ObjectModel.Collection[System.Attribute]]::new() + $attributeCollection.Add($parameterAttribute) + + $dynParam1 = [System.Management.Automation.RuntimeDefinedParameter]::new( + 'runtime', [string], $attributeCollection + ) + + $paramDictionary = [System.Management.Automation.RuntimeDefinedParameterDictionary]::new() + $paramDictionary.Add('runtime', $dynParam1) + return $paramDictionary + } elseif ($action -eq 'run') { + GetDynamicParamDictionary ParameterDefinitions + } else { + } + } + process { + #Called once - we get a single item being our PSBoundParameters dictionary + #write-host "Bound Parameters:$($PSBoundParameters.Keys)" + switch ($PSBoundParameters.keys) { + 'action' { + #write-host "got action " $PSBoundParameters.action + Set-Variable -Name $_ -Value $PSBoundParameters."$_" + $known_actions = @("fetch", "list", "run") + if (-not($known_actions -contains $action)) { + write-host "fetch '$action' not understood. Known_actions: $known_actions" + exit 1 + } + } + 'opts' { + #write-warning "Unused parameters: $($PSBoundParameters.$_)" + } + Default { + #write-warning "Unhandled parameter -> [$($_)]" + } + } + #foreach ($boundparam in $PSBoundParameters.Keys) { + # write-host "k: $boundparam" + #} + } + end { + # PSBoundParameters + #write-host "action:'$action'" + $outbase = $PSScriptRoot + $outbase = Resolve-Path -Path $outbase + #expected script location is the bin folder of a punk project + $rtfolder = Join-Path -Path $outbase -ChildPath "runtime" + $archfolder = Join-Path -Path $rtfolder -ChildPath "win32-x86_64" + switch ($action) { + 'fetch' { + $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])" + } + if ( $PSBoundParameters["runtime"].Length ) { + $runtime = $PSBoundParameters["runtime"] + } + $fileurl = "$archurl/$runtime" + $output = join-path $archfolder $runtime + + $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" + } + catch { + Write-Host "An error occurred: $($_.Exception.Message)" + if ($_.Exception.Response) { + Write-Host "HTTP Status code: $($_.Exception.Response.StatusCode)" + } + } + } else { + Write-Host "Runtime already found at $output" + } + } + 'run' { + #select first (or configured default) runtime and launch, passing arguments + 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 + #} + #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 + } 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." + } + } + } + '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 + } + } else { + write-host "No runtimes seem to be installed for win32-x86_64 in $archfolder`nPlase use 'runtime.cmd fetch' to install." + } + } + default { + $actions = @("fetch", "list", "run") + write-host "Available actions: $actions" + } + } + + return $PSBoundParameters + } +} +#write-host (psmain @args) +$returnvalue = psmain @args +#Write-Host "Function Returned $returnvalue" -ForegroundColor Cyan +return $returnvalue +exit 0 + + +# + +# +# + + +# -- --- --- --- --- --- --- --- +# +#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/bootsupport/lib/base64/ascii85.tcl b/src/bootsupport/lib/base64/ascii85.tcl index e05e3430..4fa17c06 100644 --- a/src/bootsupport/lib/base64/ascii85.tcl +++ b/src/bootsupport/lib/base64/ascii85.tcl @@ -6,7 +6,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -package require Tcl 8.4 +package require Tcl 8.5 9 namespace eval ascii85 { namespace export encode encodefile decode @@ -48,7 +48,7 @@ proc ascii85::encode {args} { must be -maxlen or -wrapchar" } } - + ##nagelfar ignore if {![string is integer -strict $opts(-maxlen)] || $opts(-maxlen) < 0} { return -code error "expected positive integer but got\ @@ -60,8 +60,8 @@ proc ascii85::encode {args} { return "" } - # shorten the names - set ml $opts(-maxlen) + # shorten the names, and normalize numeric values. + set ml [format %d $opts(-maxlen)] set wc $opts(-wrapchar) # if maxlen is zero, don't wrap the output @@ -150,8 +150,7 @@ proc ascii85::encode4bytes {b1 b2 b3 b4} { # This is a convenience command proc ascii85::encodefile {fname} { - set fd [open $fname] - fconfigure $fd -encoding binary -translation binary + set fd [open $fname rb] return [encode [read $fd]][close $fd] } @@ -268,4 +267,4 @@ proc ascii85::pad {chars len padchar} { return $chars } -package provide ascii85 1.0 +package provide ascii85 1.1.1 diff --git a/src/bootsupport/lib/base64/base64.tcl b/src/bootsupport/lib/base64/base64.tcl index fa52c1c3..14a6fbb5 100644 --- a/src/bootsupport/lib/base64/base64.tcl +++ b/src/bootsupport/lib/base64/base64.tcl @@ -19,14 +19,14 @@ # @mdgen EXCLUDE: base64c.tcl -package require Tcl 8.2 +package require Tcl 8.5 9 namespace eval ::base64 { namespace export encode decode } -package provide base64 2.5 +package provide base64 2.6.1 -if {[package vsatisfies [package require Tcl] 8.6]} { +if {[package vsatisfies [package require Tcl] 8.6 9]} { proc ::base64::encode {args} { binary encode base64 -maxlen 76 {*}$args } @@ -180,7 +180,8 @@ if {![catch {package require Trf 2.0}]} { variable base64_tmp variable i - set i 0 + variable i 0 + variable char foreach char {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 \ 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 \ 0 1 2 3 4 5 6 7 8 9 + /} { diff --git a/src/bootsupport/lib/base64/base64c.tcl b/src/bootsupport/lib/base64/base64c.tcl index 29e501df..49a88711 100644 --- a/src/bootsupport/lib/base64/base64c.tcl +++ b/src/bootsupport/lib/base64/base64c.tcl @@ -8,7 +8,7 @@ # @sak notprovided base64c package require critcl -package provide base64c 0.1.0 +package provide base64c 0.1.1 namespace eval ::base64c { variable base64c_rcsid {$Id: base64c.tcl,v 1.5 2008/03/25 07:15:35 andreas_kupries Exp $} diff --git a/src/bootsupport/lib/base64/pkgIndex.tcl b/src/bootsupport/lib/base64/pkgIndex.tcl index c8528f59..83a05a04 100644 --- a/src/bootsupport/lib/base64/pkgIndex.tcl +++ b/src/bootsupport/lib/base64/pkgIndex.tcl @@ -1,5 +1,5 @@ -if {![package vsatisfies [package provide Tcl] 8.2]} {return} -package ifneeded base64 2.5 [list source [file join $dir base64.tcl]] -package ifneeded uuencode 1.1.5 [list source [file join $dir uuencode.tcl]] -package ifneeded yencode 1.1.3 [list source [file join $dir yencode.tcl]] -package ifneeded ascii85 1.0 [list source [file join $dir ascii85.tcl]] +if {![package vsatisfies [package provide Tcl] 8.5 9]} {return} +package ifneeded base64 2.6.1 [list source [file join $dir base64.tcl]] +package ifneeded uuencode 1.1.6 [list source [file join $dir uuencode.tcl]] +package ifneeded yencode 1.1.4 [list source [file join $dir yencode.tcl]] +package ifneeded ascii85 1.1.1 [list source [file join $dir ascii85.tcl]] diff --git a/src/bootsupport/lib/base64/uuencode.tcl b/src/bootsupport/lib/base64/uuencode.tcl index 5e26422d..2b2a9ee3 100644 --- a/src/bootsupport/lib/base64/uuencode.tcl +++ b/src/bootsupport/lib/base64/uuencode.tcl @@ -7,7 +7,7 @@ # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # ------------------------------------------------------------------------- -package require Tcl 8.2; # tcl minimum version +package require Tcl 8.5 9; # tcl minimum version # Try and get some compiled helper package. if {[catch {package require tcllibc}]} { @@ -30,9 +30,9 @@ proc ::uuencode::Encode {s} { if {$c2 == {}} {set c2 0} if {$c3 == {}} {set c3 0} append r [Enc [expr {$c1 >> 2}]] - append r [Enc [expr {(($c1 << 4) & 060) | (($c2 >> 4) & 017)}]] - append r [Enc [expr {(($c2 << 2) & 074) | (($c3 >> 6) & 003)}]] - append r [Enc [expr {($c3 & 077)}]] + append r [Enc [expr {(($c1 << 4) & 0o060) | (($c2 >> 4) & 0o017)}]] + append r [Enc [expr {(($c2 << 2) & 0o074) | (($c3 >> 6) & 0o003)}]] + append r [Enc [expr {($c3 & 0o077)}]] } return $r } @@ -67,27 +67,28 @@ if {[package provide critcl] != {}} { } critcl::ccommand CEncode {dummy interp objc objv} { Tcl_Obj *inputPtr, *resultPtr; - int len, rlen, xtra; + Tcl_Size len, rlen, xtra; unsigned char *input, *p, *r; if (objc != 2) { - Tcl_WrongNumArgs(interp, 1, objv, "data"); + Tcl_WrongNumArgs(interp, 1, objv, "data"); /* OK tcl9 */ return TCL_ERROR; } inputPtr = objv[1]; - input = Tcl_GetByteArrayFromObj(inputPtr, &len); + input = Tcl_GetBytesFromObj(interp, inputPtr, &len); /* OK tcl9 */ + if (input == NULL) return TCL_ERROR; if ((xtra = (3 - (len % 3))) != 3) { if (Tcl_IsShared(inputPtr)) inputPtr = Tcl_DuplicateObj(inputPtr); - input = Tcl_SetByteArrayLength(inputPtr, len + xtra); + input = Tcl_SetByteArrayLength(inputPtr, len + xtra); /* OK tcl9 */ memset(input + len, 0, xtra); len += xtra; } rlen = (len / 3) * 4; resultPtr = Tcl_NewObj(); - r = Tcl_SetByteArrayLength(resultPtr, rlen); + r = Tcl_SetByteArrayLength(resultPtr, rlen); /* OK tcl9 */ memset(r, 0, rlen); for (p = input; p < input + len; p += 3) { @@ -104,21 +105,22 @@ if {[package provide critcl] != {}} { critcl::ccommand CDecode {dummy interp objc objv} { Tcl_Obj *inputPtr, *resultPtr; - int len, rlen, xtra; + Tcl_Size len, rlen, xtra; unsigned char *input, *p, *r; if (objc != 2) { - Tcl_WrongNumArgs(interp, 1, objv, "data"); + Tcl_WrongNumArgs(interp, 1, objv, "data"); /* OK tcl9 */ return TCL_ERROR; } /* if input is not mod 4, extend it with nuls */ inputPtr = objv[1]; - input = Tcl_GetByteArrayFromObj(inputPtr, &len); + input = Tcl_GetBytesFromObj(interp, inputPtr, &len); /* OK tcl9 */ + if (input == NULL) return TCL_ERROR; if ((xtra = (4 - (len % 4))) != 4) { if (Tcl_IsShared(inputPtr)) inputPtr = Tcl_DuplicateObj(inputPtr); - input = Tcl_SetByteArrayLength(inputPtr, len + xtra); + input = Tcl_SetByteArrayLength(inputPtr, len + xtra); /* OK tcl9 */ memset(input + len, 0, xtra); len += xtra; } @@ -126,7 +128,7 @@ if {[package provide critcl] != {}} { /* output will be 1/3 smaller than input and a multiple of 3 */ rlen = (len / 4) * 3; resultPtr = Tcl_NewObj(); - r = Tcl_SetByteArrayLength(resultPtr, rlen); + r = Tcl_SetByteArrayLength(resultPtr, rlen); /* OK tcl9 */ memset(r, 0, rlen); for (p = input; p < input + len; p += 4) { @@ -181,7 +183,7 @@ if {[info commands ::uuencode::CDecode] != {}} { # ------------------------------------------------------------------------- proc ::uuencode::uuencode {args} { - array set opts {mode 0644 filename {} name {}} + array set opts {mode 0o0644 filename {} name {}} set wrongargs "wrong \# args: should be\ \"uuencode ?-name string? ?-mode octal?\ (-file filename | ?--? string)\"" @@ -258,7 +260,7 @@ proc ::uuencode::uuencode {args} { # data itself. # proc ::uuencode::uudecode {args} { - array set opts {mode 0644 filename {}} + array set opts {mode 0o0644 filename {}} set wrongargs "wrong \# args: should be \"uudecode (-file filename | ?--? string)\"" while {[string match -* [lindex $args 0]]} { switch -glob -- [lindex $args 0] { @@ -324,7 +326,7 @@ proc ::uuencode::uudecode {args} { # ------------------------------------------------------------------------- -package provide uuencode 1.1.5 +package provide uuencode 1.1.6 # ------------------------------------------------------------------------- # diff --git a/src/bootsupport/lib/base64/yencode.tcl b/src/bootsupport/lib/base64/yencode.tcl index 0d4554c0..017085db 100644 --- a/src/bootsupport/lib/base64/yencode.tcl +++ b/src/bootsupport/lib/base64/yencode.tcl @@ -9,7 +9,7 @@ # FUTURE: Rework to allow switching between the tcl/critcl implementations. -package require Tcl 8.2; # tcl minimum version +package require Tcl 8.5 9; # tcl minimum version catch {package require crc32}; # tcllib 1.1 catch {package require tcllibc}; # critcl enhancements for tcllib @@ -65,17 +65,18 @@ if {[package provide critcl] != {}} { } critcl::ccommand CEncode {dummy interp objc objv} { Tcl_Obj *inputPtr, *resultPtr; - int len, rlen, xtra; + Tcl_Size len, rlen, xtra; unsigned char *input, *p, *r, v; if (objc != 2) { - Tcl_WrongNumArgs(interp, 1, objv, "data"); + Tcl_WrongNumArgs(interp, 1, objv, "data"); /* OK tcl9 */ return TCL_ERROR; } /* fetch the input data */ inputPtr = objv[1]; - input = Tcl_GetByteArrayFromObj(inputPtr, &len); + input = Tcl_GetBytesFromObj(interp, inputPtr, &len); /* OK tcl9 */ + if (input == NULL) return TCL_ERROR; /* calculate the length of the encoded result */ rlen = len; @@ -87,7 +88,7 @@ if {[package provide critcl] != {}} { /* allocate the output buffer */ resultPtr = Tcl_NewObj(); - r = Tcl_SetByteArrayLength(resultPtr, rlen); + r = Tcl_SetByteArrayLength(resultPtr, rlen); /* OK tcl9 */ /* encode the input */ for (p = input; p < input + len; p++) { @@ -104,21 +105,22 @@ if {[package provide critcl] != {}} { critcl::ccommand CDecode {dummy interp objc objv} { Tcl_Obj *inputPtr, *resultPtr; - int len, rlen, esc; + Tcl_Size len, rlen, esc; unsigned char *input, *p, *r, v; if (objc != 2) { - Tcl_WrongNumArgs(interp, 1, objv, "data"); + Tcl_WrongNumArgs(interp, 1, objv, "data"); /* OK tcl9 */ return TCL_ERROR; } /* fetch the input data */ inputPtr = objv[1]; - input = Tcl_GetByteArrayFromObj(inputPtr, &len); + input = Tcl_GetBytesFromObj(interp, inputPtr, &len); /* OK tcl9 */ + if (input == NULL) return TCL_ERROR; /* allocate the output buffer */ resultPtr = Tcl_NewObj(); - r = Tcl_SetByteArrayLength(resultPtr, len); + r = Tcl_SetByteArrayLength(resultPtr, len); /* OK tcl9 */ /* encode the input */ for (p = input, esc = 0, rlen = 0; p < input + len; p++) { @@ -134,7 +136,7 @@ if {[package provide critcl] != {}} { *r++ = v; rlen++; } - Tcl_SetByteArrayLength(resultPtr, rlen); + Tcl_SetByteArrayLength(resultPtr, rlen); /* OK tcl9 */ Tcl_SetObjResult(interp, resultPtr); return TCL_OK; } @@ -192,7 +194,7 @@ proc ::yencode::yencode {args} { } if {$opts(filename) != {}} { - set f [open $opts(filename) r] + set f [open $opts(filename) rb] fconfigure $f -translation binary set data [read $f] close $f @@ -296,7 +298,7 @@ proc ::yencode::ydecode {args} { # ------------------------------------------------------------------------- -package provide yencode 1.1.3 +package provide yencode 1.1.4 # ------------------------------------------------------------------------- # diff --git a/src/bootsupport/lib/virtchannel_base/cat.tcl b/src/bootsupport/lib/virtchannel_base/cat.tcl new file mode 100644 index 00000000..28a287a1 --- /dev/null +++ b/src/bootsupport/lib/virtchannel_base/cat.tcl @@ -0,0 +1,135 @@ +# -*- tcl -*- +# # ## ### ##### ######## ############# +# (C) 2011,2019 Andreas Kupries + +# Facade concatenating the contents of the channels it was constructed +# with. Owns the sub-ordinate channels and closes them on exhaustion and/or +# when closed itself. + +# @@ Meta Begin +# Package tcl::chan::cat 1.0.4 +# Meta as::author {Andreas Kupries} +# Meta as::copyright 2011 +# Meta as::license BSD +# Meta description Facade concatenating the contents of the channels it +# Meta description was constructed with. Owns the sub-ordinate channels +# Meta description and closes them on exhaustion and/or when closed itself. +# Meta platform tcl +# Meta require TclOO +# Meta require tcl::chan::core +# Meta require {Tcl 8.5} +# @@ Meta End + +# # ## ### ##### ######## ############# + +package require Tcl 8.5 9 +package require TclOO +package require tcl::chan::core + +# # ## ### ##### ######## ############# + +namespace eval ::tcl::chan {} + +proc ::tcl::chan::cat {args} { + return [::chan create {read} [cat::implementation new {*}$args]] +} + +oo::class create ::tcl::chan::cat::implementation { + superclass ::tcl::chan::core ; # -> initialize, finalize. + + # We are not using the standard event handling class, because here + # it will not be timer-driven. We propagate anything related to + # events to catin and catout instead and let them handle things. + + constructor {args} { + set channels $args + # Disable translation (and hence encoding) in the wrapped channels. + # This will happen in our generic layer instead. + foreach c $channels { + fconfigure $c -translation binary + } + set delay 10 + set watching 0 + return + } + + destructor { + foreach c $channels { + ::close $c + } + return + } + + variable channels timer delay watching + + method watch {c requestmask} { + if {"read" in $requestmask} { + # Activate event handling. Either drive an eof home via + # timers, or activate things in the foremost sub-ordinate. + + set watching 1 + if {![llength $channels]} { + set timer [after $delay [namespace code [list my Post $c]]] + } else { + chan event [lindex $channels 0] readable [list chan postevent $c read] + } + } else { + # Stop events. Either kill timer, or disable in the + # foremost sub-ordinate. + + set watching 0 + if {![llength $channels]} { + catch { after cancel $timer } + } else { + chan event [lindex $channels 0] readable {} + } + } + return + } + + method read {c n} { + if {![llength $channels]} { + # This signals EOF higher up. + return {} + } + + set buf {} + while {([string length $buf] < $n) && + [llength $channels]} { + + set in [lindex $channels 0] + set toread [expr {$n - [string length $buf]}] + append buf [::read $in $toread] + + if {[eof $in]} { + close $in + set channels [lrange $channels 1 end] + + # The close of the exhausted subordinate killed any + # fileevent handling we may have had attached to this + # channel. Update the settings (i.e. move to the next + # subordinate, or to timer-based, to drive the eof + # home). + + if {$watching} { + my watch $c read + } + } + } + + # When `buf` is empty, all channels have been exhausted and + # closed, therefore returning this empty string will cause an + # EOF higher up. + return $buf + } + + method Post {c} { + set timer [after $delay [namespace code [list my Post $c]]] + chan postevent $c read + return + } +} + +# # ## ### ##### ######## ############# +package provide tcl::chan::cat 1.0.4 +return diff --git a/src/bootsupport/lib/virtchannel_base/facade.tcl b/src/bootsupport/lib/virtchannel_base/facade.tcl new file mode 100644 index 00000000..d738446f --- /dev/null +++ b/src/bootsupport/lib/virtchannel_base/facade.tcl @@ -0,0 +1,234 @@ +# -*- tcl -*- +# # ## ### ##### ######## ############# +# (C) 2011 Andreas Kupries + +# Facade wrapping around some other channel. All operations on the +# facade are delegated to the wrapped channel. This makes it useful +# for debugging of Tcl's activity on a channel. While a transform can +# be used for that as well it does not have access to some things of +# the base-channel, i.e. all the event managment is not visible to it, +# whereas the facade has access to even this. + +# @@ Meta Begin +# Package tcl::chan::facade 1.0.2 +# Meta as::author {Colin McCormack} +# Meta as::author {Andreas Kupries} +# Meta as::copyright 2011 +# Meta as::license BSD +# Meta description Facade wrapping around some other channel. All +# Meta description operations on the facade are delegated to the +# Meta description wrapped channel. This makes it useful for debugging +# Meta description of Tcl's activity on a channel. While a transform +# Meta description can be used for that as well it does not have +# Meta description access to some things of the base-channel, i.e. all +# Meta description the event managment is not visible to it, whereas +# Meta description the facade has access to even this. +# Meta platform tcl +# Meta require TclOO +# Meta require tcl::chan::core +# Meta require {Tcl 8.5} +# @@ Meta End + +# # ## ### ##### ######## ############# +## TODO document the special options of the facade +## TODO log integration. +## TODO document that facada takes ownership of the channel. + +package require Tcl 8.5 9 +package require TclOO +package require logger +package require tcl::chan::core + +# # ## ### ##### ######## ############# + +namespace eval ::tcl::chan {} + +logger::initNamespace ::tcl::chan::facade +proc ::tcl::chan::facade {args} { + return [::chan create {read} [facade::implementation new {*}$args]] +} + +# # ## ### ##### ######## ############# + +oo::class create ::tcl::chan::facade::implementation { + superclass ::tcl::chan::core ; # -> initialize, finalize. + + # # ## ### ##### ######## ############# + + # We are not using the standard event handling class, because here + # it will not be timer-driven. We propagate anything related to + # events to the wrapped channel instead and let it handle things. + + constructor {thechan} { + # Access to the log(ger) commands. + namespace path [list {*}[namespace path] ::tcl::chan::facade] + + set chan $thechan + + # set some configuration data + set created [clock milliseconds] + set used 0 + set user "" ;# user data - freeform + + # validate args + if {$chan eq [self]} { + return -code error "recursive chan! No good." + } elseif {$chan eq ""} { + return -code error "Needs a chan argument" + } + + set blocking [::chan configure $chan -blocking] + return + } + + destructor { + log::debug {[self] destroyed} + if {[catch { ::chan close $chan } e o]} { + log::debug {failed to close $chan [self] because "$e" ($o)} + } + return + } + + variable chan used user created blocking + + method initialize {myself mode} { + log::debug {$myself initialize $chan $mode} + log::debug {$chan configured: ([::chan configure $chan])} + return [next $chan $mode] + } + + method finalize {myself} { + log::debug {$myself finalize $chan} + catch {::chan close $chan} + catch {next $myself} + catch {my destroy} + return + } + + method blocking {myself mode} { + if {[catch { + ::chan configure $chan -blocking $mode + set blocking $mode + } e o]} { + log::debug {$myself blocking $chan $mode -> error $e ($o)} + } else { + log::debug {$myself blocking $chan $mode -> $e} + } + return + } + + method watch {myself requestmask} { + log::debug {$myself watch $chan $requestmask} + + if {"read" in $requestmask} { + fileevent readable $chan [my Callback Readable $myself] + } else { + fileevent readable $chan {} + } + + if {"write" in $requestmask} { + fileevent writable $chan [my Callback Writable $myself] + } else { + fileevent writable $chan {} + } + return + } + + method read {myself n} { + log::debug {$myself read $chan begin eof: [::chan eof $chan], blocked: [::chan blocked $chan]} + set used [clock milliseconds] + + if {[catch { + set data [::chan read $chan $n] + } e o]} { + log::error {$myself read $chan $n -> error $e ($o)} + } else { + log::debug {$myself read $chan $n -> [string length $data] bytes: [string map {\n \\n} "'[string range $data 0 20]...[string range $data end-20 end]"]'} + log::debug {$myself read $chan eof = [::chan eof $chan]} + log::debug {$myself read $chan blocked = [::chan blocked $chan]} + log::debug {$chan configured: ([::chan configure $chan])} + + set gone [catch {chan eof $chan} eof] + if { + ($data eq {}) && + !$gone && !$eof && !$blocking + } { + log::error {$myself EAGAIN} + return -code error EAGAIN + } + } + + log::debug {$myself read $chan result: [string length $data] bytes} + return $data + } + + method write {myself data} { + log::debug {$myself write $chan [string length $data] / [::chan pending output $chan] / [::chan pending output $myself]} + set used [clock milliseconds] + ::chan puts -nonewline $chan $data + return [string length $data] + } + + method configure {myself option value} { + log::debug {[self] configure $myself $option -> $value} + + if {$option eq "-user"} { + set user $value + return + } + + ::chan configure $fd $option $value + return + } + + method cget {myself option} { + switch -- $option { + -self { return [self] } + -fd { return $chan } + -used { return $used } + -created { return $created } + -user { return $user } + default { + return [::chan configure $chan $option] + } + } + } + + method cgetall {myself} { + set result [::chan configure $chan] + lappend result \ + -self [self] \ + -fd $chan \ + -used $used \ + -created $created \ + -user $user + + log::debug {[self] cgetall $myself -> $result} + return $result + } + + # # ## ### ##### ######## ############# + + # Internals. Methods. Event generation. + method Readable {myself} { + log::debug {$myself readable $chan - [::chan pending input $chan]} + ::chan postevent $myself read + return + } + + method Writable {myself} { + log::debug {$myself writable $chan - [::chan pending output $chan]} + ::chan postevent $myself write + return + } + + method Callback {method args} { + list [uplevel 1 {namespace which my}] $method {*}$args + } + + # # ## ### ##### ######## ############# +} + +# # ## ### ##### ######## ############# +package provide tcl::chan::facade 1.0.2 +return diff --git a/src/bootsupport/lib/virtchannel_base/fifo.tcl b/src/bootsupport/lib/virtchannel_base/fifo.tcl new file mode 100644 index 00000000..5f04aafb --- /dev/null +++ b/src/bootsupport/lib/virtchannel_base/fifo.tcl @@ -0,0 +1,138 @@ +# -*- tcl -*- +# # ## ### ##### ######## ############# +# (C) 2009 Andreas Kupries + +# @@ Meta Begin +# Package tcl::chan::fifo 1.1 +# Meta as::author {Andreas Kupries} +# Meta as::copyright 2009 +# Meta as::license BSD +# Meta description Re-implementation of Memchan's fifo +# Meta description channel. Based on Tcl 8.5's channel +# Meta description reflection support. Exports a single +# Meta description command for the creation of new +# Meta description channels. No arguments. Result is the +# Meta description handle of the new channel. +# Meta platform tcl +# Meta require TclOO +# Meta require tcl::chan::events +# Meta require {Tcl 8.5} +# @@ Meta End +# # ## ### ##### ######## ############# + +package require Tcl 8.5 9 +package require TclOO +package require tcl::chan::events + +# # ## ### ##### ######## ############# + +namespace eval ::tcl::chan {} + +proc ::tcl::chan::fifo {} { + return [::chan create {read write} [fifo::implementation new]] +} + +oo::class create ::tcl::chan::fifo::implementation { + superclass ::tcl::chan::events ; # -> initialize, finalize, watch + + method initialize {args} { + my allow write + next {*}$args + } + + method read {c n} { + set max [string length $read] + set last [expr {$at + $n - 1}] + set result {} + + # last+1 <= max + # <=> at+n <= max + # <=> n <= max-at + + if {$n <= ($max - $at)} { + # The request is less than what we have left in the read + # buffer, we take it, and move the read pointer forward. + + append result [string range $read $at $last] + incr at $n + incr $size -$n + } else { + # We need the whole remaining read buffer, and more. For + # the latter we shift the write buffer contents over into + # the read buffer, and then read from the latter again. + + append result [string range $read $at end] + incr n -[string length $result] + + set at 0 + set read $write + set write {} + set size [string length $read] + set max $size + + # at == 0 + if {$n <= $max} { + # The request is less than what we have in the updated + # read buffer, we take it, and move the read pointer + # forward. + + append result [string range $read 0 $last] + set at $n + incr $size -$n + } else { + # We need the whole remaining read buffer, and + # more. As we took the data from write already we have + # nothing left, and update accordingly. + + append result $read + + set at 0 + set read {} + set size 0 + } + } + + my Readable + + if {$result eq {}} { + return -code error EAGAIN + } + + return $result + } + + method write {c bytes} { + append write $bytes + set n [string length $bytes] + incr size $n + my Readable + return $n + } + + # # ## ### ##### ######## ############# + + variable at read write size + + # # ## ### ##### ######## ############# + + constructor {} { + set at 0 + set read {} + set write {} + set size 0 + next + } + + method Readable {} { + if {$size} { + my allow read + } else { + my disallow read + } + return + } +} + +# # ## ### ##### ######## ############# +package provide tcl::chan::fifo 1.1 +return diff --git a/src/bootsupport/lib/virtchannel_base/fifo2.tcl b/src/bootsupport/lib/virtchannel_base/fifo2.tcl new file mode 100644 index 00000000..8de162e2 --- /dev/null +++ b/src/bootsupport/lib/virtchannel_base/fifo2.tcl @@ -0,0 +1,113 @@ +# -*- tcl -*- +# # ## ### ##### ######## ############# +# (C) 2009 Andreas Kupries + +# @@ Meta Begin +# Package tcl::chan::fifo2 1.1 +# Meta as::author {Andreas Kupries} +# Meta as::copyright 2009 +# Meta as::license BSD +# Meta as::notes This fifo2 command does not have to +# Meta as::notes deal with the pesky details of +# Meta as::notes threading for cross-thread +# Meta as::notes communication. That is hidden in the +# Meta as::notes implementation of reflected +# Meta as::notes channels. It is less optimal as the +# Meta as::notes command provided by Memchan as this +# Meta as::notes fifo2 may involve three threads when +# Meta as::notes sending data around: The threads the +# Meta as::notes two endpoints are in, and the thread +# Meta as::notes holding this code. Memchan's C +# Meta as::notes implementation does not need this last +# Meta as::notes intermediary thread. +# Meta description Re-implementation of Memchan's fifo2 +# Meta description channel. Based on Tcl 8.5's channel +# Meta description reflection support. Exports a single +# Meta description command for the creation of new +# Meta description channels. No arguments. Result are the +# Meta description handles of the two new channels. +# Meta platform tcl +# Meta require TclOO +# Meta require tcl::chan::halfpipe +# Meta require {Tcl 8.5} +# @@ Meta End +# # ## ### ##### ######## ############# + +package require Tcl 8.5 9 +package require TclOO +package require tcl::chan::halfpipe + +# # ## ### ##### ######## ############# + +namespace eval ::tcl::chan {} + +proc ::tcl::chan::fifo2 {} { + + set coordinator [fifo2::implementation new] + + lassign [halfpipe \ + -write-command [list $coordinator froma] \ + -close-command [list $coordinator closeda]] \ + a ha + + lassign [halfpipe \ + -write-command [list $coordinator fromb] \ + -close-command [list $coordinator closedb]] \ + b hb + + $coordinator connect $a $ha $b $hb + + return [list $a $b] +} + +oo::class create ::tcl::chan::fifo2::implementation { + method connect {thea theha theb thehb} { + set a $thea + set b $theb + set ha $theha + set hb $thehb + return + } + + method closeda {c} { + set a {} + if {$b ne {}} { + close $b + set b {} + } else { + my destroy + } + return + } + + method closedb {c} { + set b {} + if {$a ne {}} { + close $a + set a {} + } else { + my destroy + } + return + } + + method froma {c bytes} { + $hb put $bytes + return + } + + method fromb {c bytes} { + $ha put $bytes + return + } + + # # ## ### ##### ######## ############# + + variable a b ha hb + + # # ## ### ##### ######## ############# +} + +# # ## ### ##### ######## ############# +package provide tcl::chan::fifo2 1.1 +return diff --git a/src/bootsupport/lib/virtchannel_base/halfpipe.tcl b/src/bootsupport/lib/virtchannel_base/halfpipe.tcl new file mode 100644 index 00000000..845218e5 --- /dev/null +++ b/src/bootsupport/lib/virtchannel_base/halfpipe.tcl @@ -0,0 +1,194 @@ +# -*- tcl -*- +# # ## ### ##### ######## ############# +# (C) 2009, 2019 Andreas Kupries + +# @@ Meta Begin +# Package tcl::chan::halfpipe 1.0.3 +# Meta as::author {Andreas Kupries} +# Meta as::copyright 2009,2019 +# Meta as::license BSD +# Meta description Implementation of one half of a pipe +# Meta description channel. Based on Tcl 8.5's channel +# Meta description reflection support. Exports a single +# Meta description command for the creation of new +# Meta description channels. Option arguments. Result is the +# Meta description handle of the new channel, and the object +# Meta description command of the handler object. +# Meta platform tcl +# Meta require TclOO +# Meta require tcl::chan::events +# Meta require {Tcl 8.5} +# @@ Meta End +# # ## ### ##### ######## ############# + +package require Tcl 8.5 9 +package require TclOO +package require tcl::chan::events + +# # ## ### ##### ######## ############# + +namespace eval ::tcl::chan {} + +proc ::tcl::chan::halfpipe {args} { + set handler [halfpipe::implementation new {*}$args] + return [list [::chan create {read write} $handler] $handler] +} + +oo::class create ::tcl::chan::halfpipe::implementation { + superclass ::tcl::chan::events ; # -> initialize, finalize, watch + + method initialize {args} { + my allow write + set eof 0 + next {*}$args + } + + method finalize {c} { + my Call -close-command $c + next $c + } + + method read {c n} { + set max [string length $read] + set last [expr {$at + $n - 1}] + set result {} + + # last+1 <= max + # <=> at+n <= max + # <=> n <= max-at + + if {$n <= ($max - $at)} { + # There is enough data in the buffer to fill the request, so take + # it from there and move the read pointer forward. + + append result [string range $read $at $last] + incr at $n + incr $size -$n + } else { + # We need the whole remaining read buffer, and more. For + # the latter we make the write buffer the new read buffer, + # and then read from it again. + + append result [string range $read $at end] + incr n -[string length $result] + + set at 0 + set last [expr {$n - 1}] + set read $write + set write {} + set size [string length $read] + set max $size + + # at == 0 simplifies expressions + if {$n <= $max} { + # The request is less than what we have in the new + # read buffer, we take it, and move the read pointer + # forward. + + append result [string range $read 0 $last] + set at $n + incr $size -$n + } else { + # We need the whole remaining read buffer, and + # more. As we took the data from write already we have + # nothing left, and update accordingly. + + append result $read + + set at 0 + set read {} + set size 0 + } + } + my Readable + if {$result eq {} && !$eof} { + return -code error EAGAIN + } + return $result + } + + method write {c bytes} { + my Call -write-command $c $bytes + return [string length $bytes] + } + + # # ## ### ##### ######## ############# + + method put bytes { + append write $bytes + set n [string length $bytes] + if {$n == 0} { + my variable eof + set eof 1 + } else { + incr size $n + } + my Readable + return $n + } + + # # ## ### ##### ######## ############# + + variable at eof read write size options + # at : first location in read buffer not yet read + # eof : indicates whether the end of the data has been reached + # read : read buffer + # write : buffer for received data, i.e. + # written into the halfpipe from + # the other side. + # size : combined length of receive and read buffers + # == amount of stored data + # options : configuration array + + # The halpipe uses a pointer (`at`) into the data buffer to + # extract the characters read by the user, while not shifting the + # data down in memory. Doing such a shift would cause a large + # performance hit (O(n**2) operation vs O(n)). This however comes + # with the danger of the buffer growing out of bounds as ever more + # data is appended by the receiver while the reader is not + # catching up, preventing a release. The solution to this in turn + # is to split the buffer into two. An append-only receive buffer + # (`write`) for incoming data, and a `read` buffer with the + # pointer. When the current read buffer is entirely consumed the + # current receive buffer becomes the new read buffer and a new + # empty receive buffer is started. + + # # ## ### ##### ######## ############# + + constructor {args} { + array set options { + -write-command {} + -empty-command {} + -close-command {} + } + # todo: validity checking of options (legal names, legal + # values, etc.) + array set options $args + set at 0 + set read {} + set write {} + set size 0 + next + } + + method Readable {} { + if {$size || $eof} { + my allow read + } else { + my variable channel + my disallow read + my Call -empty-command $channel + } + return + } + + method Call {o args} { + if {![llength $options($o)]} return + uplevel \#0 [list {*}$options($o) {*}$args] + return + } +} + +# # ## ### ##### ######## ############# +package provide tcl::chan::halfpipe 1.0.3 +return diff --git a/src/bootsupport/lib/virtchannel_base/memchan.tcl b/src/bootsupport/lib/virtchannel_base/memchan.tcl new file mode 100644 index 00000000..76ef0b64 --- /dev/null +++ b/src/bootsupport/lib/virtchannel_base/memchan.tcl @@ -0,0 +1,173 @@ +# -*- tcl -*- +# # ## ### ##### ######## ############# +# (C) 2009 Andreas Kupries + +# Variable string channel (in-memory r/w file, internal variable). +# Seekable beyond the end of the data, implies appending of 0x00 +# bytes. + +# @@ Meta Begin +# Package tcl::chan::memchan 1.0.5 +# Meta as::author {Andreas Kupries} +# Meta as::copyright 2009 +# Meta as::license BSD +# Meta description Re-implementation of Memchan's memchan +# Meta description channel. Based on Tcl 8.5's channel +# Meta description reflection support. Exports a single +# Meta description command for the creation of new +# Meta description channels. No arguments. Result is the +# Meta description handle of the new channel. Essentially +# Meta description an in-memory read/write random-access +# Meta description file. Similar to -> tcl::chan::variable, +# Meta description except the content variable is internal, +# Meta description part of the channel. Further similar to +# Meta description -> tcl::chan::string, except that the +# Meta description content is here writable, and +# Meta description extendable. +# Meta platform tcl +# Meta require TclOO +# Meta require tcl::chan::events +# Meta require {Tcl 8.5} +# @@ Meta End + +# # ## ### ##### ######## ############# + +package require Tcl 8.5 9 +try { + package require tcl::oo +} trap {TCL PACKAGE UNFOUND} {tres topts} { + package require TclOO +} +package require tcl::chan::events + +# # ## ### ##### ######## ############# + +namespace eval ::tcl::chan {} + +proc ::tcl::chan::memchan {} { + return [::chan create {read write} [memchan::implementation new]] +} + +oo::class create ::tcl::chan::memchan::implementation { + superclass ::tcl::chan::events ; # -> initialize, finalize, watch + + constructor {} { + set content {} + set at 0 + next + } + + method initialize {args} { + my allow write + my Events + next {*}$args + } + + variable content at + + method read {c n} { + # First determine the location of the last byte to read, + # relative to the current location, and limited by the maximum + # location we are allowed to access per the size of the + # content. + + set last [expr {min($at + $n,[string length $content])-1}] + + # Then extract the relevant range from the content, move the + # seek location behind it, and return the extracted range. Not + # to forget, switch readable events based on the seek + # location. + + set res [string range $content $at $last] + set at $last + incr at + + my Events + return $res + } + + method write {c newbytes} { + # Return immediately if there is nothing is to write. + set n [string length $newbytes] + if {$n == 0} { + return $n + } + + # Determine where and how to write. There are three possible cases. + # (1) Append at/after the end. + # (2) Starting in the middle, but extending beyond the end. + # (3) Replace in the middle. + + set max [string length $content] + if {$at >= $max} { + # Ad 1. + append content $newbytes + set at [string length $content] + } else { + set last [expr {$at + $n - 1}] + if {$last >= $max} { + # Ad 2. + set content [string replace $content $at end $newbytes] + set at [string length $content] + } else { + # Ad 3. + set content [string replace $content $at $last $newbytes] + set at $last + incr at + } + } + + my Events + return $n + } + + method seek {c offset base} { + # offset == 0 && base == current + # <=> Seek nothing relative to current + # <=> Report current location. + + if {!$offset && ($base eq "current")} { + return $at + } + + # Compute the new location per the arguments. + + set max [string length $content] + switch -exact -- $base { + start { set newloc $offset} + current { set newloc [expr {$at + $offset }] } + end { set newloc [expr {$max + $offset }] } + } + + # Check if the new location is beyond the range given by the + # content. + + if {$newloc < 0} { + return -code error "Cannot seek before the start of the channel" + } elseif {$newloc > $max} { + # We can seek beyond the end of the current contents, add + # a block of zeros. + #puts XXX.PAD.[expr {$newloc - $max}] + append content [binary format @[expr {$newloc - $max}]] + } + + # Commit to new location, switch readable events, and report. + set at $newloc + + my Events + return $at + } + + method Events {} { + # Always readable -- Even if the seek location is at the end + # (or beyond). In that case the readable events are fired + # endlessly until the eof indicated by the seek location is + # properly processed by the event handler. Like for regular + # files -- Ticket [864a0c83e3]. + my allow read + } +} + +# # ## ### ##### ######## ############# +package provide tcl::chan::memchan 1.0.5 +return diff --git a/src/bootsupport/lib/virtchannel_base/null.tcl b/src/bootsupport/lib/virtchannel_base/null.tcl new file mode 100644 index 00000000..da9d7348 --- /dev/null +++ b/src/bootsupport/lib/virtchannel_base/null.tcl @@ -0,0 +1,54 @@ +# -*- tcl -*- +# # ## ### ##### ######## ############# +# (C) 2009 Andreas Kupries + +# @@ Meta Begin +# Package tcl::chan::null 1.1 +# Meta as::author {Andreas Kupries} +# Meta as::copyright 2009 +# Meta as::license BSD +# Meta description Re-implementation of Memchan's null +# Meta description channel. Based on Tcl 8.5's channel +# Meta description reflection support. Exports a single +# Meta description command for the creation of new +# Meta description channels. No arguments. Result is the +# Meta description handle of the new channel. +# Meta platform tcl +# Meta require TclOO +# Meta require tcl::chan::events +# Meta require {Tcl 8.5} +# @@ Meta End + +# # ## ### ##### ######## ############# + +package require Tcl 8.5 9 +package require TclOO +package require tcl::chan::events + +# # ## ### ##### ######## ############# + +namespace eval ::tcl::chan {} + +proc ::tcl::chan::null {} { + return [::chan create {write} [null::implementation new]] +} + +oo::class create ::tcl::chan::null::implementation { + superclass ::tcl::chan::events ; # -> initialize, finalize, watch + + method initialize {args} { + my allow write + next {*}$args + } + + # Ignore the data in most particulars. We do count it so that we + # can tell the caller that everything was written. Null device. + + method write {c data} { + return [string length $data] + } +} + +# # ## ### ##### ######## ############# +package provide tcl::chan::null 1.1 +return diff --git a/src/bootsupport/lib/virtchannel_base/nullzero.tcl b/src/bootsupport/lib/virtchannel_base/nullzero.tcl new file mode 100644 index 00000000..c217657a --- /dev/null +++ b/src/bootsupport/lib/virtchannel_base/nullzero.tcl @@ -0,0 +1,62 @@ +# -*- tcl -*- +# # ## ### ##### ######## ############# +# (C) 2009 Andreas Kupries + +# @@ Meta Begin +# Package tcl::chan::nullzero 1.1 +# Meta as::author {Andreas Kupries} +# Meta as::copyright 2009 +# Meta as::license BSD +# Meta description Implementation of a channel combining +# Meta description Memchan's null and zero channels in a +# Meta description single device. Based on Tcl 8.5's channel +# Meta description reflection support. Exports a single +# Meta description command for the creation of new +# Meta description channels. No arguments. Result is the +# Meta description handle of the new channel. +# Meta platform tcl +# Meta require TclOO +# Meta require tcl::chan::events +# Meta require {Tcl 8.5} +# @@ Meta End + +# # ## ### ##### ######## ############# + +package require Tcl 8.5 9 +package require TclOO +package require tcl::chan::events + +# # ## ### ##### ######## ############# + +namespace eval ::tcl::chan {} + +proc ::tcl::chan::nullzero {} { + return [::chan create {read write} [nullzero::implementation new]] +} + +oo::class create ::tcl::chan::nullzero::implementation { + superclass ::tcl::chan::events ; # -> initialize, finalize, watch + + method initialize {args} { + my allow read write + next {*}$args + } + + # Ignore the data in most particulars. We do count it so that we + # can tell the caller that everything was written. Null device. + + method write {c data} { + return [string length $data] + } + + # Generate and return a block of N null bytes, as requested. Zero + # device. + + method read {c n} { + return [binary format @$n] + } +} + +# # ## ### ##### ######## ############# +package provide tcl::chan::nullzero 1.1 +return diff --git a/src/bootsupport/lib/virtchannel_base/pkgIndex.tcl b/src/bootsupport/lib/virtchannel_base/pkgIndex.tcl new file mode 100644 index 00000000..c8431a2b --- /dev/null +++ b/src/bootsupport/lib/virtchannel_base/pkgIndex.tcl @@ -0,0 +1,17 @@ +if {![package vsatisfies [package provide Tcl] 8.5 9]} {return} + +package ifneeded tcl::chan::cat 1.0.4 [list source [file join $dir cat.tcl]] +package ifneeded tcl::chan::facade 1.0.2 [list source [file join $dir facade.tcl]] +package ifneeded tcl::chan::fifo 1.1 [list source [file join $dir fifo.tcl]] +package ifneeded tcl::chan::fifo2 1.1 [list source [file join $dir fifo2.tcl]] +package ifneeded tcl::chan::halfpipe 1.0.3 [list source [file join $dir halfpipe.tcl]] +package ifneeded tcl::chan::memchan 1.0.5 [list source [file join $dir memchan.tcl]] +package ifneeded tcl::chan::null 1.1 [list source [file join $dir null.tcl]] +package ifneeded tcl::chan::nullzero 1.1 [list source [file join $dir nullzero.tcl]] +package ifneeded tcl::chan::random 1.1 [list source [file join $dir random.tcl]] +package ifneeded tcl::chan::std 1.0.2 [list source [file join $dir std.tcl]] +package ifneeded tcl::chan::string 1.0.4 [list source [file join $dir string.tcl]] +package ifneeded tcl::chan::textwindow 1.1 [list source [file join $dir textwindow.tcl]] +package ifneeded tcl::chan::variable 1.0.5 [list source [file join $dir variable.tcl]] +package ifneeded tcl::chan::zero 1.1 [list source [file join $dir zero.tcl]] +package ifneeded tcl::randomseed 1.1 [list source [file join $dir randseed.tcl]] diff --git a/src/bootsupport/lib/virtchannel_base/random.tcl b/src/bootsupport/lib/virtchannel_base/random.tcl new file mode 100644 index 00000000..c1778b8a --- /dev/null +++ b/src/bootsupport/lib/virtchannel_base/random.tcl @@ -0,0 +1,80 @@ +# -*- tcl -*- +# # ## ### ##### ######## ############# +# (C) 2009 Andreas Kupries + +# @@ Meta Begin +# Package tcl::chan::random 1.1 +# Meta as::author {Andreas Kupries} +# Meta as::copyright 2009 +# Meta as::license BSD +# Meta description Implementation of a channel similar to +# Meta description Memchan's random channel. Based on Tcl +# Meta description 8.5's channel reflection support. Exports +# Meta description a single command for the creation of new +# Meta description channels. One argument, a list of +# Meta description numbers to initialize the feedback +# Meta description register of the internal random number +# Meta description generator. Result is the handle of the +# Meta description new channel. +# Meta platform tcl +# Meta require TclOO +# Meta require tcl::chan::events +# Meta require {Tcl 8.5} +# @@ Meta End + +# # ## ### ##### ######## ############# + +package require tcl::chan::events +package require Tcl 8.5 9 +package require TclOO + +# # ## ### ##### ######## ############# + +namespace eval ::tcl::chan {} + +proc ::tcl::chan::random {seed} { + return [::chan create {read} [random::implementation new $seed]] +} + +oo::class create ::tcl::chan::random::implementation { + superclass tcl::chan::events ; # -> initialize, finalize, watch + + constructor {theseed} { + my variable seed next + set seed $theseed + set next [expr "([join $seed +]) & 0xff"] + next + } + + method initialize {args} { + my allow read + next {*}$args + } + + # Generate and return a block of N randomly selected bytes, as + # requested. Random device. + + method read {c n} { + set buffer {} + while {$n} { + append buffer [binary format c [my Next]] + incr n -1 + } + return $buffer + } + + variable seed + variable next + + method Next {} { + my variable seed next + set result $next + set next [expr {(2*$next - [lindex $seed 0]) & 0xff}] + set seed [linsert [lrange $seed 1 end] end $result] + return $result + } +} + +# # ## ### ##### ######## ############# +package provide tcl::chan::random 1.1 +return diff --git a/src/bootsupport/lib/virtchannel_base/randseed.tcl b/src/bootsupport/lib/virtchannel_base/randseed.tcl new file mode 100644 index 00000000..5e0cbed6 --- /dev/null +++ b/src/bootsupport/lib/virtchannel_base/randseed.tcl @@ -0,0 +1,58 @@ +# -*- tcl -*- +# # ## ### ##### ######## ############# +# (C) 2009 Andreas Kupries + +# @@ Meta Begin +# Package tcl::randomseed 1.1 +# Meta as::author {Andreas Kupries} +# Meta as::copyright 2009 +# Meta as::license BSD +# Meta description Generate and combine seed lists for the +# Meta description random number generator inside of the +# Meta description tcl::chan::random channel. Sources of +# Meta description randomness are process id, time in two +# Meta description granularities, and Tcl's random number +# Meta description generator. +# Meta platform tcl +# Meta require {Tcl 8.5} +# @@ Meta End + +# # ## ### ##### ######## ############# + +package require Tcl 8.5 9 + +# # ## ### ##### ######## ############# + +namespace eval ::tcl {} + +proc ::tcl::randomseed {} { + set result {} + foreach v [list \ + [pid] \ + [clock seconds] \ + [expr {int(256*rand())}] \ + [clock clicks -milliseconds]] \ + { + lappend result [expr {$v % 256}] + } + return $result +} + +proc ::tcl::combine {a b} { + while {[llength $a] < [llength $b]} { + lappend a 0 + } + while {[llength $b] < [llength $a]} { + lappend b 0 + } + + set result {} + foreach x $a y $b { + lappend result [expr {($x ^ $y) % 256}] + } + return $result +} + +# # ## ### ##### ######## ############# +package provide tcl::randomseed 1.1 +return diff --git a/src/bootsupport/lib/virtchannel_base/std.tcl b/src/bootsupport/lib/virtchannel_base/std.tcl new file mode 100644 index 00000000..24927e30 --- /dev/null +++ b/src/bootsupport/lib/virtchannel_base/std.tcl @@ -0,0 +1,97 @@ +# -*- tcl -*- +# # ## ### ##### ######## ############# +# (C) 2011 Andreas Kupries + +# Facade wrapping the separate channels for stdin and stdout into a +# single read/write channel for all regular standard i/o. Not +# seekable. Fileevent handling is propagated to the regular channels +# the facade wrapped about. Only one instance of the class is +# ever created. + +# @@ Meta Begin +# Package tcl::chan::std 1.0.2 +# Meta as::author {Andreas Kupries} +# Meta as::copyright 2011 +# Meta as::license BSD +# Meta description Facade wrapping the separate channels for stdin +# Meta description and stdout into a single read/write channel for +# Meta description all regular standard i/o. Not seekable. Only one +# Meta description instance of the class is ever created. +# Meta platform tcl +# Meta require TclOO +# Meta require tcl::chan::core +# Meta require {Tcl 8.5} +# @@ Meta End + +# # ## ### ##### ######## ############# + +package require Tcl 8.5 9 +package require TclOO +package require tcl::chan::core + +# # ## ### ##### ######## ############# + +namespace eval ::tcl::chan {} + +proc ::tcl::chan::std {} { + ::variable std + if {$std eq {}} { + set std [::chan create {read write} [std::implementation new]] + } + return $std +} + +oo::class create ::tcl::chan::std::implementation { + superclass ::tcl::chan::core ; # -> initialize, finalize. + + # We are not using the standard event handling class, because here + # it will not be timer-driven. We propagate anything related to + # events to stdin and stdout instead and let them handle things. + + constructor {} { + # Disable encoding and translation processing in the wrapped channels. + # This will happen in our generic layer instead. + fconfigure stdin -translation binary + fconfigure stdout -translation binary + return + } + + method watch {c requestmask} { + + if {"read" in $requestmask} { + fileevent readable stdin [list chan postevent $c read] + } else { + fileevent readable stdin {} + } + + if {"write" in $requestmask} { + fileevent readable stdin [list chan postevent $c write] + } else { + fileevent readable stdout {} + } + + return + } + + method read {c n} { + # Read is redirected to stdin. + return [::read stdin $n] + } + + method write {c newbytes} { + # Write is redirected to stdout. + puts -nonewline stdout $newbytes + flush stdout + return [string length $newbytes] + } +} + +# # ## ### ##### ######## ############# + +namespace eval ::tcl::chan { + ::variable std {} +} + +# # ## ### ##### ######## ############# +package provide tcl::chan::std 1.0.2 +return diff --git a/src/bootsupport/lib/virtchannel_base/string.tcl b/src/bootsupport/lib/virtchannel_base/string.tcl new file mode 100644 index 00000000..b3b3f85c --- /dev/null +++ b/src/bootsupport/lib/virtchannel_base/string.tcl @@ -0,0 +1,126 @@ +# -*- tcl -*- +# # ## ### ##### ######## ############# +# (C) 2009 Andreas Kupries + +# @@ Meta Begin +# Package tcl::chan::string 1.0.4 +# Meta as::author {Andreas Kupries} +# Meta as::copyright 2009 +# Meta as::license BSD +# Meta description Implementation of a channel representing +# Meta description an in-memory read-only random-access +# Meta description file. Based on using Tcl 8.5's channel +# Meta description reflection support. Exports a single +# Meta description command for the creation of new channels. +# Meta description One argument, the contents of the file. +# Meta description Result is the handle of the new channel. +# Meta description Similar to -> tcl::chan::memchan, except +# Meta description that the content is read-only. Seekable +# Meta description only within the bounds of the content. +# Meta platform tcl +# Meta require TclOO +# Meta require tcl::chan::events +# Meta require {Tcl 8.5} +# @@ Meta End + +# # ## ### ##### ######## ############# + +package require Tcl 8.5 9 +if {[catch {package require tcl::oo}]} { + package require TclOO +} +package require tcl::chan::events + +# # ## ### ##### ######## ############# + +namespace eval ::tcl::chan {} + +proc ::tcl::chan::string {content} { + return [::chan create {read} [string::implementation new $content]] +} + +oo::class create ::tcl::chan::string::implementation { + superclass ::tcl::chan::events ; # -> initialize, finalize, watch + + constructor {thecontent} { + set content $thecontent + set at 0 + next + } + + method initialize {args} { + my Events + next {*}$args + } + + variable content at + + method read {c n} { + + # First determine the location of the last byte to read, + # relative to the current location, and limited by the maximum + # location we are allowed to access per the size of the + # content. + + set last [expr {min($at + $n,[string length $content])-1}] + + # Then extract the relevant range from the content, move the + # seek location behind it, and return the extracted range. Not + # to forget, switch readable events based on the seek + # location. + + set res [string range $content $at $last] + set at $last + incr at + + my Events + return $res + } + + method seek {c offset base} { + # offset == 0 && base == current + # <=> Seek nothing relative to current + # <=> Report current location. + + if {!$offset && ($base eq "current")} { + return $at + } + + # Compute the new location per the arguments. + + set max [string length $content] + switch -exact -- $base { + start { set newloc $offset} + current { set newloc [expr {$at + $offset }] } + end { set newloc [expr {$max + $offset }] } + } + + # Check if the new location is beyond the range given by the + # content. + + if {$newloc < 0} { + return -code error "Cannot seek before the start of the channel" + } elseif {$newloc > $max} { + return -code error "Cannot seek after the end of the channel" + } + + # Commit to new location, switch readable events, and report. + set at $newloc + + my Events + return $at + } + + method Events {} { + # Always readable -- Even if the seek location is at the end + # (or beyond). In that case the readable events are fired + # endlessly until the eof indicated by the seek location is + # properly processed by the event handler. Like for regular + # files -- Ticket [864a0c83e3]. + my allow read + } +} + +# # ## ### ##### ######## ############# +package provide tcl::chan::string 1.0.4 +return diff --git a/src/bootsupport/lib/virtchannel_base/textwindow.tcl b/src/bootsupport/lib/virtchannel_base/textwindow.tcl new file mode 100644 index 00000000..4e23a37a --- /dev/null +++ b/src/bootsupport/lib/virtchannel_base/textwindow.tcl @@ -0,0 +1,74 @@ +# -*- tcl -*- +# # ## ### ##### ######## ############# +# (C) 2009 Andreas Kupries + +# @@ Meta Begin +# Package tcl::chan::textwindow 1.1 +# Meta as::author {Andreas Kupries} +# Meta as::copyright 2009 +# Meta as::license BSD +# Meta as::credit To Bryan Oakley for rotext, see +# Meta as::credit http://wiki.tcl.tk/22036. His code was +# Meta as::credit used here as template for the text +# Meta as::credit widget portions of the channel. +# Meta description Implementation of a text window +# Meta description channel, using Tcl 8.5's channel +# Meta description reflection support. Exports a single +# Meta description command for the creation of new +# Meta description channels. No arguments. Result is the +# Meta description handle of the new channel. +# Meta platform tcl +# Meta require TclOO +# Meta require tcl::chan::events +# Meta require {Tcl 8.5} +# @@ Meta End + +# # ## ### ##### ######## ############# + +package require Tcl 8.5 9 +package require TclOO +package require tcl::chan::events + +# # ## ### ##### ######## ############# + +namespace eval ::tcl::chan {} + +proc ::tcl::chan::textwindow {w} { + set chan [::chan create {write} [textwindow::implementation new $w]] + fconfigure $chan -encoding utf-8 -buffering none + return $chan +} + +oo::class create ::tcl::chan::textwindow::implementation { + superclass ::tcl::chan::events ; # -> initialize, finalize, watch + + constructor {w} { + set widget $w + next + } + + # # ## ### ##### ######## ############# + + variable widget + + # # ## ### ##### ######## ############# + + method initialize {args} { + my allow write + next {*}$args + } + + method write {c data} { + # NOTE: How is encoding convertfrom dealing with a partial + # utf-8 character at the end of the buffer ? Should be saved + # up for the next buffer. No idea if we can. + + $widget insert end [encoding convertfrom utf-8 $data] + $widget see end + return [string length $data] + } +} + +# # ## ### ##### ######## ############# +package provide tcl::chan::textwindow 1.1 +return diff --git a/src/bootsupport/lib/virtchannel_base/variable.tcl b/src/bootsupport/lib/virtchannel_base/variable.tcl new file mode 100644 index 00000000..0c65a376 --- /dev/null +++ b/src/bootsupport/lib/virtchannel_base/variable.tcl @@ -0,0 +1,181 @@ +# -*- tcl -*- +# # ## ### ##### ######## ############# +# (C) 2009 Andreas Kupries + +# @@ Meta Begin +# Package tcl::chan::variable 1.0.5 +# Meta as::author {Andreas Kupries} +# Meta as::copyright 2009 +# Meta as::license BSD +# Meta description Implementation of a channel representing +# Meta description an in-memory read-write random-access +# Meta description file. Based on Tcl 8.5's channel reflection +# Meta description support. Exports a single command for the +# Meta description creation of new channels. No arguments. +# Meta description Result is the handle of the new channel. +# Meta description Similar to -> tcl::chan::memchan, except +# Meta description that the variable holding the content +# Meta description exists outside of the channel itself, in +# Meta description some namespace, and as such is not a part +# Meta description of the channel. Seekable beyond the end +# Meta description of the data, implies appending of 0x00 +# Meta description bytes. +# Meta platform tcl +# Meta require TclOO +# Meta require tcl::chan::events +# Meta require {Tcl 8.5} +# @@ Meta End + +# # ## ### ##### ######## ############# + +package require Tcl 8.5 9 +package require TclOO +package require tcl::chan::events + +# # ## ### ##### ######## ############# + +namespace eval ::tcl::chan {} + +proc ::tcl::chan::variable {varname} { + return [::chan create {read write} [variable::implementation new $varname]] +} + +oo::class create ::tcl::chan::variable::implementation { + superclass ::tcl::chan::events ; # -> initialize, finalize, watch + + constructor {thevarname} { + set varname $thevarname + set at 0 + + upvar #0 $varname content + if {![info exists content]} { + set content {} + } + next + } + + method initialize {args} { + my allow write + my Events + next {*}$args + } + + variable varname at + + method read {c n} { + # Bring connected variable for content into scope. + + upvar #0 $varname content + + # First determine the location of the last byte to read, + # relative to the current location, and limited by the maximum + # location we are allowed to access per the size of the + # content. + + set last [expr {min($at + $n,[string length $content])-1}] + + # Then extract the relevant range from the content, move the + # seek location behind it, and return the extracted range. Not + # to forget, switch readable events based on the seek + # location. + + set res [string range $content $at $last] + set at $last + incr at + + my Events + return $res + } + + method write {c newbytes} { + # Bring connected variable for content into scope. + + upvar #0 $varname content + + # Return immediately if there is nothing is to write. + set n [string length $newbytes] + if {$n == 0} { + return $n + } + + # Determine where and how to write. There are three possible cases. + # (1) Append at/after the end. + # (2) Starting in the middle, but extending beyond the end. + # (3) Replace in the middle. + + set max [string length $content] + if {$at >= $max} { + # Ad 1. + append content $newbytes + set at [string length $content] + } else { + set last [expr {$at + $n - 1}] + if {$last >= $max} { + # Ad 2. + set content [string replace $content $at end $newbytes] + set at [string length $content] + } else { + # Ad 3. + set content [string replace $content $at $last $newbytes] + set at $last + incr at + } + } + + my Events + return $n + } + + method seek {c offset base} { + # offset == 0 && base == current + # <=> Seek nothing relative to current + # <=> Report current location. + + if {!$offset && ($base eq "current")} { + return $at + } + + # Bring connected variable for content into scope. + + upvar #0 $varname content + + # Compute the new location per the arguments. + + set max [string length $content] + switch -exact -- $base { + start { set newloc $offset} + current { set newloc [expr {$at + $offset }] } + end { set newloc [expr {$max + $offset }] } + } + + # Check if the new location is beyond the range given by the + # content. + + if {$newloc < 0} { + return -code error "Cannot seek before the start of the channel" + } elseif {$newloc > $max} { + # We can seek beyond the end of the current contents, add + # a block of zeros. + append content [binary format @[expr {$newloc - $max}]] + } + + # Commit to new location, switch readable events, and report. + set at $newloc + + my Events + return $at + } + + method Events {} { + # Always readable -- Even if the seek location is at the end + # (or beyond). In that case the readable events are fired + # endlessly until the eof indicated by the seek location is + # properly processed by the event handler. Like for regular + # files -- Ticket [864a0c83e3]. + my allow read + } +} + +# # ## ### ##### ######## ############# +package provide tcl::chan::variable 1.0.5 +return diff --git a/src/bootsupport/lib/virtchannel_base/zero.tcl b/src/bootsupport/lib/virtchannel_base/zero.tcl new file mode 100644 index 00000000..752e109e --- /dev/null +++ b/src/bootsupport/lib/virtchannel_base/zero.tcl @@ -0,0 +1,54 @@ +# -*- tcl -*- +# # ## ### ##### ######## ############# +# (C) 2009 Andreas Kupries + +# @@ Meta Begin +# Package tcl::chan::zero 1.1 +# Meta as::author {Andreas Kupries} +# Meta as::copyright 2009 +# Meta as::license BSD +# Meta description Re-implementation of Memchan's zero +# Meta description channel. Based on Tcl 8.5's channel +# Meta description reflection support. Exports a single +# Meta description command for the creation of new +# Meta description channels. No arguments. Result is the +# Meta description handle of the new channel. +# Meta platform tcl +# Meta require TclOO +# Meta require tcl::chan::events +# Meta require {Tcl 8.5} +# @@ Meta End + +# # ## ### ##### ######## ############# + +package require Tcl 8.5 9 +package require TclOO +package require tcl::chan::events + +# # ## ### ##### ######## ############# + +namespace eval ::tcl::chan {} + +proc ::tcl::chan::zero {} { + return [::chan create {read} [zero::implementation new]] +} + +oo::class create ::tcl::chan::zero::implementation { + superclass tcl::chan::events ; # -> initialize, finalize, watch + + method initialize {args} { + my allow read + next {*}$args + } + + # Generate and return a block of N null bytes, as requested. + # Zero device. + + method read {c n} { + return [binary format @$n] + } +} + +# # ## ### ##### ######## ############# +package provide tcl::chan::zero 1.1 +return diff --git a/src/bootsupport/lib/virtchannel_core/core.tcl b/src/bootsupport/lib/virtchannel_core/core.tcl new file mode 100644 index 00000000..a54892ef --- /dev/null +++ b/src/bootsupport/lib/virtchannel_core/core.tcl @@ -0,0 +1,75 @@ +# -*- tcl -*- +# # ## ### ##### ######## ############# +# (C) 2009 Andreas Kupries + +# @@ Meta Begin +# Package tcl::chan::core 1.1 +# Meta as::author {Andreas Kupries} +# Meta as::copyright 2009 +# Meta as::license BSD +# Meta description Support package handling a core +# Meta description aspect of reflected base channels +# Meta description (initialization, finalization). +# Meta description It is expected that this class +# Meta description is used as either one superclass of the +# Meta description class C for a specific channel, or is +# Meta description mixed into C. +# Meta platform tcl +# Meta require TclOO +# Meta require {Tcl 8.5} +# @@ Meta End + +# # ## ### ##### ######## ############# + +package require Tcl 8.5 9 +if {[catch {package require tcl::oo}]} { + package require TclOO +} + +# # ## ### ##### ######## ############# + +oo::class create ::tcl::chan::core { + destructor { + if {$channel eq {}} return + close $channel + return + } + + # # ## ### ##### ######## ############# + + method initialize {thechannel mode} { + set methods [info object methods [self] -all] + + # Note: Checking of the mode against the supported methods is + # done by the caller. + + set channel $thechannel + set supported {} + foreach m { + initialize finalize watch read write seek configure cget + cgetall blocking + } { + if {$m in $methods} { + lappend supported $m + } + } + return $supported + } + + method finalize {c} { + set channel {} ; # Prevent destroctor from calling close. + my destroy + return + } + + # # ## ### ##### ######## ############# + + variable channel + + # channel The channel the handler belongs to. + # # ## ### ##### ######## ############# +} + +# # ## ### ##### +package provide tcl::chan::core 1.1 +return diff --git a/src/bootsupport/lib/virtchannel_core/events.tcl b/src/bootsupport/lib/virtchannel_core/events.tcl new file mode 100644 index 00000000..6a7efc57 --- /dev/null +++ b/src/bootsupport/lib/virtchannel_core/events.tcl @@ -0,0 +1,156 @@ +# -*- tcl -*- +# # ## ### ##### ######## ############# +# (C) 2009 Andreas Kupries + +# @@ Meta Begin +# Package tcl::chan::events 1.1 +# Meta as::author {Andreas Kupries} +# Meta as::copyright 2009 +# Meta as::license BSD +# Meta description Support package handling a core +# Meta description aspect of reflected base channels +# Meta description (timer +# Meta description driven file event support). Controls a +# Meta description timer generating the expected read/write +# Meta description events. It is expected that this class +# Meta description is used as either one superclass of the +# Meta description class C for a specific channel, or is +# Meta description mixed into C. +# Meta platform tcl +# Meta require tcl::chan::core +# Meta require TclOO +# Meta require {Tcl 8.5} +# @@ Meta End + +# TODO :: set/get accessor methods for the timer delay + +# # ## ### ##### ######## ############# + +package require Tcl 8.5 9 +if {[catch {package require tcl::oo}]} { + package require TclOO +} +package require tcl::chan::core + +# # ## ### ##### ######## ############# + +oo::class create ::tcl::chan::events { + superclass ::tcl::chan::core ; # -> initialize, finalize, destructor + + constructor {} { + array set allowed { + read 0 + write 0 + } + set requested {} + set delay 10 + return + } + + # # ## ### ##### ######## ############# + + method finalize {c} { + my disallow read write + next $c + } + + # Allow/disallow the posting of events based on the + # events requested by Tcl's IO system, and the mask of + # events the instance's channel can handle, per all + # preceding calls of allow and disallow. + + method watch {c requestmask} { + if {$requestmask eq $requested} return + set requested $requestmask + my Update + return + } + + # # ## ### ##### ######## ############# + + # Declare that the named events are handled by the + # channel. This may start a timer to periodically post + # these events to the instance's channel. + + method allow {args} { + my Allowance $args yes + return + } + + # Declare that the named events are not handled by the + # channel. This may stop the periodic posting of events + # to the instance's channel. + + method disallow {args} { + my Allowance $args no + return + } + + # # ## ### ##### ######## ############# + + # Event System State - Timer driven + + variable timer allowed requested posting delay + + # channel = The channel to post events to - provided by superclass + # timer = Timer controlling the posting. + # allowed = Set of events allowed to post. + # requested = Set of events requested by core. + # posting = Set of events we are posting. + # delay = Millisec interval between posts. + + # 'allowed' is an Array (event name -> boolean). The + # value is true if the named event is allowed to be + # posted. + + # Common code used by both allow and disallow to enter + # the state change. + + method Allowance {events enable} { + set changed no + foreach event $events { + if {$allowed($event) == $enable} continue + set allowed($event) $enable + set changed yes + } + if {!$changed} return + my Update + return + } + + # Merge the current event allowance and the set of + # requested events into one datum, the set of events to + # post. From that then derive whether we need a timer or + # not and act accordingly. + + method Update {} { + catch { after cancel $timer } + set posting {} + foreach event $requested { + if {!$allowed($event)} continue + lappend posting $event + } + if {[llength $posting]} { + set timer [after $delay \ + [namespace code [list my Post]]] + } else { + catch { unset timer } + } + return + } + + # Post the current set of events, then reschedule to + # make this periodic. + + method Post {} { + my variable channel + set timer [after $delay \ + [namespace code [list my Post]]] + chan postevent $channel $posting + return + } +} + +# # ## ### ##### +package provide tcl::chan::events 1.1 +return diff --git a/src/bootsupport/lib/virtchannel_core/pkgIndex.tcl b/src/bootsupport/lib/virtchannel_core/pkgIndex.tcl new file mode 100644 index 00000000..300eb278 --- /dev/null +++ b/src/bootsupport/lib/virtchannel_core/pkgIndex.tcl @@ -0,0 +1,8 @@ +if {![package vsatisfies [package provide Tcl] 8.5 9]} {return} + +package ifneeded tcl::chan::core 1.1 [list source [file join $dir core.tcl]] +package ifneeded tcl::chan::events 1.1 [list source [file join $dir events.tcl]] + +if {![package vsatisfies [package provide Tcl] 8.6 9]} {return} + +package ifneeded tcl::transform::core 1.1 [list source [file join $dir transformcore.tcl]] diff --git a/src/bootsupport/lib/virtchannel_core/transformcore.tcl b/src/bootsupport/lib/virtchannel_core/transformcore.tcl new file mode 100644 index 00000000..3cd8c696 --- /dev/null +++ b/src/bootsupport/lib/virtchannel_core/transformcore.tcl @@ -0,0 +1,71 @@ +# -*- tcl -*- +# # ## ### ##### ######## ############# +# (C) 2009 Andreas Kupries + +# @@ Meta Begin +# Package tcl::transform::core 1.1 +# Meta as::author {Andreas Kupries} +# Meta as::copyright 2009 +# Meta as::license BSD +# Meta description Support package handling a core +# Meta description aspect of reflected transform channels +# Meta description (initialization, finalization). +# Meta description It is expected that this class +# Meta description is used as either one superclass of the +# Meta description class C for a specific channel, or is +# Meta description mixed into C. +# Meta platform tcl +# Meta require TclOO +# Meta require {Tcl 8.6} +# @@ Meta End + +# # ## ### ##### ######## ############# + +package require Tcl 8.6 9 + +# # ## ### ##### ######## ############# + +oo::class create ::tcl::transform::core { + destructor { + if {$channel eq {}} return + close $channel + return + } + + # # ## ### ##### ######## ############# + + method initialize {thechannel mode} { + set methods [info object methods [self] -all] + + # Note: Checking of the mode against the supported methods is + # done by the caller. + + set channel $thechannel + set supported {} + foreach m { + initialize finalize read write drain flush limit? + } { + if {$m in $methods} { + lappend supported $m + } + } + return $supported + } + + method finalize {c} { + set channel {} ; # Prevent destroctor from calling close. + my destroy + return + } + + # # ## ### ##### ######## ############# + + variable channel + + # channel The channel the handler belongs to. + # # ## ### ##### ######## ############# +} + +# # ## ### ##### +package provide tcl::transform::core 1.1 +return diff --git a/src/bootsupport/lib/virtchannel_transform/adler32.tcl b/src/bootsupport/lib/virtchannel_transform/adler32.tcl new file mode 100644 index 00000000..af31e0cc --- /dev/null +++ b/src/bootsupport/lib/virtchannel_transform/adler32.tcl @@ -0,0 +1,103 @@ +# -*- tcl -*- +# # ## ### ##### ######## ############# +# (C) 2009 Andreas Kupries + +# @@ Meta Begin +# Package tcl::transform::adler32 1.1 +# Meta as::author {Andreas Kupries} +# Meta as::copyright 2009 +# Meta as::license BSD +# Meta as::notes For other observers see crc32, counter, +# Meta as::notes identity, and observer (stream copy). +# Meta description Implementation of an adler32 checksum +# Meta description transformation. Based on Tcl 8.6's +# Meta description transformation reflection support (TIP +# Meta description 230), and its zlib support (TIP 234) for +# Meta description the adler32 functionality. An observer +# Meta description instead of a transformation. For details +# Meta description on the adler checksum see +# Meta description http://en.wikipedia.org/wiki/Adler-32 . +# Meta description The observer saves the checksums into two +# Meta description namespaced external variables specified +# Meta description at construction time. Exports a single +# Meta description command adding a new transformation of +# Meta description this type to a channel. One argument, +# Meta description the channel to extend, plus options to +# Meta description specify the variables for the checksums. +# Meta description No result. +# Meta platform tcl +# Meta require tcl::transform::core +# Meta require {Tcl 8.6} +# @@ Meta End + +# # ## ### ##### ######## ############# + +package require Tcl 8.6 9 +package require tcl::transform::core + +# # ## ### ##### ######## ############# + +namespace eval ::tcl::transform {} + +proc ::tcl::transform::adler32 {chan args} { + ::chan push $chan [adler32::implementation new {*}$args] +} + +oo::class create ::tcl::transform::adler32::implementation { + superclass tcl::transform::core ;# -> initialize, finalize, destructor + + # This transformation continuously computes a checksum from the + # data it sees. This data may be arbitrary parts of the input or + # output if the channel is seeked while the transform is + # active. This may not be what is wanted and the desired behaviour + # may require the destruction of the transform before seeking. + + method write {c data} { + my Adler32 -write-variable $data + return $data + } + + method read {c data} { + my Adler32 -read-variable $data + return $data + } + + # # ## ### ##### ######## ############# + + constructor {args} { + array set options { + -read-variable {} + -write-variable {} + } + # todo: validity checking of options (legal names, legal + # values, etc.) + array set options $args + my Init -read-variable + my Init -write-variable + return + } + + # # ## ### ##### ######## ############# + + variable options + + # # ## ### ##### ######## ############# + + method Init {o} { + if {$options($o) eq ""} return + upvar #0 $options($o) adler + set adler 1 + return + } + + method Adler32 {o data} { + if {$options($o) eq ""} return + upvar #0 $options($o) adler + set adler [zlib adler32 $data $adler] + return + } +} + +# # ## ### ##### ######## ############# +package provide tcl::transform::adler32 1.1 +return diff --git a/src/bootsupport/lib/virtchannel_transform/base64.tcl b/src/bootsupport/lib/virtchannel_transform/base64.tcl new file mode 100644 index 00000000..feaf7da1 --- /dev/null +++ b/src/bootsupport/lib/virtchannel_transform/base64.tcl @@ -0,0 +1,111 @@ +# -*- tcl -*- +# # ## ### ##### ######## ############# +# (C) 2009 Andreas Kupries + +# @@ Meta Begin +# Package tcl::transform::base64 1.1 +# Meta as::author {Andreas Kupries} +# Meta as::copyright 2009 +# Meta as::license BSD +# Meta as::notes Possibilities for extension: Currently +# Meta as::notes the mapping between read/write and +# Meta as::notes decode/encode is fixed. Allow it to be +# Meta as::notes configured at construction time. +# Meta description Implementation of a base64 +# Meta description transformation (RFC 4648). Based on Tcl +# Meta description 8.6's transformation reflection support +# Meta description (TIP 230) and binary en/decode (TIP 317). +# Meta description Exports a single command adding a new +# Meta description transformation of this type to a channel. +# Meta description One argument, the channel to extend. No +# Meta description result. +# Meta platform tcl +# Meta require tcl::transform::core +# Meta require {Tcl 8.6} +# @@ Meta End + +# # ## ### ##### ######## ############# + +package require Tcl 8.6 9 +package require tcl::transform::core + +# # ## ### ##### ######## ############# + +namespace eval ::tcl::transform {} + +proc ::tcl::transform::base64 {chan} { + ::chan push $chan [base64::implementation new] + return +} + +oo::class create ::tcl::transform::base64::implementation { + superclass tcl::transform::core ;# -> initialize, finalize, destructor + + method write {c data} { + my Code encodebuf encode $data 3 + } + + method read {c data} { + my Code decodebuf decode $data 4 + } + + method flush {c} { + set data [binary encode base64 $encodebuf] + set encodebuf {} + return $data + } + + method drain {c} { + set data [binary decode base64 $decodebuf] + set decodebuf {} + return $data + } + + method clear {c} { + set decodebuf {} + return + } + + # # ## ### ##### ######## ############# + + constructor {} { + set encodebuf {} + set decodebuf {} + return + } + + # # ## ### ##### ######## ############# + + variable encodebuf decodebuf + + # # ## ### ##### ######## ############# + + method Code {bufvar op data n} { + upvar 1 $bufvar buffer + + append buffer $data + + set n [my Complete $buffer $n] + if {$n < 0} { + return {} + } + + set result \ + [binary $op base64 \ + [string range $buffer 0 $n]] + incr n + set buffer \ + [string range $buffer $n end] + + return $result + } + + method Complete {buffer n} { + set len [string length $buffer] + return [expr {(($len / $n) * $n)-1}] + } +} + +# # ## ### ##### ######## ############# +package provide tcl::transform::base64 1.1 +return diff --git a/src/bootsupport/lib/virtchannel_transform/counter.tcl b/src/bootsupport/lib/virtchannel_transform/counter.tcl new file mode 100644 index 00000000..4b8a6f21 --- /dev/null +++ b/src/bootsupport/lib/virtchannel_transform/counter.tcl @@ -0,0 +1,94 @@ +# -*- tcl -*- +# # ## ### ##### ######## ############# +# (C) 2009 Andreas Kupries + +# @@ Meta Begin +# Package tcl::transform::counter 1.1 +# Meta as::author {Andreas Kupries} +# Meta as::copyright 2009 +# Meta as::license BSD +# Meta as::notes For other observers see adler32, crc32, +# Meta as::notes identity, and observer (stream copy). +# Meta as::notes Possibilities for extension: Separate +# Meta as::notes counters per byte value. Count over +# Meta as::notes fixed time-intervals = channel speed. +# Meta as::notes Use callbacks or traces to save changes +# Meta as::notes in the counters, etc. as time-series. +# Meta as::notes Compute statistics over the time-series. +# Meta description Implementation of a counter +# Meta description transformation. Based on Tcl 8.6's +# Meta description transformation reflection support (TIP +# Meta description 230). An observer instead of a +# Meta description transformation, it counts the number of +# Meta description bytes read and written. The observer +# Meta description saves the counts into two external +# Meta description namespaced variables specified at +# Meta description construction time. Exports a single +# Meta description command adding a new transformation of +# Meta description this type to a channel. One argument, +# Meta description the channel to extend, plus options to +# Meta description specify the variables for the counters. +# Meta description No result. +# Meta platform tcl +# Meta require tcl::transform::core +# Meta require {Tcl 8.6} +# @@ Meta End + +# # ## ### ##### ######## ############# + +package require Tcl 8.6 9 +package require tcl::transform::core + +# # ## ### ##### ######## ############# + +namespace eval ::tcl::transform {} + +proc ::tcl::transform::counter {chan args} { + ::chan push $chan [counter::implementation new {*}$args] +} + +oo::class create ::tcl::transform::counter::implementation { + superclass tcl::transform::core ;# -> initialize, finalize, destructor + + method write {c data} { + my Count -write-variable $data + return $data + } + + method read {c data} { + my Count -read-variable $data + return $data + } + + # No partial data, nor state => no flush, drain, nor clear needed. + + # # ## ### ##### ######## ############# + + constructor {args} { + array set options { + -read-variable {} + -write-variable {} + } + # todo: validity checking of options (legal names, legal + # values, etc.) + array set options $args + return + } + + # # ## ### ##### ######## ############# + + variable options + + # # ## ### ##### ######## ############# + + method Count {o data} { + if {$options($o) eq ""} return + upvar #0 $options($o) counter + incr counter [string length $data] + return + } +} + +# # ## ### ##### ######## ############# +package provide tcl::transform::counter 1.1 +return diff --git a/src/bootsupport/lib/virtchannel_transform/crc32.tcl b/src/bootsupport/lib/virtchannel_transform/crc32.tcl new file mode 100644 index 00000000..28974910 --- /dev/null +++ b/src/bootsupport/lib/virtchannel_transform/crc32.tcl @@ -0,0 +1,103 @@ +# -*- tcl -*- +# # ## ### ##### ######## ############# +# (C) 2009 Andreas Kupries + +# @@ Meta Begin +# Package tcl::transform::crc32 1.1 +# Meta as::author {Andreas Kupries} +# Meta as::copyright 2009 +# Meta as::license BSD +# Meta as::notes For other observers see adler32, counter, +# Meta as::notes identity, and observer (stream copy). +# Meta description Implementation of a crc32 checksum +# Meta description transformation. Based on Tcl 8.6's +# Meta description transformation reflection support (TIP +# Meta description 230), and its zlib support (TIP 234) for +# Meta description the crc32 functionality. An observer +# Meta description instead of a transformation. For details +# Meta description on the crc checksum see +# Meta description http://en.wikipedia.org/wiki/Cyclic_redundancy_check#Commonly_used_and_standardised_CRCs . +# Meta description The observer saves the checksums into two +# Meta description namespaced external variables specified +# Meta description at construction time. Exports a single +# Meta description command adding a new transformation of +# Meta description this type to a channel. One argument, +# Meta description the channel to extend, plus options to +# Meta description specify the variables for the checksums. +# Meta description No result. +# Meta platform tcl +# Meta require tcl::transform::core +# Meta require {Tcl 8.6} +# @@ Meta End + +# # ## ### ##### ######## ############# + +package require Tcl 8.6 9 +package require tcl::transform::core + +# # ## ### ##### ######## ############# + +namespace eval ::tcl::transform {} + +proc ::tcl::transform::crc32 {chan args} { + ::chan push $chan [crc32::implementation new {*}$args] +} + +oo::class create ::tcl::transform::crc32::implementation { + superclass tcl::transform::core ;# -> initialize, finalize, destructor + + # This transformation continuously computes a checksum from the + # data it sees. This data may be arbitrary parts of the input or + # output if the channel is seeked while the transform is + # active. This may not be what is wanted and the desired behaviour + # may require the destruction of the transform before seeking. + + method write {c data} { + my Crc32 -write-variable $data + return $data + } + + method read {c data} { + my Crc32 -read-variable $data + return $data + } + + # # ## ### ##### ######## ############# + + constructor {args} { + array set options { + -read-variable {} + -write-variable {} + } + # todo: validity checking of options (legal names, legal + # values, etc.) + array set options $args + my Init -read-variable + my Init -write-variable + return + } + + # # ## ### ##### ######## ############# + + variable options + + # # ## ### ##### ######## ############# + + method Init {o} { + if {$options($o) eq ""} return + upvar #0 $options($o) crc + set crc 0 + return + } + + method Crc32 {o data} { + if {$options($o) eq ""} return + upvar #0 $options($o) crc + set crc [zlib crc32 $data $crc] + return + } +} + +# # ## ### ##### ######## ############# +package provide tcl::transform::crc32 1.1 +return diff --git a/src/bootsupport/lib/virtchannel_transform/hex.tcl b/src/bootsupport/lib/virtchannel_transform/hex.tcl new file mode 100644 index 00000000..799eac76 --- /dev/null +++ b/src/bootsupport/lib/virtchannel_transform/hex.tcl @@ -0,0 +1,58 @@ +# -*- tcl -*- +# # ## ### ##### ######## ############# +# (C) 2009 Andreas Kupries + +# @@ Meta Begin +# Package tcl::transform::hex 1.1 +# Meta as::author {Andreas Kupries} +# Meta as::copyright 2009 +# Meta as::license BSD +# Meta description Implementation of a hex transformation, +# Meta description using Tcl 8.6's transformation +# Meta description reflection support. Uses the binary +# Meta description command to implement the transformation. +# Meta description Exports a single command adding a new +# Meta description transform of this type to a channel. One +# Meta description argument, the channel to extend. No +# Meta description result. +# Meta platform tcl +# Meta require tcl::transform::core +# Meta require {Tcl 8.6} +# @@ Meta End + +# # ## ### ##### ######## ############# + +package require Tcl 8.6 9 +package require tcl::transform::core + +# # ## ### ##### ######## ############# + +namespace eval ::tcl::transform {} + +proc ::tcl::transform::hex {chan} { + ::chan push $chan [hex::implementation new] + return +} + +oo::class create ::tcl::transform::hex::implementation { + superclass tcl::transform::core ;# -> initialize, finalize, destructor + + method write {c data} { + # bytes -> hex + binary scan $data H* hex + return $hex + } + + method read {c data} { + # hex -> bytes + return [binary format H* $data] + } + + # No partial data, nor state => no flush, drain, nor clear needed. + + # # ## ### ##### ######## ############# +} + +# # ## ### ##### ######## ############# +package provide tcl::transform::hex 1.1 +return diff --git a/src/bootsupport/lib/virtchannel_transform/identity.tcl b/src/bootsupport/lib/virtchannel_transform/identity.tcl new file mode 100644 index 00000000..d3b613ce --- /dev/null +++ b/src/bootsupport/lib/virtchannel_transform/identity.tcl @@ -0,0 +1,59 @@ +# -*- tcl -*- +# # ## ### ##### ######## ############# +# (C) 2009 Andreas Kupries + +# @@ Meta Begin +# Package tcl::transform::identity 1.1 +# Meta as::author {Andreas Kupries} +# Meta as::copyright 2009 +# Meta as::license BSD +# Meta as::notes The prototypical observer transformation. +# Meta as::notes To observers what null is to reflected +# Meta as::notes base channels. For other observers see +# Meta as::notes adler32, crc32, counter, and observer +# Meta as::notes (stream copy). +# Meta description Implementation of an identity +# Meta description transformation, i.e one which does not +# Meta description change the data in any way, shape, or +# Meta description form. Based on Tcl 8.6's transformation +# Meta description reflection support. Exports a single +# Meta description command adding a new transform of this +# Meta description type to a channel. One argument, the +# Meta description channel to extend. No result. +# Meta platform tcl +# Meta require tcl::transform::core +# Meta require {Tcl 8.6} +# @@ Meta End + +# # ## ### ##### ######## ############# + +package require Tcl 8.6 9 +package require tcl::transform::core + +# # ## ### ##### ######## ############# + +namespace eval ::tcl::transform {} + +proc ::tcl::transform::identity {chan} { + ::chan push $chan [identity::implementation new] +} + +oo::class create ::tcl::transform::identity::implementation { + superclass tcl::transform::core ;# -> initialize, finalize, destructor + + method write {c data} { + return $data + } + + method read {c data} { + return $data + } + + # No partial data, nor state => no flush, drain, nor clear needed. + + # # ## ### ##### ######## ############# +} + +# # ## ### ##### ######## ############# +package provide tcl::transform::identity 1.1 +return diff --git a/src/bootsupport/lib/virtchannel_transform/limitsize.tcl b/src/bootsupport/lib/virtchannel_transform/limitsize.tcl new file mode 100644 index 00000000..7d1f821b --- /dev/null +++ b/src/bootsupport/lib/virtchannel_transform/limitsize.tcl @@ -0,0 +1,88 @@ +# -*- tcl -*- +# # ## ### ##### ######## ############# +# (C) 2009 Andreas Kupries + +# @@ Meta Begin +# Package tcl::transform::limitsize 1.1 +# Meta as::author {Andreas Kupries} +# Meta as::copyright 2009 +# Meta as::license BSD +# Meta as::notes Possibilities for extension: Trigger the +# Meta as::notes EOF when finding specific patterns in +# Meta as::notes the input. Trigger the EOF based on some +# Meta as::notes external signal routed into the limiter. +# Meta as::notes Make the limit reconfigurable. +# Meta description Implementation of a transformation +# Meta description limiting the number of bytes read +# Meta description from its channel. An observer instead of +# Meta description a transformation, forcing an artificial +# Meta description EOF marker. Based on Tcl 8.6's +# Meta description transformation reflection support. +# Meta description Exports a single command adding a new +# Meta description transform of this type to a channel. One +# Meta description argument, the channel to extend, and the +# Meta description number of bytes to allowed to be read. +# Meta description No result. +# Meta platform tcl +# Meta require tcl::transform::core +# Meta require {Tcl 8.6} +# @@ Meta End + +# This may help with things like zlib compression of messages. Have +# the message format a length at the front, followed by a payload of +# that size. Now we may compress messages. On the read side we can use +# the limiter to EOF on a message, then reset the limit for the +# next. This is a half-baked idea. + +# # ## ### ##### ######## ############# + +package require Tcl 8.6 9 +package require tcl::transform::core + +# # ## ### ##### ######## ############# + +namespace eval ::tcl::transform {} + +proc ::tcl::transform::limitsize {chan max} { + ::chan push $chan [limitsize::implementation new $max] +} + +oo::class create ::tcl::transform::limitsize::implementation { + superclass tcl::transform::core ;# -> initialize, finalize, destructor + + method write {c data} { + return $data + } + + method read {c data} { + # Reduce the limit of bytes allowed in the future according to + # the number of bytes we have seen already. + + if {$max > 0} { + incr max -[string length $data] + if {$max < 0} { + set max 0 + } + } + return $data + } + + method limit? {c} { + return $max + } + + # # ## ### ##### ######## ############# + + constructor {themax} { + set max $themax + return + } + + variable max + + # # ## ### ##### ######## ############# +} + +# # ## ### ##### ######## ############# +package provide tcl::transform::limitsize 1.1 +return diff --git a/src/bootsupport/lib/virtchannel_transform/observe.tcl b/src/bootsupport/lib/virtchannel_transform/observe.tcl new file mode 100644 index 00000000..93e1331e --- /dev/null +++ b/src/bootsupport/lib/virtchannel_transform/observe.tcl @@ -0,0 +1,80 @@ +# -*- tcl -*- +# # ## ### ##### ######## ############# +# (C) 2009 Andreas Kupries + +# @@ Meta Begin +# Package tcl::transform::observe 1.1 +# Meta as::author {Andreas Kupries} +# Meta as::copyright 2009 +# Meta as::license BSD +# Meta as::notes For other observers see adler32, crc32, +# Meta as::notes identity, and counter. +# Meta as::notes Possibilities for extension: Save the +# Meta as::notes observed bytes to variables instead of +# Meta as::notes channels. Use callbacks to save the +# Meta as::notes observed bytes. +# Meta description Implementation of an observer +# Meta description transformation copying the bytes going +# Meta description through it into two channels configured +# Meta description at construction time. Based on Tcl 8.6's +# Meta description transformation reflection support. +# Meta description Exports a single command adding a new +# Meta description transformation of this type to a channel. +# Meta description Three arguments, the channel to extend, +# Meta description plus the channels to write the bytes to. +# Meta description No result. +# Meta platform tcl +# Meta require tcl::transform::core +# Meta require {Tcl 8.6} +# @@ Meta End + +# # ## ### ##### ######## ############# + +package require Tcl 8.6 9 +package require tcl::transform::core + +# # ## ### ##### ######## ############# + +namespace eval ::tcl::transform {} + +proc ::tcl::transform::observe {chan logw logr} { + ::chan push $chan [observe::implementation new $logw $logr] +} + +oo::class create ::tcl::transform::observe::implementation { + superclass tcl::transform::core ;# -> initialize, finalize, destructor + + method write {c data} { + if {$logw ne {}} { + puts -nonewline $logw $data + } + return $data + } + + method read {c data} { + if {$logr ne {}} { + puts -nonewline $logr $data + } + return $data + } + + # No partial data, nor state => no flush, drain, nor clear needed. + + # # ## ### ##### ######## ############# + + constructor {lw lr} { + set logr $lr + set logw $lw + return + } + + # # ## ### ##### ######## ############# + + variable logr logw + + # # ## ### ##### ######## ############# +} + +# # ## ### ##### ######## ############# +package provide tcl::transform::observe 1.1 +return diff --git a/src/bootsupport/lib/virtchannel_transform/otp.tcl b/src/bootsupport/lib/virtchannel_transform/otp.tcl new file mode 100644 index 00000000..61663f73 --- /dev/null +++ b/src/bootsupport/lib/virtchannel_transform/otp.tcl @@ -0,0 +1,98 @@ +# -*- tcl -*- +# # ## ### ##### ######## ############# +# (C) 2009 Andreas Kupries + +# @@ Meta Begin +# Package tcl::transform::otp 1.1 +# Meta as::author {Andreas Kupries} +# Meta as::copyright 2009 +# Meta as::license BSD +# Meta description Implementation of an onetimepad +# Meta description encryption transformation. Based on Tcl +# Meta description 8.6's transformation reflection support. +# Meta description The key bytes are read from two channels +# Meta description configured at construction time. Exports +# Meta description a single command adding a new +# Meta description transformation of this type to a channel. +# Meta description Three arguments, the channel to extend, +# Meta description plus the channels to read the keys from. +# Meta description No result. +# Meta platform tcl +# Meta require tcl::transform::core +# Meta require {Tcl 8.6} +# @@ Meta End + +# # ## ### ##### ######## ############# + +package require Tcl 8.6 9 +package require tcl::transform::core + +# # ## ### ##### ######## ############# + +namespace eval ::tcl::transform {} + +proc ::tcl::transform::otp {chan keychanw keychanr} { + ::chan push $chan [otp::implementation new $keychanw $keychanr] +} + +oo::class create ::tcl::transform::otp::implementation { + superclass tcl::transform::core ;# -> initialize, finalize, destructor + + # This transformation is intended for streaming operation. Seeking + # the channel while it is active may cause undesirable + # output. Proper behaviour may require the destruction of the + # transform before seeking. + + method write {c data} { + return [my Xor $data $keychanw] + } + + method read {c data} { + return [my Xor $data $keychanr] + } + + # # ## ### ##### ######## ############# + + constructor {keyw keyr} { + set keychanr $keyr + set keychanw $keyw + return + } + + # # ## ### ##### ######## ############# + + variable keychanr keychanw + + # # ## ### ##### ######## ############# + + # A very convoluted way to perform the XOR would be to use TIP + # #317's hex encoding to convert the bytes into strings, then zip + # key and data into an interleaved string (nibble wise), then + # perform the xor as a 'string map' of the whole thing, and at + # last 'binary decode hex' the string back into bytes. Even so + # most ops would run on the whole message at C level. Except for + # the interleave. :( + + method Xor {data keychan} { + # xor is done byte-wise. to keep IO down we read the key bytes + # once, before the loop handling the bytes. Note that we are + # having binary data at this point, making it necessary to + # convert into numbers (scan), and back (binary format). + + set keys [read $keychan [string length $data]] + set result {} + foreach d [split $data {}] k [split $keys {}] { + append result \ + [binary format c \ + [expr { + [scan $d %c] ^ + [scan $k %c] + }]] + } + return $result + } +} + +# # ## ### ##### ######## ############# +package provide tcl::transform::otp 1.1 +return diff --git a/src/bootsupport/lib/virtchannel_transform/pkgIndex.tcl b/src/bootsupport/lib/virtchannel_transform/pkgIndex.tcl new file mode 100644 index 00000000..0067c17e --- /dev/null +++ b/src/bootsupport/lib/virtchannel_transform/pkgIndex.tcl @@ -0,0 +1,14 @@ +if {![package vsatisfies [package provide Tcl] 8.6 9]} {return} + +package ifneeded tcl::transform::adler32 1.1 [list source [file join $dir adler32.tcl]] +package ifneeded tcl::transform::base64 1.1 [list source [file join $dir base64.tcl]] +package ifneeded tcl::transform::counter 1.1 [list source [file join $dir counter.tcl]] +package ifneeded tcl::transform::crc32 1.1 [list source [file join $dir crc32.tcl]] +package ifneeded tcl::transform::hex 1.1 [list source [file join $dir hex.tcl]] +package ifneeded tcl::transform::identity 1.1 [list source [file join $dir identity.tcl]] +package ifneeded tcl::transform::limitsize 1.1 [list source [file join $dir limitsize.tcl]] +package ifneeded tcl::transform::observe 1.1 [list source [file join $dir observe.tcl]] +package ifneeded tcl::transform::otp 1.1 [list source [file join $dir otp.tcl]] +package ifneeded tcl::transform::rot 1.1 [list source [file join $dir rot.tcl]] +package ifneeded tcl::transform::spacer 1.1 [list source [file join $dir spacer.tcl]] +package ifneeded tcl::transform::zlib 1.0.2 [list source [file join $dir zlib.tcl]] diff --git a/src/bootsupport/lib/virtchannel_transform/rot.tcl b/src/bootsupport/lib/virtchannel_transform/rot.tcl new file mode 100644 index 00000000..2fa98034 --- /dev/null +++ b/src/bootsupport/lib/virtchannel_transform/rot.tcl @@ -0,0 +1,95 @@ +# -*- tcl -*- +# # ## ### ##### ######## ############# +# (C) 2009 Andreas Kupries + +# @@ Meta Begin +# Package tcl::transform::rot 1.1 +# Meta as::author {Andreas Kupries} +# Meta as::copyright 2009 +# Meta as::license BSD +# Meta description Implementation of a rot +# Meta description encryption transformation. Based on Tcl +# Meta description 8.6's transformation reflection support. +# Meta description The key byte is +# Meta description configured at construction time. Exports +# Meta description a single command adding a new +# Meta description transformation of this type to a channel. +# Meta description Two arguments, the channel to extend, +# Meta description plus the key byte. +# Meta description No result. +# Meta platform tcl +# Meta require tcl::transform::core +# Meta require {Tcl 8.6} +# @@ Meta End + +# # ## ### ##### ######## ############# + +package require Tcl 8.6 9 +package require tcl::transform::core + +# # ## ### ##### ######## ############# + +namespace eval ::tcl::transform {} + +proc ::tcl::transform::rot {chan key} { + ::chan push $chan [rot::implementation new $key] +} + +oo::class create ::tcl::transform::rot::implementation { + superclass tcl::transform::core ;# -> initialize, finalize, destructor + + # This transformation is intended for streaming operation. Seeking + # the channel while it is active may cause undesirable + # output. Proper behaviour may require the destruction of the + # transform before seeking. + + method write {c data} { + return [my Rot $data $key] + } + + method read {c data} { + return [my Rot $data $ikey] + } + + # # ## ### ##### ######## ############# + + constructor {thekey} { + set key [expr {$thekey % 26}] + set ikey [expr {26 - $key}] + return + } + + # # ## ### ##### ######## ############# + + variable key ikey + + # # ## ### ##### ######## ############# + + method Rot {data key} { + # rot'ation is done byte-wise. Note that we are having binary + # data at this point, making it necessary to convert into + # numbers (scan), and back (binary format). + + set result {} + foreach d [split $data {}] { + set dx [scan $d %c] + if {(65 <= $dx) && ($dx <= 90)} { + set n [binary format c \ + [expr { (($dx - 65 + $key) % 26) + 65 }]] + } elseif {(97 <= $dx) && ($dx <= 122)} { + set n [binary format c \ + [expr { (($dx - 97 + $key) % 26) + 97 }]] + } else { + set n $d + } + + append result $n + + } + return $result + } +} + +# # ## ### ##### ######## ############# +package provide tcl::transform::rot 1.1 +return diff --git a/src/bootsupport/lib/virtchannel_transform/spacer.tcl b/src/bootsupport/lib/virtchannel_transform/spacer.tcl new file mode 100644 index 00000000..e3f481a5 --- /dev/null +++ b/src/bootsupport/lib/virtchannel_transform/spacer.tcl @@ -0,0 +1,151 @@ +# -*- tcl -*- +# # ## ### ##### ######## ############# +# (C) 2009 Andreas Kupries + +# @@ Meta Begin +# Package tcl::transform::spacer 1.1 +# Meta as::author {Andreas Kupries} +# Meta as::copyright 2009 +# Meta as::license BSD +# Meta description Implementation of a spacer +# Meta description transformation, using Tcl 8.6's +# Meta description transformation reflection support. Uses +# Meta description counters to implement the transformation, +# Meta description i.e. decide where to insert the spacing. +# Meta description Exports a single command adding a new +# Meta description transform of this type to a channel. One +# Meta description argument, the channel to extend. No +# Meta description result. +# Meta platform tcl +# Meta require tcl::transform::core +# Meta require {Tcl 8.6} +# @@ Meta End + +# # ## ### ##### ######## ############# + +package require Tcl 8.6 9 +package require tcl::transform::core + +# # ## ### ##### ######## ############# + +namespace eval ::tcl::transform {} + +proc ::tcl::transform::spacer {chan n {space { }}} { + ::chan push $chan [spacer::implementation new $n $space] + return +} + +oo::class create ::tcl::transform::spacer::implementation { + superclass tcl::transform::core ;# -> initialize, finalize, destructor + + # This transformation is intended for streaming operation. Seeking + # the channel while it is active may cause undesirable + # output. Proper behaviour may require the destruction of the + # transform before seeking. + + method write {c data} { + # add spacing, data is split into groups of delta chars. + set result {} + set len [string length $data] + + if {$woffset} { + # The beginning of the buffer is the remainder of the + # partial group found at the end of the buffer in the last + # call. It may still be partial, if the current buffer is + # short enough. + + if {($woffset + $len) < $delta} { + # Yes, the group is still not fully covered. + # Move the offset forward, and return the whole + # buffer. spacing is not needed yet. + incr woffset $len + return $data + } + + # The buffer completes the group. Add it and the following + # spacing, then fix the offset to start the processing of + # the groups coming after at the proper location. + + set stop [expr {$delta - $woffset - 1}] + + append result [string range $data 0 $stop] + append result $spacing + + set woffset $stop + incr woffset + } + + # Process full groups in the middle of the incoming buffer. + + set at $woffset + set stop [expr {$at + $delta - 1}] + while {$stop < $len} { + append result [string range $data $at $stop] + append result $spacing + incr at $delta + incr stop $delta + } + + # Process partial group at the end of the buffer and remember + # the offset, for the processing of the group remainder in the + # next call. + + if {($at < $len) && ($stop >= $len)} { + append result [string range $data $at end] + } + set woffset [expr {$len - $at}] + return $result + } + + method read {c data} { + # remove spacing from groups of delta+sdelta chars, keeping + # the first delta in each group. + set result {} + set iter [expr {$delta + $sdelta}] + set at 0 + if {$roffset} { + if {$roffset < $delta} { + append result [string range $data 0 ${roffset}-1] + } + incr at [expr {$iter - $roffset}] + } + set len [string length $data] + set end [expr {$at + $delta - 1}] + set stop [expr {$at + $iter - 1}] + while {$stop < $len} { + append result [string range $data $at $end] + incr at $iter + incr end $iter + incr stop $iter + } + if {$end < $len} { + append result [string range $data $at $end] + set roffset [expr {$len - $end + 1}] + } elseif {$at < $len} { + append result [string range $data $at end] + set roffset [expr {$len - $at}] + } + return [list $result $roffset] + } + + # # ## ### ##### ######## ############# + + constructor {n space} { + set roffset 0 + set woffset 0 + set delta $n + set spacing $space + set sdelta [string length $spacing] + return + } + + # # ## ### ##### ######## ############# + + variable roffset woffset delta spacing sdelta + + # # ## ### ##### ######## ############# +} + +# # ## ### ##### ######## ############# +package provide tcl::transform::spacer 1.1 +return diff --git a/src/bootsupport/lib/virtchannel_transform/zlib.tcl b/src/bootsupport/lib/virtchannel_transform/zlib.tcl new file mode 100644 index 00000000..8599f248 --- /dev/null +++ b/src/bootsupport/lib/virtchannel_transform/zlib.tcl @@ -0,0 +1,100 @@ +# -*- tcl -*- +# # ## ### ##### ######## ############# +# (C) 2009 Andreas Kupries + +# @@ Meta Begin +# Package tcl::transform::zlib 1.0.2 +# Meta as::author {Andreas Kupries} +# Meta as::copyright 2009 +# Meta as::license BSD +# Meta as::notes Possibilities for extension: Currently +# Meta as::notes the mapping between read/write and +# Meta as::notes de/compression is fixed. Allow it to be +# Meta as::notes configured at construction time. +# Meta description Implementation of a zlib (de)compressor. +# Meta description Based on Tcl 8.6's transformation +# Meta description reflection support (TIP 230) and zlib +# Meta description support (TIP 234). Compresses on write. +# Meta description Exports a single command adding a new +# Meta description transformation of this type to a channel. +# Meta description Two arguments, the channel to extend, +# Meta description and the compression level. No result. +# Meta platform tcl +# Meta require tcl::transform::core +# Meta require {Tcl 8.6} +# @@ Meta End + +# # ## ### ##### ######## ############# + +package require Tcl 8.6 9 +package require tcl::transform::core + +# # ## ### ##### ######## ############# + +namespace eval ::tcl::transform {} + +proc ::tcl::transform::zlib {chan {level 4}} { + ::chan push $chan [zlib::implementation new $level] + return +} + +oo::class create ::tcl::transform::zlib::implementation { + superclass tcl::transform::core ;# -> initialize, finalize, destructor + + # This transformation is intended for streaming operation. Seeking + # the channel while it is active may cause undesirable + # output. Proper behaviour may require the destruction of the + # transform before seeking. + + method initialize {c mode} { + set compressor [zlib stream deflate -level $level] + set decompressor [zlib stream inflate] + + next $c $mode + } + + method finalize {c} { + $compressor close + $decompressor close + + next $c + } + + method write {c data} { + $compressor put $data + return [$compressor get] + } + + method read {c data} { + $decompressor put $data + return [$decompressor get] + } + + method flush {c} { + $compressor flush + return [$compressor get] + } + + method drain {c} { + $decompressor flush + return [$decompressor get] + } + + # # ## ### ##### ######## ############# + + constructor {thelevel} { + # Should validate input (level in (0 ...9)) + set level $thelevel + return + } + + # # ## ### ##### ######## ############# + + variable level compressor decompressor + + # # ## ### ##### ######## ############# +} + +# # ## ### ##### ######## ############# +package provide tcl::transform::zlib 1.0.2 +return diff --git a/src/bootsupport/modules/include_modules.config b/src/bootsupport/modules/include_modules.config index 2000d2f0..edd7393d 100644 --- a/src/bootsupport/modules/include_modules.config +++ b/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/bootsupport/modules/zzzload-0.1.0.tm b/src/bootsupport/modules/zzzload-0.1.0.tm new file mode 100644 index 00000000..def41578 --- /dev/null +++ b/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/modules/punk/mix/templates/utility/scriptappwrappers/multishell.cmd b/src/modules/punk/mix/templates/utility/scriptappwrappers/multishell.cmd index 82d174a5..392d400f 100644 --- a/src/modules/punk/mix/templates/utility/scriptappwrappers/multishell.cmd +++ b/src/modules/punk/mix/templates/utility/scriptappwrappers/multishell.cmd @@ -752,12 +752,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 +770,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,7 +786,7 @@ function GetDynamicParamDictionary { # } # end { # #Main function logic -# Write-Host "myargumentname value is: $myargumentname" +# Write-Host "myargument value is: $myargument" # #myotherfunction @PSBoundParameters # } #} diff --git a/src/runtime/mapvfs.config b/src/runtime/mapvfs.config index a0766222..ed09bcde 100644 --- a/src/runtime/mapvfs.config +++ b/src/runtime/mapvfs.config @@ -83,5 +83,6 @@ tclsh902z.exe {punk9win_for_tkruntime.vfs punk902z zip} #temp hack - todo fix .exe for x-platform #linux tclsh90 (zip) built with zig.build x-compile on windows -#tclsh90linux.exe {punk9linux.vfs punk90linux zip} +#tclsh90linux.exe {punk9linux.vfs punk90linux zip} +tclkit-902-Linux64-intel-dyn {punk9linux.vfs punk902linux-x86_64 zip} diff --git a/src/scriptapps/runtime.bash b/src/scriptapps/runtime.bash new file mode 100644 index 00000000..584a949f --- /dev/null +++ b/src/scriptapps/runtime.bash @@ -0,0 +1,111 @@ + +wdir="$(pwd)"; [ "$(pwd)" = "/" ] && wdir="" +case "$0" in + /*) scriptpath="${0}";; + *) scriptpath="$wdir/${0#./}";; +esac +scriptdir="${scriptpath%/*}" +scriptdir=$(realpath $scriptdir) +scriptpath=$(realpath $scriptpath) +basename=$(basename "$scriptpath") #e.g fetchruntime.bash +scriptroot="${basename%.*}" #e.g "fetchruntime" + +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 + 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 + 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" + fi + os="linux" +elif [[ "$OSTYPE" == "darwin"* ]]; then + os="macosx" + #assumed to be Mach-O 'universal binaries' for both x86-64 and arm? - REVIEW + url="${url_kitbase}/macosx/tclkit-902-Darwin64-dyn" + archdir="${scriptdir}/runtime/macosx/" + output="${archdir}/tclkit-902-Darwin64-dyn" + runtime_available=1 +elif [[ "$OSTYPE" == "freebsd"* ]]; then + os="freebsd" +elif [[ "$OSTYPE" == "dragonflybsd"* ]]; then + os="dragonflybsd" +elif [[ "$OSTYPE" == "netbsd"* ]]; then + os="netbsd" +elif [[ "$OSTYPE" == "win32" ]]; then + os="win32" + url="${url_kitbase}/win32-x86_64/tclsh902z.exe" + archdir="${scriptdir}/runtime/win32-x86_64/" + output="${archdir}/tcsh902z.exe" + runtime_available=1 +elif [[ "$OSTYPE" == "msys" ]]; then + echo MSYS + os="win32" + #use 'command -v' (shell builtin preferred over external which) + interp = `ps -p $$ | awk '$1 != "PID" {print $(NF)}' | tr -d '()' | sed -E 's/^.*\/|^-//'` + shellpath=`command -v $interp` + shellfolder="${shellpath%/*}" #avoid dependency on basename or dirname + #"c:/windows/system32/" is quite likely in the path ahead of msys,git etc. + #This breaks calls to various unix utils such as sed etc (wsl related?) + export PATH="$shellfolder${PATH:+:${PATH}}" + url="${url_kitbase}/win32-x86_64/tclsh902z.exe" + archdir="${scriptdir}/runtime/win32-x86_64" + output="${archdir}/tclsh902z.exe" + runtime_available=1 +else + #os="$OSTYPE" + os="other" +fi + +case "$1" in + "fetch") + + if [[ "$runtime_available" -eq 1 ]]; then + #test win32 + mkdir -p $archdir + echo "Attempting to download $url" + #wget $url -O $output + curl -SL --output "$output" "$url" + if [[ $? -eq 0 ]]; then + echo "File downloaded to $output" + chmod +x $output + else + echo "Error: Failed to download to $output" + fi + else + echo "No runtime currently available for $os" + fi + ;; + "list") + 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." + 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" + shift + echo "args: $@" + $activeruntime_fullpath "$@" + ;; + *) + echo "Usage: $0 {fetch|list|run}" + exit 1 + ;; +esac diff --git a/src/scriptapps/runtime.ps1 b/src/scriptapps/runtime.ps1 new file mode 100644 index 00000000..f6cab3b8 --- /dev/null +++ b/src/scriptapps/runtime.ps1 @@ -0,0 +1,184 @@ + + +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-Object -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 + } +} +function ParameterDefinitions { + param( + [Parameter(ValueFromRemainingArguments=$true)] $opts + ) +} + +function psmain { + [CmdletBinding()] + #Empty param block (extra params can be added) + param( + [Parameter(Mandatory=$false)][string] $action + ) + dynamicparam { + if ($action -eq 'list') { + } elseif ($action -eq 'fetch') { + #GetDynamicParamDictionary ParameterDefinitions + $parameterAttribute = [System.Management.Automation.ParameterAttribute]@{ + ParameterSetName = "fetchruntime" + Mandatory = $false + } + $attributeCollection = [System.Collections.ObjectModel.Collection[System.Attribute]]::new() + $attributeCollection.Add($parameterAttribute) + + $dynParam1 = [System.Management.Automation.RuntimeDefinedParameter]::new( + 'runtime', [string], $attributeCollection + ) + + $paramDictionary = [System.Management.Automation.RuntimeDefinedParameterDictionary]::new() + $paramDictionary.Add('runtime', $dynParam1) + return $paramDictionary + } elseif ($action -eq 'run') { + GetDynamicParamDictionary ParameterDefinitions + } else { + } + } + process { + #Called once - we get a single item being our PSBoundParameters dictionary + #write-host "Bound Parameters:$($PSBoundParameters.Keys)" + switch ($PSBoundParameters.keys) { + 'action' { + #write-host "got action " $PSBoundParameters.action + Set-Variable -Name $_ -Value $PSBoundParameters."$_" + $known_actions = @("fetch", "list", "run") + if (-not($known_actions -contains $action)) { + write-host "fetch '$action' not understood. Known_actions: $known_actions" + exit 1 + } + } + 'opts' { + #write-warning "Unused parameters: $($PSBoundParameters.$_)" + } + Default { + #write-warning "Unhandled parameter -> [$($_)]" + } + } + #foreach ($boundparam in $PSBoundParameters.Keys) { + # write-host "k: $boundparam" + #} + } + end { + # PSBoundParameters + #write-host "action:'$action'" + $outbase = $PSScriptRoot + $outbase = Resolve-Path -Path $outbase + #expected script location is the bin folder of a punk project + $rtfolder = Join-Path -Path $outbase -ChildPath "runtime" + $archfolder = Join-Path -Path $rtfolder -ChildPath "win32-x86_64" + switch ($action) { + 'fetch' { + $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])" + } + if ( $PSBoundParameters["runtime"].Length ) { + $runtime = $PSBoundParameters["runtime"] + } + $fileurl = "$archurl/$runtime" + $output = join-path $archfolder $runtime + + $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" + } + catch { + Write-Host "An error occurred: $($_.Exception.Message)" + if ($_.Exception.Response) { + Write-Host "HTTP Status code: $($_.Exception.Response.StatusCode)" + } + } + } else { + Write-Host "Runtime already found at $output" + } + } + 'run' { + #select first (or configured default) runtime and launch, passing arguments + 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 + #} + #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 + } 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." + } + } + } + '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 + } + } else { + write-host "No runtimes seem to be installed for win32-x86_64 in $archfolder`nPlase use 'runtime.cmd fetch' to install." + } + } + default { + $actions = @("fetch", "list", "run") + write-host "Available actions: $actions" + } + } + + return $PSBoundParameters + } +} +#write-host (psmain @args) +$returnvalue = psmain @args +#Write-Host "Function Returned $returnvalue" -ForegroundColor Cyan +return $returnvalue +exit 0 + diff --git a/src/scriptapps/runtime_wrap.toml b/src/scriptapps/runtime_wrap.toml new file mode 100644 index 00000000..c9840a08 --- /dev/null +++ b/src/scriptapps/runtime_wrap.toml @@ -0,0 +1,20 @@ + +[application] + template="punk.multishell.cmd" + as_admin=false + + scripts=[ + "runtime.ps1", + "runtime.bash" + ] + + default_outputfile="runtime.cmd" + default_nextshellpath="/usr/bin/env bash" + default_nextshelltype="bash" + + #valid nextshelltype entries are: tcl perl powershell bash. + #nextshellpath entries must be 64 characters or less. + + win32.nextshellpath="powershell" + win32.nextshelltype="powershell" + win32.outputfile="runtime.cmd" diff --git a/src/vendorlib_tcl9/linux-x86_64/thread3.0.2/libtcl9thread3.0.2.so b/src/vendorlib_tcl9/linux-x86_64/thread3.0.2/libtcl9thread3.0.2.so new file mode 100644 index 00000000..942beddf Binary files /dev/null and b/src/vendorlib_tcl9/linux-x86_64/thread3.0.2/libtcl9thread3.0.2.so differ diff --git a/src/vendorlib_tcl9/linux-x86_64/thread3.0.2/pkgIndex.tcl b/src/vendorlib_tcl9/linux-x86_64/thread3.0.2/pkgIndex.tcl new file mode 100644 index 00000000..a6a7a228 --- /dev/null +++ b/src/vendorlib_tcl9/linux-x86_64/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/vendorlib_tcl9/linux-x86_64/thread3.0.2/thread3.0.2/libtcl9thread3.0.2.so b/src/vendorlib_tcl9/linux-x86_64/thread3.0.2/thread3.0.2/libtcl9thread3.0.2.so new file mode 100644 index 00000000..942beddf Binary files /dev/null and b/src/vendorlib_tcl9/linux-x86_64/thread3.0.2/thread3.0.2/libtcl9thread3.0.2.so differ diff --git a/src/vendorlib_tcl9/linux-x86_64/thread3.0.2/thread3.0.2/pkgIndex.tcl b/src/vendorlib_tcl9/linux-x86_64/thread3.0.2/thread3.0.2/pkgIndex.tcl new file mode 100644 index 00000000..a6a7a228 --- /dev/null +++ b/src/vendorlib_tcl9/linux-x86_64/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] + + + +