9 changed files with 5154 additions and 0 deletions
@ -0,0 +1,890 @@
|
||||
# vim: set ft=tcl |
||||
# |
||||
#purpose: handle the run commands that call shellfilter::run |
||||
#e.g run,runout,runerr,runx |
||||
|
||||
package require shellfilter |
||||
package require punk::ansi |
||||
|
||||
#NOTE: the run,runout,runerr,runx commands only produce an error if the command didn't run. |
||||
# - If it did run, but there was a non-zero exitcode it is up to the application to check that. |
||||
#This is deliberate, but means 'catch' doesn't catch errors within the command itself - the exitcode has to be checked. |
||||
#The user can always use exec for different process error semantics (they don't get exitcode with exec) |
||||
|
||||
namespace eval shellrun { |
||||
variable PUNKARGS |
||||
variable runout |
||||
variable runerr |
||||
|
||||
#do we need these? |
||||
#variable punkout |
||||
#variable punkerr |
||||
|
||||
#some ugly coupling with punk/punk::config for now |
||||
#todo - something better |
||||
if {[info exists ::punk::config::configdata]} { |
||||
set conf_running [punk::config::configure running] |
||||
set syslog_stdout [dict get $conf_running syslog_stdout] |
||||
set syslog_stderr [dict get $conf_running syslog_stderr] |
||||
set logfile_stdout [dict get $conf_running logfile_stdout] |
||||
set logfile_stderr [dict get $conf_running logfile_stderr] |
||||
} else { |
||||
lassign [list "" "" "" ""] syslog_stdout syslog_stderr logfile_stdout logfile_stderr |
||||
} |
||||
if {"punkshout" ni [shellfilter::stack::items]} { |
||||
set outdevice [shellfilter::stack::new punkshout -settings [list -tag "punkshout" -buffering none -raw 1 -syslog $syslog_stdout -file $logfile_stdout]] |
||||
set out [dict get $outdevice localchan] |
||||
} else { |
||||
set out [dict get [shellfilter::stack::item punkshout] device localchan] |
||||
} |
||||
if {"punksherr" ni [shellfilter::stack::items]} { |
||||
set errdevice [shellfilter::stack::new punksherr -settings [list -tag "punksherr" -buffering none -raw 1 -syslog $syslog_stderr -file $logfile_stderr]] |
||||
set err [dict get $errdevice localchan] |
||||
} else { |
||||
set err [dict get [shellfilter::stack::item punksherr] device localchan] |
||||
} |
||||
|
||||
namespace import ::punk::ansi::a+ |
||||
namespace import ::punk::ansi::a |
||||
|
||||
|
||||
|
||||
|
||||
#repltelemetry - additional/alternative display info used in a repl context i.e info directed towards the screen |
||||
#todo - package up in repltelemetry module and rewrite proc based on whether the module was found/loaded. |
||||
#somewhat strong coupling to punk - but let's try to behave decently if it's not loaded |
||||
#The last_run_display is actually intended for the repl - but is resident in the punk namespace with a view to the possibility of a different repl being in use. |
||||
proc set_last_run_display {chunklist} { |
||||
#chunklist as understood by the |
||||
if {![info exists ::punk::repltelemetry_emmitters]} { |
||||
namespace eval ::punk { |
||||
variable repltelemetry_emmitters |
||||
set repltelemetry_emmitters "shellrun" |
||||
} |
||||
} else { |
||||
if {"shellrun" ni $::punk::repltelemetry_emmitters} { |
||||
lappend punk::repltelemetry_emmitters "shellrun" |
||||
} |
||||
} |
||||
|
||||
#most basic of validity tests here.. just that it is a list (can be empty). We don't want to duplicate or over-constrain the way repls/shells/terminals interpet the info |
||||
if {[catch {llength $chunklist} errMsg]} { |
||||
error "set_last_run_display expects a list. Value supplied doesn't appear to be a well formed tcl list. '$errMsg'" |
||||
} |
||||
#todo - |
||||
tsv::lappend repl runchunks-[tsv::get repl runid] {*}$chunklist |
||||
} |
||||
|
||||
|
||||
|
||||
#maintenance: similar used in punk::ns & punk::winrun |
||||
#todo - take runopts + aliases as args |
||||
#longopts must be passed as a single item ie --timeout=100 not --timeout 100 |
||||
proc get_run_opts {arglist} { |
||||
if {[catch { |
||||
set callerinfo [info level -1] |
||||
} errM]} { |
||||
set caller "" |
||||
} else { |
||||
set caller [lindex $callerinfo 0] |
||||
} |
||||
|
||||
#we provide -nonewline even for 'run' even though run doesn't deliver stderr or stdout to the tcl return value |
||||
#This is for compatibility with other runX commands, and the difference is also visible when calling from repl. |
||||
set known_runopts [list "-echo" "-e" "-nonewline" "-n" "-tcl" "-debug"] |
||||
set known_longopts [list "--timeout"] |
||||
set known_longopts_msg "" |
||||
foreach lng $known_longopts { |
||||
append known_longopts_msg "${lng}=val " |
||||
} |
||||
set aliases [list "-e" "-echo" "-echo" "-echo" "-n" "-nonewline" "-nonewline" "-nonewline" "-tcl" "-tcl" "-debug" "-debug"] ;#include map to self |
||||
set runopts [list] |
||||
set runoptslong [list] |
||||
set cmdargs [list] |
||||
|
||||
set idx_first_cmdarg [lsearch -not $arglist "-*"] |
||||
|
||||
set allopts [lrange $arglist 0 $idx_first_cmdarg-1] |
||||
set cmdargs [lrange $arglist $idx_first_cmdarg end] |
||||
foreach o $allopts { |
||||
if {[string match --* $o]} { |
||||
lassign [split $o =] flagpart valpart |
||||
if {$valpart eq ""} { |
||||
error "$caller: longopt $o seems to be missing a value - must be of form --option=value" |
||||
} |
||||
if {$flagpart ni $known_longopts} { |
||||
error "$caller: Unknown runoption $o - known options $known_runopts $known_longopts_msg" |
||||
} |
||||
lappend runoptslong $flagpart $valpart |
||||
} else { |
||||
if {$o ni $known_runopts} { |
||||
error "$caller: Unknown runoption $o - known options $known_runopts $known_longopts_msg" |
||||
} |
||||
lappend runopts [dict get $aliases $o] |
||||
} |
||||
} |
||||
return [list runopts $runopts runoptslong $runoptslong cmdargs $cmdargs] |
||||
} |
||||
|
||||
|
||||
#todo - investigate cause of punk86 run hanging sometimes. An 'after 500' before exit in the called script fixes the issue. punk87 doesn't seem to be affected. |
||||
lappend PUNKARGS [list { |
||||
@id -id ::shellrun::run |
||||
@leaders -min 0 -max 0 |
||||
@opts |
||||
-nonewline -type none |
||||
-tcl -type none -default 0 |
||||
-debug -type none -default 0 |
||||
--timeout= -type integer |
||||
@values -min 1 -max -1 |
||||
cmdname -type string |
||||
cmdarg -type any -multiple 1 -optional 1 |
||||
}] |
||||
proc run {args} { |
||||
#set_last_run_display [list] |
||||
|
||||
#set splitargs [get_run_opts $args] |
||||
#set runopts [dict get $splitargs runopts] |
||||
#set runoptslong [dict get $splitargs runoptslong] |
||||
#set cmdargs [dict get $splitargs cmdargs] |
||||
set argd [punk::args::parse $args withid ::shellrun::run] |
||||
lassign [dict values $argd] leaders opts values received |
||||
|
||||
if {[dict exists $received "-nonewline"]} { |
||||
set nonewline 1 |
||||
} else { |
||||
set nonewline 0 |
||||
} |
||||
#review nonewline does nothing here.. |
||||
|
||||
set idlist_stderr [list] |
||||
#we leave stdout without imposed ansi colouring - because the source may be colourised and because ansi-wrapping a stream at whatever boundaries it comes in at isn't a really nice thing to do. |
||||
#stderr might have source colouring - but it usually doesn't seem to, and the visual distiction of red stderr can be very handy for the run command. |
||||
#A further enhancement could be to detect well-known options such as --color and/or use a configuration for specific commands that have useful colourised stderr, |
||||
#but having an option to configure stderr to red is a compromise. |
||||
#Note that the other run commands, runout,runerr, runx don't emit in real-time - so for those commands there may be options to detect and/or post-process stdout and stderr. |
||||
#TODO - fix. This has no effect if/when the repl adds an ansiwrap transform |
||||
# what we probably want to do is 'aside' that transform for runxxx commands only. |
||||
#lappend idlist_stderr [shellfilter::stack::add stderr ansiwrap -settings {-colour {red bold}}] |
||||
|
||||
set callopts [dict create] |
||||
if {[dict exists $received "-tcl"]} { |
||||
dict set callopts -tclscript 1 |
||||
} |
||||
if {[dict exists $received "-debug"]} { |
||||
dict set callopts -debug 1 |
||||
} |
||||
if {[dict exists $received --timeout]} { |
||||
dict set callopts -timeout [dict get $opts --timeout] ;#convert to single dash |
||||
} |
||||
set cmdname [dict get $values cmdname] |
||||
if {[dict exists $received cmdarg]} { |
||||
set cmdarglist [dict get $values cmdarg] |
||||
} else { |
||||
set cmdarglist {} |
||||
} |
||||
set cmdargs [concat $cmdname $cmdarglist] |
||||
#--------------------------------------------------------------------------------------------- |
||||
set exitinfo [shellfilter::run $cmdargs {*}$callopts -teehandle punksh -inbuffering none -outbuffering none ] |
||||
#--------------------------------------------------------------------------------------------- |
||||
|
||||
foreach id $idlist_stderr { |
||||
shellfilter::stack::remove stderr $id |
||||
} |
||||
|
||||
flush stderr |
||||
flush stdout |
||||
|
||||
if {[dict exists $exitinfo error]} { |
||||
error "[dict get $exitinfo error]\n$exitinfo" |
||||
} |
||||
|
||||
return $exitinfo |
||||
} |
||||
|
||||
lappend PUNKARGS [list { |
||||
@id -id ::shellrun::runconsole |
||||
@leaders -min 0 -max 0 |
||||
@opts |
||||
@values -min 1 -max -1 |
||||
cmdname -type string |
||||
cmdarg -type any -multiple 1 -optional 1 |
||||
}] |
||||
#run in the way tcl unknown does - but without regard to auto_noexec |
||||
proc runconsole {args} { |
||||
set argd [punk::args::parse $args withid ::shellrun::runconsole] |
||||
lassign [dict values $argd] leaders opts values received |
||||
set cmdname [dict get $values cmdname] |
||||
if {[dict exists $received cmdarg]} { |
||||
set arglist [dict get $values cmdarg] |
||||
} else { |
||||
set arglist {} |
||||
} |
||||
|
||||
set resolved_cmdname [auto_execok $cmdname] |
||||
set repl_runid [punk::get_repl_runid] |
||||
#set ::punk::last_run_display [list] |
||||
|
||||
set redir ">&@stdout <@stdin" |
||||
uplevel 1 [list ::catch [concat exec $redir $resolved_cmdname $arglist] ::tcl::UnknownResult ::tcl::UnknownOptions] |
||||
#we can't detect stdout/stderr output from the exec |
||||
#for now emit an extra \n on stderr |
||||
#todo - there is probably no way around this but to somehow exec in the context of a completely separate console |
||||
#This is probably a tricky problem - especially to do cross-platform |
||||
# |
||||
# - use [dict get $::tcl::UnknownOptions -code] (0|1) exit |
||||
if {[dict get $::tcl::UnknownOptions -code] == 0} { |
||||
set c green |
||||
set m "ok" |
||||
} else { |
||||
set c yellow |
||||
set m "errorCode $::errorCode" |
||||
} |
||||
set chunklist [list] |
||||
lappend chunklist [list "info" "[a $c]$m[a] " ] |
||||
if {$repl_runid != 0} { |
||||
tsv::lappend repl runchunks-$repl_runid {*}$chunklist |
||||
} |
||||
|
||||
dict incr ::tcl::UnknownOptions -level |
||||
return -options $::tcl::UnknownOptions $::tcl::UnknownResult |
||||
} |
||||
lappend PUNKARGS [list { |
||||
@id -id ::shellrun::runout |
||||
@leaders -min 0 -max 0 |
||||
@opts |
||||
-echo -type none |
||||
-nonewline -type none |
||||
-tcl -type none -default 0 |
||||
-debug -type none -default 0 |
||||
--timeout= -type integer |
||||
@values -min 1 -max -1 |
||||
cmdname -type string |
||||
cmdarg -type any -multiple 1 -optional 1 |
||||
}] |
||||
proc runout {args} { |
||||
set argd [punk::args::parse $args withid ::shellrun::runout] |
||||
lassign [dict values $argd] leaders opts values received |
||||
|
||||
if {[dict exists $received "-nonewline"]} { |
||||
set nonewline 1 |
||||
} else { |
||||
set nonewline 0 |
||||
} |
||||
|
||||
#set_last_run_display [list] |
||||
variable runout |
||||
variable runerr |
||||
set runout "" |
||||
set runerr "" |
||||
set RST [a] |
||||
|
||||
#set splitargs [get_run_opts $args] |
||||
#set runopts [dict get $splitargs runopts] |
||||
#set cmdargs [dict get $splitargs cmdargs] |
||||
|
||||
|
||||
#puts stdout "RUNOUT cmdargs: $cmdargs" |
||||
|
||||
#todo add -data boolean and -data lastwrite to -settings with default being -data all |
||||
# because sometimes we're only interested in last char (e.g to detect something was output) |
||||
|
||||
#set outvar_stackid [shellfilter::stack::add commandout tee_to_var -action float -settings {-varname ::runout}] |
||||
# |
||||
#when not echoing - use float-locked so that the repl's stack is bypassed |
||||
if {[dict exists $received "-echo"]} { |
||||
set stdout_stackid [shellfilter::stack::add stdout tee_to_var -action float-locked -settings {-varname ::shellrun::runout}] |
||||
set stderr_stackid [shellfilter::stack::add stderr tee_to_var -action float-locked -settings {-varname ::shellrun::runerr}] |
||||
#set stderr_stackid [shellfilter::stack::add stderr tee_to_var -action sink-locked -settings {-varname ::shellrun::runerr}] |
||||
} else { |
||||
set stdout_stackid [shellfilter::stack::add stdout var -action float-locked -settings {-varname ::shellrun::runout}] |
||||
set stderr_stackid [shellfilter::stack::add stderr var -action float-locked -settings {-varname ::shellrun::runerr}] |
||||
} |
||||
|
||||
set callopts [dict create] |
||||
if {[dict exists $received "-tcl"]} { |
||||
dict set callopts -tclscript 1 |
||||
} |
||||
if {[dict exists $received "-debug"]} { |
||||
dict set callopts -debug 1 |
||||
} |
||||
if {[dict exists $received --timeout]} { |
||||
dict set callopts -timeout [dict get $opts --timeout] ;#convert to single dash |
||||
} |
||||
set cmdname [dict get $values cmdname] |
||||
if {[dict exists $received cmdarg]} { |
||||
set cmdarglist [dict get $values cmdarg] |
||||
} else { |
||||
set cmdarglist {} |
||||
} |
||||
set cmdargs [concat $cmdname $cmdarglist] |
||||
|
||||
#shellfilter::run [lrange $args 1 end] -teehandle punksh -outchan stdout -inbuffering none -outbuffering none -stdinhandler ::repl::repl_handler |
||||
set exitinfo [shellfilter::run $cmdargs {*}$callopts -teehandle punksh -inbuffering none -outbuffering none ] |
||||
|
||||
flush stderr |
||||
flush stdout |
||||
|
||||
shellfilter::stack::remove stdout $stdout_stackid |
||||
shellfilter::stack::remove stderr $stderr_stackid |
||||
|
||||
#shellfilter::stack::remove commandout $outvar_stackid |
||||
|
||||
if {[dict exists $exitinfo error]} { |
||||
if {[dict exists $received "-tcl"]} { |
||||
|
||||
} else { |
||||
#we must raise an error. |
||||
#todo - check errorInfo makes sense.. return -code? tailcall? |
||||
# |
||||
set msg "" |
||||
append msg [dict get $exitinfo error] |
||||
append msg "\n(add -tcl option to run as a tcl command/script instead of an external command)" |
||||
error $msg |
||||
} |
||||
} |
||||
|
||||
set chunklist [list] |
||||
|
||||
#exitcode not part of return value for runout - colourcode appropriately |
||||
set n $RST |
||||
set c "" |
||||
|
||||
if {[dict exists $exitinfo exitcode]} { |
||||
set code [dict get $exitinfo exitcode] |
||||
if {$code == 0} { |
||||
set c [a+ green] |
||||
} else { |
||||
set c [a+ white bold] |
||||
} |
||||
lappend chunklist [list "info" "$c$exitinfo$n"] |
||||
} elseif {[dict exists $exitinfo error]} { |
||||
set c [a+ yellow bold] |
||||
lappend chunklist [list "info" "${c}error [dict get $exitinfo error]$n"] |
||||
lappend chunklist [list "info" "errorCode [dict get $exitinfo errorCode]"] |
||||
#lappend chunklist [list "info" "errorInfo [list [dict get $exitinfo errorInfo]]"] |
||||
lappend chunklist [list "info" errorInfo] |
||||
lappend chunklist [list "stderr" [dict get $exitinfo errorInfo]] |
||||
} else { |
||||
set c [a+ Yellow red bold] |
||||
#lappend chunklist [list "info" "$c$exitinfo$n"] |
||||
lappend chunklist [list "info" [punk::ansi::ansiwrap_raw $c \x1b\[m "" $exitinfo]] |
||||
} |
||||
|
||||
|
||||
set chunk "[a+ red bold]stderr$RST" |
||||
lappend chunklist [list "info" $chunk] |
||||
|
||||
set chunk "" |
||||
if {[string length $::shellrun::runerr]} { |
||||
if {$nonewline} { |
||||
set e [string trimright $::shellrun::runerr \r\n] |
||||
} else { |
||||
set e $::shellrun::runerr |
||||
} |
||||
#append chunk "[a+ red normal]$e$RST\n" |
||||
append chunk "[a+ red normal]$e$RST" |
||||
} |
||||
lappend chunklist [list stderr $chunk] |
||||
|
||||
|
||||
|
||||
|
||||
lappend chunklist [list "info" "[a+ white bold]stdout$RST"] |
||||
set chunk "" |
||||
if {[string length $::shellrun::runout]} { |
||||
if {$nonewline} { |
||||
set o [string trimright $::shellrun::runout \r\n] |
||||
} else { |
||||
set o $::shellrun::runout |
||||
} |
||||
append chunk "$o" |
||||
} |
||||
lappend chunklist [list result $chunk] |
||||
|
||||
|
||||
#set_last_run_display $chunklist |
||||
tsv::lappend repl runchunks-[tsv::get repl runid] {*}$chunklist |
||||
|
||||
if {$nonewline} { |
||||
return [string trimright $::shellrun::runout \r\n] |
||||
} else { |
||||
return $::shellrun::runout |
||||
} |
||||
} |
||||
|
||||
lappend PUNKARGS [list { |
||||
@id -id ::shellrun::runerr |
||||
@leaders -min 0 -max 0 |
||||
@opts |
||||
-echo -type none |
||||
-nonewline -type none |
||||
-tcl -type none -default 0 |
||||
-debug -type none -default 0 |
||||
--timeout= -type integer |
||||
@values -min 1 -max -1 |
||||
cmdname -type string |
||||
cmdarg -type any -multiple 1 -optional 1 |
||||
}] |
||||
proc runerr {args} { |
||||
set argd [punk::args::parse $args withid ::shellrun::runout] |
||||
lassign [dict values $argd] leaders opts values received |
||||
|
||||
if {[dict exists $received "-nonewline"]} { |
||||
set nonewline 1 |
||||
} else { |
||||
set nonewline 0 |
||||
} |
||||
|
||||
#set_last_run_display [list] |
||||
variable runout |
||||
variable runerr |
||||
set runout "" |
||||
set runerr "" |
||||
|
||||
#set splitargs [get_run_opts $args] |
||||
#set runopts [dict get $splitargs runopts] |
||||
#set cmdargs [dict get $splitargs cmdargs] |
||||
|
||||
set callopts [dict create] |
||||
if {[dict exists $received "-tcl"]} { |
||||
dict set callopts -tclscript 1 |
||||
} |
||||
if {[dict exists $received "-debug"]} { |
||||
dict set callopts -debug 1 |
||||
} |
||||
if {[dict exists $received --timeout]} { |
||||
dict set callopts -timeout [dict get $opts --timeout] ;#convert to single dash |
||||
} |
||||
set cmdname [dict get $values cmdname] |
||||
if {[dict exists $received cmdarg]} { |
||||
set cmdarglist [dict get $values cmdarg] |
||||
} else { |
||||
set cmdarglist {} |
||||
} |
||||
set cmdargs [concat $cmdname $cmdarglist] |
||||
|
||||
if {[dict exists $received "-tcl"]} { |
||||
append callopts " -tclscript 1" |
||||
} |
||||
if {[dict exists $received "-echo"]} { |
||||
set stderr_stackid [shellfilter::stack::add stderr tee_to_var -action float-locked -settings {-varname ::shellrun::runerr}] |
||||
set stdout_stackid [shellfilter::stack::add stdout tee_to_var -action float-locked -settings {-varname ::shellrun::runout}] |
||||
} else { |
||||
set stderr_stackid [shellfilter::stack::add stderr var -action float-locked -settings {-varname ::shellrun::runerr}] |
||||
set stdout_stackid [shellfilter::stack::add stdout var -action float-locked -settings {-varname ::shellrun::runout}] |
||||
} |
||||
|
||||
|
||||
set exitinfo [shellfilter::run $cmdargs {*}$callopts -teehandle punksh -inbuffering none -outbuffering none -stdinhandler ::repl::repl_handler] |
||||
shellfilter::stack::remove stderr $stderr_stackid |
||||
shellfilter::stack::remove stdout $stdout_stackid |
||||
|
||||
|
||||
flush stderr |
||||
flush stdout |
||||
|
||||
#we raise an error because an error during calling is different to collecting stderr from a command, and the caller should be able to wrap in a catch |
||||
# to determine something other than just a nonzero exit code or output on stderr. |
||||
if {[dict exists $exitinfo error]} { |
||||
if {[dict exists $received "-tcl"]} { |
||||
|
||||
} else { |
||||
#todo - check errorInfo makes sense.. return -code? tailcall? |
||||
error [dict get $exitinfo error] |
||||
} |
||||
} |
||||
|
||||
set chunklist [list] |
||||
|
||||
set n [a] |
||||
set c "" |
||||
if {[dict exists $exitinfo exitcode]} { |
||||
set code [dict get $exitinfo exitcode] |
||||
if {$code == 0} { |
||||
set c [a+ green] |
||||
} else { |
||||
set c [a+ white bold] |
||||
} |
||||
lappend chunklist [list "info" "$c$exitinfo$n"] |
||||
} elseif {[dict exists $exitinfo error]} { |
||||
set c [a+ yellow bold] |
||||
lappend chunklist [list "info" "error [dict get $exitinfo error]"] |
||||
lappend chunklist [list "info" "errorCode [dict get $exitinfo errorCode]"] |
||||
lappend chunklist [list "info" "errorInfo [list [dict get $exitinfo errorInfo]]"] |
||||
} else { |
||||
set c [a+ Yellow red bold] |
||||
#lappend chunklist [list "info" "$c$exitinfo$n"] |
||||
lappend chunklist [list "info" [punk::ansi::ansiwrap_raw $c "\x1b\[m" "" $exitinfo]] |
||||
} |
||||
|
||||
|
||||
lappend chunklist [list "info" "[a+ white bold]stdout[a]"] |
||||
set chunk "" |
||||
if {[string length $::shellrun::runout]} { |
||||
if {$nonewline} { |
||||
set o [string trimright $::shellrun::runout \r\n] |
||||
} else { |
||||
set o $::shellrun::runout |
||||
} |
||||
append chunk "[a+ white normal]$o[a]\n" ;#this newline is the display output separator - always there whether data has trailing newline or not. |
||||
} |
||||
lappend chunklist [list stdout $chunk] |
||||
|
||||
|
||||
#set c_stderr [punk::config] |
||||
set chunk "[a+ red bold]stderr[a]" |
||||
lappend chunklist [list "info" $chunk] |
||||
|
||||
set chunk "" |
||||
if {[string length $::shellrun::runerr]} { |
||||
if {$nonewline} { |
||||
set e [string trimright $::shellrun::runerr \r\n] |
||||
} else { |
||||
set e $::shellrun::runerr |
||||
} |
||||
append chunk "$e" |
||||
} |
||||
lappend chunklist [list resulterr $chunk] |
||||
|
||||
|
||||
#set_last_run_display $chunklist |
||||
tsv::lappend repl runchunks-[tsv::get repl runid] {*}$chunklist |
||||
|
||||
if {$nonewline} { |
||||
return [string trimright $::shellrun::runerr \r\n] |
||||
} |
||||
return $::shellrun::runerr |
||||
} |
||||
|
||||
|
||||
proc runx {args} { |
||||
#set_last_run_display [list] |
||||
variable runout |
||||
variable runerr |
||||
set runout "" |
||||
set runerr "" |
||||
|
||||
set splitargs [get_run_opts $args] |
||||
set runopts [dict get $splitargs runopts] |
||||
set cmdargs [dict get $splitargs cmdargs] |
||||
|
||||
if {"-nonewline" in $runopts} { |
||||
set nonewline 1 |
||||
} else { |
||||
set nonewline 0 |
||||
} |
||||
|
||||
#shellfilter::stack::remove stdout $::repl::id_outstack |
||||
|
||||
if {"-echo" in $runopts} { |
||||
#float to ensure repl transform doesn't interfere with the output data |
||||
set stderr_stackid [shellfilter::stack::add stderr tee_to_var -action float -settings {-varname ::shellrun::runerr}] |
||||
set stdout_stackid [shellfilter::stack::add stdout tee_to_var -action float -settings {-varname ::shellrun::runout}] |
||||
} else { |
||||
#set stderr_stackid [shellfilter::stack::add stderr var -action sink-locked -settings {-varname ::shellrun::runerr}] |
||||
#set stdout_stackid [shellfilter::stack::add stdout var -action sink-locked -settings {-varname ::shellrun::runout}] |
||||
|
||||
#float above the repl's tee_to_var to deliberately block it. |
||||
#a var transform is naturally a junction point because there is no flow-through.. |
||||
# - but mark it with -junction 1 just to be explicit |
||||
set stderr_stackid [shellfilter::stack::add stderr var -action float-locked -junction 1 -settings {-varname ::shellrun::runerr}] |
||||
set stdout_stackid [shellfilter::stack::add stdout var -action float-locked -junction 1 -settings {-varname ::shellrun::runout}] |
||||
} |
||||
|
||||
set callopts "" |
||||
if {"-tcl" in $runopts} { |
||||
append callopts " -tclscript 1" |
||||
} |
||||
#set exitinfo [shellfilter::run $cmdargs -teehandle punksh -inbuffering none -outbuffering none -stdinhandler ::repl::repl_handler] |
||||
set exitinfo [shellfilter::run $cmdargs {*}$callopts -teehandle punksh -inbuffering none -outbuffering none] |
||||
|
||||
shellfilter::stack::remove stdout $stdout_stackid |
||||
shellfilter::stack::remove stderr $stderr_stackid |
||||
|
||||
|
||||
flush stderr |
||||
flush stdout |
||||
|
||||
if {[dict exists $exitinfo error]} { |
||||
if {"-tcl" in $runopts} { |
||||
|
||||
} else { |
||||
#todo - check errorInfo makes sense.. return -code? tailcall? |
||||
error [dict get $exitinfo error] |
||||
} |
||||
} |
||||
|
||||
#set x [shellfilter::stack::add stdout var -action sink-locked -settings {-varname ::repl::runxoutput}] |
||||
|
||||
set chunk "" |
||||
if {[string length $::shellrun::runout]} { |
||||
if {$nonewline} { |
||||
set o [string trimright $::shellrun::runout \r\n] |
||||
} else { |
||||
set o $::shellrun::runout |
||||
} |
||||
set chunk $o |
||||
} |
||||
set chunklist [list] |
||||
lappend chunklist [list "info" " "] |
||||
lappend chunklist [list "result" stdout] ;#key 'stdout' forms part of the resulting dictionary output |
||||
lappend chunklist [list "info" "[a+ white bold]stdout[a]"] |
||||
lappend chunklist [list result $chunk] ;#value corresponding to 'stdout' key in resulting dict |
||||
|
||||
|
||||
lappend chunklist [list "info" " "] |
||||
set chunk "[a+ red bold]stderr[a]" |
||||
lappend chunklist [list "result" $chunk] |
||||
lappend chunklist [list "info" stderr] |
||||
|
||||
set chunk "" |
||||
if {[string length $::shellrun::runerr]} { |
||||
if {$nonewline} { |
||||
set e [string trimright $::shellrun::runerr \r\n] |
||||
} else { |
||||
set e $::shellrun::runerr |
||||
} |
||||
set chunk $e |
||||
} |
||||
#stderr is part of the result |
||||
lappend chunklist [list "resulterr" $chunk] |
||||
|
||||
|
||||
|
||||
set n [a] |
||||
set c "" |
||||
if {[dict exists $exitinfo exitcode]} { |
||||
set code [dict get $exitinfo exitcode] |
||||
if {$code == 0} { |
||||
set c [a+ green] |
||||
} else { |
||||
set c [a+ yellow bold] |
||||
} |
||||
lappend chunklist [list "info" " "] |
||||
lappend chunklist [list "result" exitcode] |
||||
lappend chunklist [list "info" "exitcode $code"] |
||||
lappend chunklist [list "result" "$c$code$n"] |
||||
set exitdict [list exitcode $code] |
||||
} elseif {[dict exists $exitinfo result]} { |
||||
# presumably from a -tcl call |
||||
set val [dict get $exitinfo result] |
||||
lappend chunklist [list "info" " "] |
||||
lappend chunklist [list "result" result] |
||||
lappend chunklist [list "info" result] |
||||
lappend chunklist [list "result" $val] |
||||
set exitdict [list result $val] |
||||
} elseif {[dict exists $exitinfo error]} { |
||||
# -tcl call with error |
||||
#set exitdict [dict create] |
||||
lappend chunklist [list "info" " "] |
||||
lappend chunklist [list "result" error] |
||||
lappend chunklist [list "info" error] |
||||
lappend chunklist [list "result" [dict get $exitinfo error]] |
||||
|
||||
lappend chunklist [list "info" " "] |
||||
lappend chunklist [list "result" errorCode] |
||||
lappend chunklist [list "info" errorCode] |
||||
lappend chunklist [list "result" [dict get $exitinfo errorCode]] |
||||
|
||||
lappend chunklist [list "info" " "] |
||||
lappend chunklist [list "result" errorInfo] |
||||
lappend chunklist [list "info" errorInfo] |
||||
lappend chunklist [list "result" [dict get $exitinfo errorInfo]] |
||||
|
||||
set exitdict $exitinfo |
||||
} else { |
||||
#review - if no exitcode or result. then what is it? |
||||
lappend chunklist [list "info" exitinfo] |
||||
set c [a+ yellow bold] |
||||
lappend chunklist [list result "$c$exitinfo$n"] |
||||
set exitdict [list exitinfo $exitinfo] |
||||
} |
||||
|
||||
#set_last_run_display $chunklist |
||||
tsv::lappend repl runchunks-[tsv::get repl runid] {*}$chunklist |
||||
|
||||
#set ::repl::result_print 0 |
||||
#return [lindex [list [list stdout $::runout stderr $::runerr {*}$exitinfo] [shellfilter::stack::remove stdout $x][puts -nonewline stdout $pretty][set ::repl::output ""]] 0] |
||||
|
||||
|
||||
if {$nonewline} { |
||||
return [list {*}$exitdict stdout [string trimright $::shellrun::runout \r\n] stderr [string trimright $::shellrun::runerr \r\n]] |
||||
} |
||||
#always return exitinfo $code at beginning of dict (so that punk unknown can interpret the exit code as a unix-style bool if double evaluated) |
||||
return [list {*}$exitdict stdout $::shellrun::runout stderr $::shellrun::runerr] |
||||
} |
||||
|
||||
#an experiment |
||||
# |
||||
#run as raw string instead of tcl-list - no variable subst etc |
||||
# |
||||
#dummy repl_runraw that repl will intercept |
||||
proc repl_runraw {args} { |
||||
error "runraw: only available in repl as direct call - not from script" |
||||
} |
||||
#we can only call runraw with a single (presumably braced) string if we want to use it from both repl and tcl scripts (why? todo with unbalanced quotes/braces?) |
||||
proc runraw {commandline} { |
||||
#runraw fails as intended - because we can't bypass exec/open interference quoting :/ |
||||
#set_last_run_display [list] |
||||
variable runout |
||||
variable runerr |
||||
set runout "" |
||||
set runerr "" |
||||
|
||||
#return [shellfilter::run [lrange $args 1 end] -teehandle punksh -inbuffering none -outbuffering none -stdinhandler ::repl::repl_handler] |
||||
puts stdout ">>runraw got: $commandline" |
||||
|
||||
#run always echoes anyway.. as we aren't diverting stdout/stderr off for capturing |
||||
#for consistency with other runxxx commands - we'll just consume it. (review) |
||||
|
||||
set reallyraw 1 |
||||
if {$reallyraw} { |
||||
set wordparts [regexp -inline -all {\S+} $commandline] |
||||
set runwords $wordparts |
||||
} else { |
||||
#shell style args parsing not suitable for windows where we can't assume matched quotes etc. |
||||
package require string::token::shell |
||||
set parts [string token shell -indices -- $commandline] |
||||
puts stdout ">>shellparts: $parts" |
||||
set runwords [list] |
||||
foreach p $parts { |
||||
set ptype [lindex $p 0] |
||||
set pval [lindex $p 3] |
||||
if {$ptype eq "PLAIN"} { |
||||
lappend runwords [lindex $p 3] |
||||
} elseif {$ptype eq "D:QUOTED"} { |
||||
set v {"} |
||||
append v $pval |
||||
append v {"} |
||||
lappend runwords $v |
||||
} elseif {$ptype eq "S:QUOTED"} { |
||||
set v {'} |
||||
append v $pval |
||||
append v {'} |
||||
lappend runwords $v |
||||
} |
||||
} |
||||
} |
||||
|
||||
puts stdout ">>runraw runwords: $runwords" |
||||
set runwords [lrange $runwords 1 end] |
||||
|
||||
puts stdout ">>runraw runwords: $runwords" |
||||
#set args [lrange $args 1 end] |
||||
#set runwords [lrange $wordparts 1 end] |
||||
|
||||
set known_runopts [list "-echo" "-e" "-terminal" "-t"] |
||||
set aliases [list "-e" "-echo" "-echo" "-echo" "-t" "-terminal" "-terminal" "-terminal"] ;#include map to self |
||||
set runopts [list] |
||||
set cmdwords [list] |
||||
set idx_first_cmdarg [lsearch -not $runwords "-*"] |
||||
set runopts [lrange $runwords 0 $idx_first_cmdarg-1] |
||||
set cmdwords [lrange $runwords $idx_first_cmdarg end] |
||||
|
||||
foreach o $runopts { |
||||
if {$o ni $known_runopts} { |
||||
error "runraw: Unknown runoption $o" |
||||
} |
||||
} |
||||
set runopts [lmap o $runopts {dict get $aliases $o}] |
||||
|
||||
set cmd_as_string [join $cmdwords " "] |
||||
puts stdout ">>cmd_as_string: $cmd_as_string" |
||||
|
||||
if {"-terminal" in $runopts} { |
||||
#fake terminal using 'script' command. |
||||
#not ideal: smushes stdout & stderr together amongst other problems |
||||
set tcmd [shellfilter::get_scriptrun_from_cmdlist_dquote_if_not $cmdwords] |
||||
puts stdout ">>tcmd: $tcmd" |
||||
set exitinfo [shellfilter::run $tcmd -teehandle punksh -inbuffering line -outbuffering none ] |
||||
set exitinfo "exitcode not-implemented" |
||||
} else { |
||||
set exitinfo [shellfilter::run $cmdwords -teehandle punksh -inbuffering line -outbuffering none ] |
||||
} |
||||
|
||||
if {[dict exists $exitinfo error]} { |
||||
#todo - check errorInfo makes sense.. return -code? tailcall? |
||||
error [dict get $exitinfo error] |
||||
} |
||||
set code [dict get $exitinfo exitcode] |
||||
if {$code == 0} { |
||||
set c [a+ green] |
||||
} else { |
||||
set c [a+ white bold] |
||||
} |
||||
puts stderr $c |
||||
return $exitinfo |
||||
} |
||||
|
||||
proc sh_run {args} { |
||||
set splitargs [get_run_opts $args] |
||||
set runopts [dict get $splitargs runopts] |
||||
set cmdargs [dict get $splitargs cmdargs] |
||||
#e.g sh -c "ls -l *" |
||||
#we pass cmdargs to sh -c as a list, not individually |
||||
tailcall shellrun::run {*}$runopts sh -c $cmdargs |
||||
} |
||||
proc sh_runout {args} { |
||||
set splitargs [get_run_opts $args] |
||||
set runopts [dict get $splitargs runopts] |
||||
set cmdargs [dict get $splitargs cmdargs] |
||||
tailcall shellrun::runout {*}$runopts sh -c $cmdargs |
||||
} |
||||
proc sh_runerr {args} { |
||||
set splitargs [get_run_opts $args] |
||||
set runopts [dict get $splitargs runopts] |
||||
set cmdargs [dict get $splitargs cmdargs] |
||||
tailcall shellrun::runerr {*}$runopts sh -c $cmdargs |
||||
} |
||||
proc sh_runx {args} { |
||||
set splitargs [get_run_opts $args] |
||||
set runopts [dict get $splitargs runopts] |
||||
set cmdargs [dict get $splitargs cmdargs] |
||||
tailcall shellrun::runx {*}$runopts sh -c $cmdargs |
||||
} |
||||
} |
||||
|
||||
namespace eval shellrun { |
||||
interp alias {} run {} shellrun::run |
||||
interp alias {} sh_run {} shellrun::sh_run |
||||
interp alias {} runout {} shellrun::runout |
||||
interp alias {} sh_runout {} shellrun::sh_runout |
||||
interp alias {} runerr {} shellrun::runerr |
||||
interp alias {} sh_runerr {} shellrun::sh_runerr |
||||
interp alias {} runx {} shellrun::runx |
||||
interp alias {} sh_runx {} shellrun::sh_runx |
||||
|
||||
interp alias {} runc {} shellrun::runconsole |
||||
interp alias {} runraw {} shellrun::runraw |
||||
|
||||
|
||||
#the shortened versions deliberately don't get pretty output from the repl |
||||
interp alias {} r {} shellrun::run |
||||
interp alias {} ro {} shellrun::runout |
||||
interp alias {} re {} shellrun::runerr |
||||
interp alias {} rx {} shellrun::runx |
||||
|
||||
|
||||
} |
||||
|
||||
namespace eval shellrun { |
||||
proc test_cffi {} { |
||||
package require test_cffi |
||||
cffi::Wrapper create ::shellrun::kernel32 [file join $env(windir) system32 Kernel32.dll] |
||||
::shellrun::kernel32 stdcall CreateProcessA |
||||
#todo - stuff. |
||||
return ::shellrun::kernel32 |
||||
} |
||||
|
||||
} |
||||
namespace eval ::punk::args::register { |
||||
#use fully qualified so 8.6 doesn't find existing var in global namespace |
||||
lappend ::punk::args::register::NAMESPACES ::shellrun |
||||
} |
||||
|
||||
|
||||
package provide shellrun [namespace eval shellrun { |
||||
variable version |
||||
set version 0.1.1 |
||||
}] |
||||
@ -0,0 +1,826 @@
|
||||
#package require logger |
||||
|
||||
|
||||
package require Thread |
||||
|
||||
namespace eval shellthread { |
||||
|
||||
proc iso8601 {{tsmicros ""}} { |
||||
if {$tsmicros eq ""} { |
||||
set tsmicros [tcl::clock::microseconds] |
||||
} else { |
||||
set microsnow [tcl::clock::microseconds] |
||||
if {[tcl::string::length $tsmicros] != [tcl::string::length $microsnow]} { |
||||
error "iso8601 requires 'clock micros' or empty string to create timestamp" |
||||
} |
||||
} |
||||
set seconds [expr {$tsmicros / 1000000}] |
||||
return [tcl::clock::format $seconds -format "%Y-%m-%d_%H-%M-%S"] |
||||
} |
||||
} |
||||
|
||||
namespace eval shellthread::worker { |
||||
variable settings |
||||
variable sysloghost_port |
||||
variable sock |
||||
variable logfile "" |
||||
variable fd |
||||
variable client_ids [list] |
||||
variable ts_start_micros |
||||
variable errorlist [list] |
||||
variable inpipe "" |
||||
|
||||
proc bgerror {args} { |
||||
variable errorlist |
||||
lappend errorlist $args |
||||
} |
||||
proc send_errors_now {tidcli} { |
||||
variable errorlist |
||||
thread::send -async $tidcli [list shellthread::manager::report_worker_errors [list worker_tid [thread::id] errors $errorlist]] |
||||
} |
||||
proc add_client_tid {tidcli} { |
||||
variable client_ids |
||||
if {$tidcli ni $client_ids} { |
||||
lappend client_ids $tidcli |
||||
} |
||||
} |
||||
proc init {tidclient start_m settingsdict} { |
||||
variable sysloghost_port |
||||
variable logfile |
||||
variable settings |
||||
interp bgerror {} shellthread::worker::bgerror |
||||
#package require overtype ;#overtype uses tcllib textutil, punk::char etc - currently too heavyweight in terms of loading time for use in threads. |
||||
variable client_ids |
||||
variable ts_start_micros |
||||
lappend client_ids $tidclient |
||||
set ts_start_micros $start_m |
||||
|
||||
set defaults [list -raw 0 -file "" -syslog "" -direction out] |
||||
set settings [dict merge $defaults $settingsdict] |
||||
|
||||
set syslog [dict get $settings -syslog] |
||||
if {[string length $syslog]} { |
||||
lassign [split $syslog :] s_host s_port |
||||
set sysloghost_port [list $s_host $s_port] |
||||
if {[catch {package require udp} errm]} { |
||||
#disable rather than bomb and interfere with any -file being written |
||||
#review - log/notify? |
||||
set sysloghost_port "" |
||||
} |
||||
} else { |
||||
set sysloghost_port "" |
||||
} |
||||
|
||||
set logfile [dict get $settings -file] |
||||
} |
||||
|
||||
proc start_pipe_read {source readchan args} { |
||||
#assume 1 inpipe for now |
||||
variable inpipe |
||||
variable sysloghost_port |
||||
variable logfile |
||||
|
||||
set defaults [dict create -buffering \uFFFF ] |
||||
set opts [dict merge $defaults $args] |
||||
if {[dict exists $opts -readbuffering]} { |
||||
set readbuffering [dict get $opts -readbuffering] |
||||
} else { |
||||
if {[dict get $opts -buffering] eq "\uFFFF"} { |
||||
#get buffering setting from the channel as it was set prior to thread::transfer |
||||
set readbuffering [chan configure $readchan -buffering] |
||||
} else { |
||||
set readbuffering [dict get $opts -buffering] |
||||
chan configure $readchan -buffering $readbuffering |
||||
} |
||||
} |
||||
if {[dict exists $opts -writebuffering]} { |
||||
set writebuffering [dict get $opts -writebuffering] |
||||
} else { |
||||
if {[dict get $opts -buffering] eq "\uFFFF"} { |
||||
set writebuffering line |
||||
#set writebuffering [chan configure $writechan -buffering] |
||||
} else { |
||||
set writebuffering [dict get $opts -buffering] |
||||
#can configure $writechan -buffering $writebuffering |
||||
} |
||||
} |
||||
|
||||
chan configure $readchan -translation lf |
||||
|
||||
if {$readchan ni [chan names]} { |
||||
error "shellthread::worker::start_pipe_read - inpipe not configured. Use shellthread::manager::set_pipe_read_from_client to thread::transfer the pipe end" |
||||
} |
||||
set inpipe $readchan |
||||
chan configure $readchan -blocking 0 |
||||
set waitvar ::shellthread::worker::wait($inpipe,[clock micros]) |
||||
|
||||
#tcl::chan::fifo2 based pipe seems slower to establish events upon than Memchan |
||||
chan event $readchan readable [list ::shellthread::worker::pipe_read $readchan $source $waitvar $readbuffering $writebuffering] |
||||
vwait $waitvar |
||||
} |
||||
proc pipe_read {chan source waitfor readbuffering writebuffering} { |
||||
if {$readbuffering eq "line"} { |
||||
set chunksize [chan gets $chan chunk] |
||||
if {$chunksize >= 0} { |
||||
if {![chan eof $chan]} { |
||||
::shellthread::worker::log pipe 0 - $source - info $chunk\n $writebuffering |
||||
} else { |
||||
::shellthread::worker::log pipe 0 - $source - info $chunk $writebuffering |
||||
} |
||||
} |
||||
} else { |
||||
set chunk [chan read $chan] |
||||
::shellthread::worker::log pipe 0 - $source - info $chunk $writebuffering |
||||
} |
||||
if {[chan eof $chan]} { |
||||
chan event $chan readable {} |
||||
set $waitfor "pipe" |
||||
chan close $chan |
||||
} |
||||
} |
||||
|
||||
proc start_pipe_write {source writechan args} { |
||||
variable outpipe |
||||
set defaults [dict create -buffering \uFFFF ] |
||||
set opts [dict merge $defaults $args] |
||||
|
||||
#todo! |
||||
set readchan stdin |
||||
|
||||
if {[dict exists $opts -readbuffering]} { |
||||
set readbuffering [dict get $opts -readbuffering] |
||||
} else { |
||||
if {[dict get $opts -buffering] eq "\uFFFF"} { |
||||
set readbuffering [chan configure $readchan -buffering] |
||||
} else { |
||||
set readbuffering [dict get $opts -buffering] |
||||
chan configure $readchan -buffering $readbuffering |
||||
} |
||||
} |
||||
if {[dict exists $opts -writebuffering]} { |
||||
set writebuffering [dict get $opts -writebuffering] |
||||
} else { |
||||
if {[dict get $opts -buffering] eq "\uFFFF"} { |
||||
#nothing explicitly set - take from transferred channel |
||||
set writebuffering [chan configure $writechan -buffering] |
||||
} else { |
||||
set writebuffering [dict get $opts -buffering] |
||||
can configure $writechan -buffering $writebuffering |
||||
} |
||||
} |
||||
|
||||
if {$writechan ni [chan names]} { |
||||
error "shellthread::worker::start_pipe_write - outpipe not configured. Use shellthread::manager::set_pipe_write_to_client to thread::transfer the pipe end" |
||||
} |
||||
set outpipe $writechan |
||||
chan configure $readchan -blocking 0 |
||||
chan configure $writechan -blocking 0 |
||||
set waitvar ::shellthread::worker::wait($outpipe,[clock micros]) |
||||
|
||||
chan event $readchan readable [list apply {{chan writechan source waitfor readbuffering} { |
||||
if {$readbuffering eq "line"} { |
||||
set chunksize [chan gets $chan chunk] |
||||
if {$chunksize >= 0} { |
||||
if {![chan eof $chan]} { |
||||
puts $writechan $chunk |
||||
} else { |
||||
puts -nonewline $writechan $chunk |
||||
} |
||||
} |
||||
} else { |
||||
set chunk [chan read $chan] |
||||
puts -nonewline $writechan $chunk |
||||
} |
||||
if {[chan eof $chan]} { |
||||
chan event $chan readable {} |
||||
set $waitfor "pipe" |
||||
chan close $writechan |
||||
if {$chan ne "stdin"} { |
||||
chan close $chan |
||||
} |
||||
} |
||||
}} $readchan $writechan $source $waitvar $readbuffering] |
||||
|
||||
vwait $waitvar |
||||
} |
||||
|
||||
|
||||
proc _initsock {} { |
||||
variable sysloghost_port |
||||
variable sock |
||||
if {[string length $sysloghost_port]} { |
||||
if {[catch {chan configure $sock} state]} { |
||||
set sock [udp_open] |
||||
chan configure $sock -buffering none -translation binary |
||||
chan configure $sock -remote $sysloghost_port |
||||
} |
||||
} |
||||
} |
||||
proc _reconnect {} { |
||||
variable sock |
||||
catch {close $sock} |
||||
_initsock |
||||
return [chan configure $sock] |
||||
} |
||||
|
||||
proc send_info {client_tid ts_sent source msg} { |
||||
set ts_received [clock micros] |
||||
set lag_micros [expr {$ts_received - $ts_sent}] |
||||
set lag [expr {$lag_micros / 1000000.0}] ;#lag as x.xxxxxx seconds |
||||
log $client_tid $ts_sent $lag $source - info $msg line 1 |
||||
} |
||||
proc log {client_tid ts_sent lag source service level msg writebuffering {islog 0}} { |
||||
variable sock |
||||
variable fd |
||||
variable sysloghost_port |
||||
variable logfile |
||||
variable settings |
||||
|
||||
set logchunk $msg |
||||
|
||||
if {![dict get $settings -raw]} { |
||||
set tail_crlf 0 |
||||
set tail_lf 0 |
||||
set tail_cr 0 |
||||
#for cooked - always remove the trailing newline before splitting.. |
||||
# |
||||
#note that if we got our data from reading a non-line-buffered binary channel - then this naive line splitting will not split neatly for mixed line-endings. |
||||
# |
||||
#Possibly not critical as cooked is for logging and we are still preserving all \r and \n chars - but review and consider implementing a better split |
||||
#but add it back exactly as it was afterwards |
||||
#we can always split on \n - and any adjacent \r will be preserved in the rejoin |
||||
set lastchar [string range $logchunk end end] |
||||
if {[string range $logchunk end-1 end] eq "\r\n"} { |
||||
set tail_crlf 1 |
||||
set logchunk [string range $logchunk 0 end-2] |
||||
} else { |
||||
if {$lastchar eq "\n"} { |
||||
set tail_lf 1 |
||||
set logchunk [string range $logchunk 0 end-1] |
||||
} elseif {$lastchar eq "\r"} { |
||||
#\r line-endings are obsolete..and unlikely... and ugly as they can hide characters on the console. but we'll pass through anyway. |
||||
set tail_cr 1 |
||||
set logchunk [string range $logchunk 0 end-1] |
||||
} else { |
||||
#possibly a single line with no linefeed.. or has linefeeds only in the middle |
||||
} |
||||
} |
||||
|
||||
if {$ts_sent != 0} { |
||||
set micros [lindex [split [expr {$ts_sent / 1000000.0}] .] end] |
||||
set time_info [::shellthread::iso8601 $ts_sent].$micros |
||||
#set time_info "${time_info}+$lag" |
||||
set lagfp "+[format %f $lag]" |
||||
} else { |
||||
#from pipe - no ts_sent/lag info available |
||||
set time_info "" |
||||
set lagfp "" |
||||
} |
||||
|
||||
set idtail [string range $client_tid end-8 end] ;#enough for display purposes id - mostly zeros anyway |
||||
|
||||
|
||||
#set col0 [string repeat " " 9] |
||||
#set col1 [string repeat " " 27] |
||||
#set col2 [string repeat " " 11] |
||||
#set col3 [string repeat " " 22] |
||||
##do not columnize the final data column or append to tail - or we could muck up the crlf integrity |
||||
#lassign [list [overtype::left $col0 $idtail] [overtype::left $col1 $time_info] [overtype::left $col2 $lagfp] [overtype::left $col3 $source]] c0 c1 c2 c3 |
||||
|
||||
set w0 9 |
||||
set w1 27 |
||||
set w2 11 |
||||
set w3 22 ;#review - this can truncate source name without indication tail is missing |
||||
#do not columnize the final data column or append to tail - or we could muck up the crlf integrity |
||||
lassign [list \ |
||||
[format %-${w0}s $idtail]\ |
||||
[format %-${w1}s $time_info]\ |
||||
[format %-${w2}s $lagfp]\ |
||||
[format %-${w3}s $source]\ |
||||
] c0 c1 c2 c3 |
||||
set c2_blank [string repeat " " $w2] |
||||
|
||||
|
||||
#split on \n no matter the actual line-ending in use |
||||
#shouldn't matter as long as we don't add anything at the end of the line other than the raw data |
||||
#ie - don't quote or add spaces |
||||
set lines [split $logchunk \n] |
||||
|
||||
set i 1 |
||||
set outlines [list] |
||||
foreach ln $lines { |
||||
if {$i == 1} { |
||||
lappend outlines "$c0 $c1 $c2 $c3 $ln" |
||||
} else { |
||||
lappend outlines "$c0 $c1 $c2_blank $c3 $ln" |
||||
} |
||||
incr i |
||||
} |
||||
if {$tail_lf} { |
||||
set logchunk "[join $outlines \n]\n" |
||||
} elseif {$tail_crlf} { |
||||
set logchunk "[join $outlines \r\n]\r\n" |
||||
} elseif {$tail_cr} { |
||||
set logchunk "[join $outlines \r]\r" |
||||
} else { |
||||
#no trailing linefeed |
||||
set logchunk [join $outlines \n] |
||||
|
||||
} |
||||
|
||||
#set logchunk "[overtype::left $col0 $idtail] [overtype::left $col1 $time_info] [overtype::left $col2 "+$lagfp"] [overtype::left $col3 $source] $msg" |
||||
} |
||||
|
||||
if {[string length $sysloghost_port]} { |
||||
_initsock |
||||
catch {puts -nonewline $sock $logchunk} |
||||
} |
||||
#todo - sockets etc? |
||||
if {[string length $logfile]} { |
||||
#todo - setting to maintain open filehandle and reduce io. |
||||
# possible settings for buffersize - and maybe logrotation, although this could be left to client |
||||
#for now - default to safe option of open/close each write despite the overhead. |
||||
set fd [open $logfile a] |
||||
chan configure $fd -translation auto -buffering $writebuffering |
||||
#whether line buffered or not - by now our logchunk includes newlines |
||||
puts -nonewline $fd $logchunk |
||||
close $fd |
||||
} |
||||
} |
||||
|
||||
# - withdraw just this client |
||||
proc finish {tidclient} { |
||||
variable client_ids |
||||
if {($tidclient in $clientids) && ([llength $clientids] == 1)} { |
||||
terminate $tidclient |
||||
} else { |
||||
set posn [lsearch $client_ids $tidclient] |
||||
set client_ids [lreplace $clientids $posn $posn] |
||||
} |
||||
} |
||||
|
||||
#allow any client to terminate |
||||
proc terminate {tidclient} { |
||||
variable sock |
||||
variable fd |
||||
variable client_ids |
||||
if {$tidclient in $client_ids} { |
||||
catch {close $sock} |
||||
catch {close $fd} |
||||
set client_ids [list] |
||||
#review use of thread::release -wait |
||||
#docs indicate deprecated for regular use, and that we should use thread::join |
||||
#however.. how can we set a timeout on a thread::join ? |
||||
#by telling the thread to release itself - we can wait on the thread::send variable |
||||
# This needs review - because it's unclear that -wait even works on self |
||||
# (what does it mean to wait for the target thread to exit if the target is self??) |
||||
thread::release -wait |
||||
return [thread::id] |
||||
} else { |
||||
return "" |
||||
} |
||||
} |
||||
|
||||
|
||||
} |
||||
|
||||
|
||||
namespace eval shellthread::manager { |
||||
variable workers [dict create] |
||||
variable worker_errors [list] |
||||
variable timeouts |
||||
|
||||
variable free_threads [list] |
||||
#variable log_threads |
||||
|
||||
proc dict_getdef {dictValue args} { |
||||
if {[llength $args] < 2} { |
||||
error {wrong # args: should be "dict_getdef dictValue ?key ...? key default"} |
||||
} |
||||
set keys [lrange $args 0 end-1] |
||||
if {[tcl::dict::exists $dictValue {*}$keys]} { |
||||
return [tcl::dict::get $dictValue {*}$keys] |
||||
} else { |
||||
return [lindex $args end] |
||||
} |
||||
} |
||||
#new datastructure regarding workers and sourcetags required. |
||||
#one worker can service multiple sourcetags - but each sourcetag may be used by multiple threads too. |
||||
#generally each thread will use a specific sourcetag - but we may have pools doing similar things which log to same destination. |
||||
# |
||||
#As a convention we may use a sourcetag for the thread which started the worker that isn't actually used for logging - but as a common target for joins |
||||
#If the thread which started the thread calls leave_worker with that 'primary' sourcetag it means others won't be able to use that target - which seems reasonable. |
||||
#If another thread want's to maintain joinability beyond the span provided by the starting client, |
||||
#it can join with both the primary tag and a tag it will actually use for logging. |
||||
#A thread can join the logger with any existingtag - not just the 'primary' |
||||
#(which is arbitrary anyway. It will usually be the first in the list - but may be unsubscribed by clients and disappear) |
||||
proc join_worker {existingtag sourcetaglist} { |
||||
set client_tid [thread::id] |
||||
#todo - allow a source to piggyback on existing worker by referencing one of the sourcetags already using the worker |
||||
} |
||||
|
||||
proc new_pipe_worker {sourcetaglist {settingsdict {}}} { |
||||
if {[dict exists $settingsdict -workertype]} { |
||||
if {[string tolower [dict get $settingsdict -workertype]] ne "pipe"} { |
||||
error "new_pipe_worker error: -workertype ne 'pipe'. Set to 'pipe' or leave empty" |
||||
} |
||||
} |
||||
dict set settingsdict -workertype pipe |
||||
new_worker $sourcetaglist $settingsdict |
||||
} |
||||
|
||||
#it is up to caller to use a unique sourcetag (e.g by prefixing with own thread::id etc) |
||||
# This allows multiple threads to more easily write to the same named sourcetag if necessary |
||||
# todo - change sourcetag for a list of tags which will be handled by the same thread. e.g for multiple threads logging to same file |
||||
# |
||||
# todo - some protection mechanism for case where target is a file to stop creation of multiple worker threads writing to same file. |
||||
# Even if we use open fd,close fd wrapped around writes.. it is probably undesirable to have multiple threads with same target |
||||
# On the other hand socket targets such as UDP can happily be written to by multiple threads. |
||||
# For now the mechanism is that a call to new_worker (rename to open_worker?) will join the same thread if a sourcetag matches. |
||||
# but, as sourcetags can get removed(unsubbed via leave_worker) this doesn't guarantee two threads with same -file settings won't fight. |
||||
# Also.. the settingsdict is ignored when joining with a tag that exists.. this is problematic.. e.g logrotation where previous file still being written by existing worker |
||||
# todo - rename 'sourcetag' concept to 'targettag' ?? the concept is a mixture of both.. it is somewhat analagous to a syslog 'facility' |
||||
# probably new_worker should disallow auto-joining and we allow different workers to handle same tags simultaneously to support overlap during logrotation etc. |
||||
proc new_worker {sourcetaglist {settingsdict {}}} { |
||||
variable workers |
||||
set ts_start [clock micros] |
||||
set tidclient [thread::id] |
||||
set sourcetag [lindex $sourcetaglist 0] ;#todo - use all |
||||
|
||||
set defaults [dict create\ |
||||
-workertype message\ |
||||
] |
||||
set settingsdict [dict merge $defaults $settingsdict] |
||||
|
||||
set workertype [string tolower [dict get $settingsdict -workertype]] |
||||
set known_workertypes [list pipe message] |
||||
if {$workertype ni $known_workertypes} { |
||||
error "new_worker - unknown -workertype $workertype. Expected one of '$known_workertypes'" |
||||
} |
||||
|
||||
if {[dict exists $workers $sourcetag]} { |
||||
set winfo [dict get $workers $sourcetag] |
||||
if {[dict get $winfo tid] ne "noop" && [thread::exists [dict get $winfo tid]]} { |
||||
#add our client-info to existing worker thread |
||||
dict lappend winfo list_client_tids $tidclient |
||||
dict set workers $sourcetag $winfo ;#writeback |
||||
return [dict get $winfo tid] |
||||
} |
||||
} |
||||
|
||||
#noop fake worker for empty syslog and empty file |
||||
if {$workertype eq "message"} { |
||||
if {[dict_getdef $settingsdict -syslog ""] eq "" && [dict_getdef $settingsdict -file ""] eq ""} { |
||||
set winfo [dict create tid noop list_client_tids [list $tidclient] ts_start $ts_start ts_end_list [list] workertype "message"] |
||||
dict set workers $sourcetag $winfo |
||||
return noop |
||||
} |
||||
} |
||||
|
||||
#check if there is an existing unsubscribed thread first |
||||
#don't use free_threads for pipe workertype for now.. |
||||
variable free_threads |
||||
if {$workertype ne "pipe"} { |
||||
if {[llength $free_threads]} { |
||||
#todo - re-use from tail - as most likely to have been doing similar work?? review |
||||
|
||||
set free_threads [lassign $free_threads tidworker] |
||||
#todo - keep track of real ts_start of free threads... kill when too old |
||||
set winfo [dict create tid $tidworker list_client_tids [list $tidclient] ts_start $ts_start ts_end_list [list] workertype [dict get $settingsdict -workertype]] |
||||
#puts stderr "shellfilter::new_worker Re-using free worker thread: $tidworker with tag $sourcetag" |
||||
dict set workers $sourcetag $winfo |
||||
return $tidworker |
||||
} |
||||
} |
||||
|
||||
|
||||
#set ts_start [::shellthread::iso8601] |
||||
set tidworker [thread::create -preserved] |
||||
set init_script [string map [list %ts_start% $ts_start %mp% [tcl::tm::list] %ap% $::auto_path %tidcli% $tidclient %sd% $settingsdict] { |
||||
#set tclbase [file dirname [file dirname [info nameofexecutable]]] |
||||
#set tcllib $tclbase/lib |
||||
#if {$tcllib ni $::auto_path} { |
||||
# lappend ::auto_path $tcllib |
||||
#} |
||||
|
||||
set ::settingsinfo [dict create %sd%] |
||||
#if the executable running things is something like a tclkit, |
||||
# then it's likely we will need to use the caller's auto_path and tcl::tm::list to find things |
||||
#The caller can tune the thread's package search by providing a settingsdict |
||||
#tcl::tm::add * must add in reverse order to get reulting list in same order as original |
||||
if {![dict exists $::settingsinfo tcl_tm_list]} { |
||||
#JMN2 |
||||
::tcl::tm::add {*}[lreverse [list %mp%]] |
||||
} else { |
||||
tcl::tm::remove {*}[tcl::tm::list] |
||||
::tcl::tm::add {*}[lreverse [dict get $::settingsinfo tcl_tm_list]] |
||||
} |
||||
if {![dict exists $::settingsinfo auto_path]} { |
||||
set ::auto_path [list %ap%] |
||||
} else { |
||||
set ::auto_path [dict get $::settingsinfo auto_path] |
||||
} |
||||
|
||||
package require punk::packagepreference |
||||
punk::packagepreference::install |
||||
|
||||
package require Thread |
||||
package require shellthread |
||||
if {![catch {::shellthread::worker::init %tidcli% %ts_start% $::settingsinfo} errmsg]} { |
||||
unset ::settingsinfo |
||||
set ::shellthread_init "ok" |
||||
} else { |
||||
unset ::settingsinfo |
||||
set ::shellthread_init "err $errmsg" |
||||
} |
||||
}] |
||||
|
||||
thread::send -async $tidworker $init_script |
||||
#thread::send $tidworker $init_script |
||||
set winfo [dict create tid $tidworker list_client_tids [list $tidclient] ts_start $ts_start ts_end_list [list]] |
||||
dict set workers $sourcetag $winfo |
||||
return $tidworker |
||||
} |
||||
|
||||
proc set_pipe_read_from_client {tag_pipename worker_tid rchan args} { |
||||
variable workers |
||||
if {![dict exists $workers $tag_pipename]} { |
||||
error "workerthread::manager::set_pipe_read_from_client source/pipename $tag_pipename not found" |
||||
} |
||||
set match_worker_tid [dict get $workers $tag_pipename tid] |
||||
if {$worker_tid ne $match_worker_tid} { |
||||
error "workerthread::manager::set_pipe_read_from_client source/pipename $tag_pipename workert_tid mismatch '$worker_tid' vs existing:'$match_worker_tid'" |
||||
} |
||||
#buffering set during channel creation will be preserved on thread::transfer |
||||
thread::transfer $worker_tid $rchan |
||||
#start_pipe_read will vwait - so we have to send async |
||||
thread::send -async $worker_tid [list ::shellthread::worker::start_pipe_read $tag_pipename $rchan] |
||||
#client may start writing immediately - but presumably it will buffer in fifo2 |
||||
} |
||||
|
||||
proc set_pipe_write_to_client {tag_pipename worker_tid wchan args} { |
||||
variable workers |
||||
if {![dict exists $workers $tag_pipename]} { |
||||
error "workerthread::manager::set_pipe_write_to_client pipename $tag_pipename not found" |
||||
} |
||||
set match_worker_tid [dict get $workers $tag_pipename tid] |
||||
if {$worker_tid ne $match_worker_tid} { |
||||
error "workerthread::manager::set_pipe_write_to_client pipename $tag_pipename workert_tid mismatch '$worker_tid' vs existing:'$match_worker_tid'" |
||||
} |
||||
#buffering set during channel creation will be preserved on thread::transfer |
||||
thread::transfer $worker_tid $wchan |
||||
thread::send -async $worker_tid [list ::shellthread::worker::start_pipe_write $tag_pipename $wchan] |
||||
} |
||||
|
||||
proc write_log {source msg args} { |
||||
variable workers |
||||
set ts_micros_sent [clock micros] |
||||
set defaults [list -async 1 -level info] |
||||
set opts [dict merge $defaults $args] |
||||
|
||||
if {[dict exists $workers $source]} { |
||||
set tidworker [dict get $workers $source tid] |
||||
if {$tidworker eq "noop"} { |
||||
return |
||||
} |
||||
if {![thread::exists $tidworker]} { |
||||
# -syslog -file ? |
||||
set tidworker [new_worker $source] |
||||
} |
||||
} else { |
||||
#auto create with no requirement to call new_worker.. warn? |
||||
# -syslog -file ? |
||||
error "write_log no log opened for source: $source" |
||||
set tidworker [new_worker $source] |
||||
} |
||||
set client_tid [thread::id] |
||||
if {[dict get $opts -async]} { |
||||
thread::send -async $tidworker [list ::shellthread::worker::send_info $client_tid $ts_micros_sent $source $msg] |
||||
} else { |
||||
thread::send $tidworker [list ::shellthread::worker::send_info $client_tid $ts_micros_sent $source $msg] |
||||
} |
||||
} |
||||
proc report_worker_errors {errdict} { |
||||
variable workers |
||||
set reporting_tid [dict get $errdict worker_tid] |
||||
dict for {src srcinfo} $workers { |
||||
if {[dict get $srcinfo tid] eq $reporting_tid} { |
||||
dict set srcinfo errors [dict get $errdict errors] |
||||
dict set workers $src $srcinfo ;#writeback updated |
||||
break |
||||
} |
||||
} |
||||
} |
||||
|
||||
#aka leave_worker |
||||
#Note that the tags may be on separate workertids, or some tags may share workertids |
||||
proc unsubscribe {sourcetaglist} { |
||||
variable workers |
||||
#workers structure example: |
||||
#[list sourcetag1 [list tid <tidworker> list_client_tids <clients>] ts_start <ts_start> ts_end_list {}] |
||||
variable free_threads |
||||
set mytid [thread::id] ;#caller of shellthread::manager::xxx is the client thread |
||||
|
||||
set subscriberless_tags [list] |
||||
foreach source $sourcetaglist { |
||||
if {[dict exists $workers $source]} { |
||||
set list_client_tids [dict get $workers $source list_client_tids] |
||||
if {[set posn [lsearch $list_client_tids $mytid]] >= 0} { |
||||
set list_client_tids [lreplace $list_client_tids $posn $posn] |
||||
dict set workers $source list_client_tids $list_client_tids |
||||
} |
||||
if {![llength $list_client_tids]} { |
||||
lappend subscriberless_tags $source |
||||
} |
||||
} |
||||
} |
||||
|
||||
#we've removed our own tid from all the tags - possibly across multiplew workertids, and possibly leaving some workertids with no subscribers for a particular tag - or no subscribers at all. |
||||
|
||||
set subscriberless_workers [list] |
||||
set shuttingdown_workers [list] |
||||
foreach deadtag $subscriberless_tags { |
||||
set workertid [dict get $workers $deadtag tid] |
||||
set worker_tags [get_worker_tagstate $workertid] |
||||
set subscriber_count 0 |
||||
set kill_count 0 ;#number of ts_end_list entries - even one indicates thread is doomed |
||||
foreach taginfo $worker_tags { |
||||
incr subscriber_count [llength [dict get $taginfo list_client_tids]] |
||||
incr kill_count [llength [dict get $taginfo ts_end_list]] |
||||
} |
||||
if {$subscriber_count == 0} { |
||||
lappend subscriberless_workers $workertid |
||||
} |
||||
if {$kill_count > 0} { |
||||
lappend shuttingdown_workers $workertid |
||||
} |
||||
} |
||||
|
||||
#if worker isn't shutting down - add it to free_threads list |
||||
foreach workertid $subscriberless_workers { |
||||
if {$workertid ni $shuttingdown_workers} { |
||||
if {$workertid ni $free_threads && $workertid ne "noop"} { |
||||
lappend free_threads $workertid |
||||
} |
||||
} |
||||
} |
||||
|
||||
#todo |
||||
#unsub this client_tid from the sourcetags in the sourcetaglist. if no more client_tids exist for sourcetag, remove sourcetag, |
||||
#if no more sourcetags - add worker to free_threads |
||||
} |
||||
proc get_worker_tagstate {workertid} { |
||||
variable workers |
||||
set taginfo_list [list] |
||||
dict for {source sourceinfo} $workers { |
||||
if {[dict get $sourceinfo tid] eq $workertid} { |
||||
lappend taginfo_list $sourceinfo |
||||
} |
||||
} |
||||
return $taginfo_list |
||||
} |
||||
|
||||
#finalisation |
||||
proc shutdown_free_threads {{timeout 2500}} { |
||||
variable free_threads |
||||
if {![llength $free_threads]} { |
||||
return |
||||
} |
||||
upvar ::shellthread::manager::timeouts timeoutarr |
||||
if {[info exists timeoutarr(shutdown_free_threads)]} { |
||||
#already called |
||||
return false |
||||
} |
||||
#set timeoutarr(shutdown_free_threads) waiting |
||||
#after $timeout [list set timeoutarr(shutdown_free_threads) timed-out] |
||||
set ::shellthread::waitfor waiting |
||||
after $timeout [list set ::shellthread::waitfor] |
||||
|
||||
set waiting_for [list] |
||||
set ended [list] |
||||
set timedout 0 |
||||
foreach tid $free_threads { |
||||
if {[thread::exists $tid]} { |
||||
lappend waiting_for $tid |
||||
#thread::send -async $tid [list shellthread::worker::terminate [thread::id]] timeoutarr(shutdown_free_threads) |
||||
thread::send -async $tid [list shellthread::worker::terminate [thread::id]] ::shellthread::waitfor |
||||
} |
||||
} |
||||
if {[llength $waiting_for]} { |
||||
for {set i 0} {$i < [llength $waiting_for]} {incr i} { |
||||
vwait ::shellthread::waitfor |
||||
if {$::shellthread::waitfor eq "timed-out"} { |
||||
set timedout 1 |
||||
break |
||||
} else { |
||||
lappend ended $::shellthread::waitfor |
||||
} |
||||
} |
||||
} |
||||
set free_threads [list] |
||||
return [dict create existed $waiting_for ended $ended timedout $timedout] |
||||
} |
||||
|
||||
#TODO - important. |
||||
#REVIEW! |
||||
#since moving to the unsubscribe mechansm - close_worker $source isn't being called |
||||
# - we need to set a limit to the number of free threads and shut down excess when detected during unsubscription |
||||
#instruction to shut-down the thread that has this source. |
||||
#instruction to shut-down the thread that has this source. |
||||
proc close_worker {source {timeout 2500}} { |
||||
variable workers |
||||
variable worker_errors |
||||
variable free_threads |
||||
upvar ::shellthread::manager::timeouts timeoutarr |
||||
set ts_now [clock micros] |
||||
#puts stderr "close_worker $source" |
||||
if {[dict exists $workers $source]} { |
||||
set tidworker [dict get $workers $source tid] |
||||
if {$tidworker in $freethreads} { |
||||
#make sure a thread that is being closed is removed from the free_threads list |
||||
set posn [lsearch $freethreads $tidworker] |
||||
set freethreads [lreplace $freethreads $posn $posn] |
||||
} |
||||
set mytid [thread::id] |
||||
set client_tids [dict get $workers $source list_client_tids] |
||||
if {[set posn [lsearch $client_tids $mytid]] >= 0} { |
||||
set client_tids [lreplace $client_tids $posn $posn] |
||||
#remove self from list of clients |
||||
dict set workers $source list_client_tids $client_tids |
||||
} |
||||
set ts_end_list [dict get $workers $source ts_end_list] ;#ts_end_list is just a list of timestamps of closing calls for this source - only one is needed to close, but they may all come in a flurry. |
||||
if {[llength $ts_end_list]} { |
||||
set last_end_ts [lindex $ts_end_list end] |
||||
if {(($tsnow - $last_end_ts) / 1000) >= $timeout} { |
||||
lappend ts_end_list $ts_now |
||||
dict set workers $source ts_end_list $ts_end_list |
||||
} else { |
||||
#existing close in progress.. assume it will work |
||||
return |
||||
} |
||||
} |
||||
|
||||
if {[thread::exists $tidworker]} { |
||||
#puts stderr "shellthread::manager::close_worker: thread $tidworker for source $source still running.. terminating" |
||||
|
||||
#review - timeoutarr is local var (?) |
||||
set timeoutarr($source) 0 |
||||
after $timeout [list set timeoutarr($source) 2] |
||||
|
||||
thread::send -async $tidworker [list shellthread::worker::send_errors_now [thread::id]] |
||||
thread::send -async $tidworker [list shellthread::worker::terminate [thread::id]] timeoutarr($source) |
||||
|
||||
#thread::send -async $tidworker [string map [list %tidclient% [thread::id]] { |
||||
# shellthread::worker::terminate %tidclient% |
||||
#}] timeoutarr($source) |
||||
|
||||
vwait timeoutarr($source) |
||||
#puts stderr "shellthread::manager::close_worker: thread $tidworker for source $source DONE1" |
||||
|
||||
thread::release $tidworker |
||||
#puts stderr "shellthread::manager::close_worker: thread $tidworker for source $source DONE2" |
||||
if {[dict exists $workers $source errors]} { |
||||
set errlist [dict get $workers $source errors] |
||||
if {[llength $errlist]} { |
||||
lappend worker_errors [list $source [dict get $workers $source]] |
||||
} |
||||
} |
||||
dict unset workers $source |
||||
} else { |
||||
#thread may have been closed by call to close_worker with another source with same worker |
||||
#clear workers record for this source |
||||
#REVIEW - race condition for re-creation of source with new workerid? |
||||
#check that record is subscriberless to avoid this |
||||
if {[llength [dict get $workers $source list_client_tids]] == 0} { |
||||
dict unset workers $source |
||||
} |
||||
} |
||||
} |
||||
#puts stdout "close_worker $source - end" |
||||
} |
||||
|
||||
#worker errors only available for a source after close_worker called on that source |
||||
#It is possible for there to be multiple entries for a source because new_worker can be called multiple times with same sourcetag, |
||||
proc get_and_clear_errors {source} { |
||||
variable worker_errors |
||||
set source_errors [lsearch -all -inline -index 0 $worker_errors $source] |
||||
set worker_errors [lsearch -all -inline -index 0 -not $worker_errors $source] |
||||
return $source_errors |
||||
} |
||||
|
||||
|
||||
} |
||||
|
||||
package provide shellthread [namespace eval shellthread { |
||||
variable version |
||||
set version 1.6.1 |
||||
}] |
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
@ -0,0 +1,890 @@
|
||||
# vim: set ft=tcl |
||||
# |
||||
#purpose: handle the run commands that call shellfilter::run |
||||
#e.g run,runout,runerr,runx |
||||
|
||||
package require shellfilter |
||||
package require punk::ansi |
||||
|
||||
#NOTE: the run,runout,runerr,runx commands only produce an error if the command didn't run. |
||||
# - If it did run, but there was a non-zero exitcode it is up to the application to check that. |
||||
#This is deliberate, but means 'catch' doesn't catch errors within the command itself - the exitcode has to be checked. |
||||
#The user can always use exec for different process error semantics (they don't get exitcode with exec) |
||||
|
||||
namespace eval shellrun { |
||||
variable PUNKARGS |
||||
variable runout |
||||
variable runerr |
||||
|
||||
#do we need these? |
||||
#variable punkout |
||||
#variable punkerr |
||||
|
||||
#some ugly coupling with punk/punk::config for now |
||||
#todo - something better |
||||
if {[info exists ::punk::config::configdata]} { |
||||
set conf_running [punk::config::configure running] |
||||
set syslog_stdout [dict get $conf_running syslog_stdout] |
||||
set syslog_stderr [dict get $conf_running syslog_stderr] |
||||
set logfile_stdout [dict get $conf_running logfile_stdout] |
||||
set logfile_stderr [dict get $conf_running logfile_stderr] |
||||
} else { |
||||
lassign [list "" "" "" ""] syslog_stdout syslog_stderr logfile_stdout logfile_stderr |
||||
} |
||||
if {"punkshout" ni [shellfilter::stack::items]} { |
||||
set outdevice [shellfilter::stack::new punkshout -settings [list -tag "punkshout" -buffering none -raw 1 -syslog $syslog_stdout -file $logfile_stdout]] |
||||
set out [dict get $outdevice localchan] |
||||
} else { |
||||
set out [dict get [shellfilter::stack::item punkshout] device localchan] |
||||
} |
||||
if {"punksherr" ni [shellfilter::stack::items]} { |
||||
set errdevice [shellfilter::stack::new punksherr -settings [list -tag "punksherr" -buffering none -raw 1 -syslog $syslog_stderr -file $logfile_stderr]] |
||||
set err [dict get $errdevice localchan] |
||||
} else { |
||||
set err [dict get [shellfilter::stack::item punksherr] device localchan] |
||||
} |
||||
|
||||
namespace import ::punk::ansi::a+ |
||||
namespace import ::punk::ansi::a |
||||
|
||||
|
||||
|
||||
|
||||
#repltelemetry - additional/alternative display info used in a repl context i.e info directed towards the screen |
||||
#todo - package up in repltelemetry module and rewrite proc based on whether the module was found/loaded. |
||||
#somewhat strong coupling to punk - but let's try to behave decently if it's not loaded |
||||
#The last_run_display is actually intended for the repl - but is resident in the punk namespace with a view to the possibility of a different repl being in use. |
||||
proc set_last_run_display {chunklist} { |
||||
#chunklist as understood by the |
||||
if {![info exists ::punk::repltelemetry_emmitters]} { |
||||
namespace eval ::punk { |
||||
variable repltelemetry_emmitters |
||||
set repltelemetry_emmitters "shellrun" |
||||
} |
||||
} else { |
||||
if {"shellrun" ni $::punk::repltelemetry_emmitters} { |
||||
lappend punk::repltelemetry_emmitters "shellrun" |
||||
} |
||||
} |
||||
|
||||
#most basic of validity tests here.. just that it is a list (can be empty). We don't want to duplicate or over-constrain the way repls/shells/terminals interpet the info |
||||
if {[catch {llength $chunklist} errMsg]} { |
||||
error "set_last_run_display expects a list. Value supplied doesn't appear to be a well formed tcl list. '$errMsg'" |
||||
} |
||||
#todo - |
||||
tsv::lappend repl runchunks-[tsv::get repl runid] {*}$chunklist |
||||
} |
||||
|
||||
|
||||
|
||||
#maintenance: similar used in punk::ns & punk::winrun |
||||
#todo - take runopts + aliases as args |
||||
#longopts must be passed as a single item ie --timeout=100 not --timeout 100 |
||||
proc get_run_opts {arglist} { |
||||
if {[catch { |
||||
set callerinfo [info level -1] |
||||
} errM]} { |
||||
set caller "" |
||||
} else { |
||||
set caller [lindex $callerinfo 0] |
||||
} |
||||
|
||||
#we provide -nonewline even for 'run' even though run doesn't deliver stderr or stdout to the tcl return value |
||||
#This is for compatibility with other runX commands, and the difference is also visible when calling from repl. |
||||
set known_runopts [list "-echo" "-e" "-nonewline" "-n" "-tcl" "-debug"] |
||||
set known_longopts [list "--timeout"] |
||||
set known_longopts_msg "" |
||||
foreach lng $known_longopts { |
||||
append known_longopts_msg "${lng}=val " |
||||
} |
||||
set aliases [list "-e" "-echo" "-echo" "-echo" "-n" "-nonewline" "-nonewline" "-nonewline" "-tcl" "-tcl" "-debug" "-debug"] ;#include map to self |
||||
set runopts [list] |
||||
set runoptslong [list] |
||||
set cmdargs [list] |
||||
|
||||
set idx_first_cmdarg [lsearch -not $arglist "-*"] |
||||
|
||||
set allopts [lrange $arglist 0 $idx_first_cmdarg-1] |
||||
set cmdargs [lrange $arglist $idx_first_cmdarg end] |
||||
foreach o $allopts { |
||||
if {[string match --* $o]} { |
||||
lassign [split $o =] flagpart valpart |
||||
if {$valpart eq ""} { |
||||
error "$caller: longopt $o seems to be missing a value - must be of form --option=value" |
||||
} |
||||
if {$flagpart ni $known_longopts} { |
||||
error "$caller: Unknown runoption $o - known options $known_runopts $known_longopts_msg" |
||||
} |
||||
lappend runoptslong $flagpart $valpart |
||||
} else { |
||||
if {$o ni $known_runopts} { |
||||
error "$caller: Unknown runoption $o - known options $known_runopts $known_longopts_msg" |
||||
} |
||||
lappend runopts [dict get $aliases $o] |
||||
} |
||||
} |
||||
return [list runopts $runopts runoptslong $runoptslong cmdargs $cmdargs] |
||||
} |
||||
|
||||
|
||||
#todo - investigate cause of punk86 run hanging sometimes. An 'after 500' before exit in the called script fixes the issue. punk87 doesn't seem to be affected. |
||||
lappend PUNKARGS [list { |
||||
@id -id ::shellrun::run |
||||
@leaders -min 0 -max 0 |
||||
@opts |
||||
-nonewline -type none |
||||
-tcl -type none -default 0 |
||||
-debug -type none -default 0 |
||||
--timeout= -type integer |
||||
@values -min 1 -max -1 |
||||
cmdname -type string |
||||
cmdarg -type any -multiple 1 -optional 1 |
||||
}] |
||||
proc run {args} { |
||||
#set_last_run_display [list] |
||||
|
||||
#set splitargs [get_run_opts $args] |
||||
#set runopts [dict get $splitargs runopts] |
||||
#set runoptslong [dict get $splitargs runoptslong] |
||||
#set cmdargs [dict get $splitargs cmdargs] |
||||
set argd [punk::args::parse $args withid ::shellrun::run] |
||||
lassign [dict values $argd] leaders opts values received |
||||
|
||||
if {[dict exists $received "-nonewline"]} { |
||||
set nonewline 1 |
||||
} else { |
||||
set nonewline 0 |
||||
} |
||||
#review nonewline does nothing here.. |
||||
|
||||
set idlist_stderr [list] |
||||
#we leave stdout without imposed ansi colouring - because the source may be colourised and because ansi-wrapping a stream at whatever boundaries it comes in at isn't a really nice thing to do. |
||||
#stderr might have source colouring - but it usually doesn't seem to, and the visual distiction of red stderr can be very handy for the run command. |
||||
#A further enhancement could be to detect well-known options such as --color and/or use a configuration for specific commands that have useful colourised stderr, |
||||
#but having an option to configure stderr to red is a compromise. |
||||
#Note that the other run commands, runout,runerr, runx don't emit in real-time - so for those commands there may be options to detect and/or post-process stdout and stderr. |
||||
#TODO - fix. This has no effect if/when the repl adds an ansiwrap transform |
||||
# what we probably want to do is 'aside' that transform for runxxx commands only. |
||||
#lappend idlist_stderr [shellfilter::stack::add stderr ansiwrap -settings {-colour {red bold}}] |
||||
|
||||
set callopts [dict create] |
||||
if {[dict exists $received "-tcl"]} { |
||||
dict set callopts -tclscript 1 |
||||
} |
||||
if {[dict exists $received "-debug"]} { |
||||
dict set callopts -debug 1 |
||||
} |
||||
if {[dict exists $received --timeout]} { |
||||
dict set callopts -timeout [dict get $opts --timeout] ;#convert to single dash |
||||
} |
||||
set cmdname [dict get $values cmdname] |
||||
if {[dict exists $received cmdarg]} { |
||||
set cmdarglist [dict get $values cmdarg] |
||||
} else { |
||||
set cmdarglist {} |
||||
} |
||||
set cmdargs [concat $cmdname $cmdarglist] |
||||
#--------------------------------------------------------------------------------------------- |
||||
set exitinfo [shellfilter::run $cmdargs {*}$callopts -teehandle punksh -inbuffering none -outbuffering none ] |
||||
#--------------------------------------------------------------------------------------------- |
||||
|
||||
foreach id $idlist_stderr { |
||||
shellfilter::stack::remove stderr $id |
||||
} |
||||
|
||||
flush stderr |
||||
flush stdout |
||||
|
||||
if {[dict exists $exitinfo error]} { |
||||
error "[dict get $exitinfo error]\n$exitinfo" |
||||
} |
||||
|
||||
return $exitinfo |
||||
} |
||||
|
||||
lappend PUNKARGS [list { |
||||
@id -id ::shellrun::runconsole |
||||
@leaders -min 0 -max 0 |
||||
@opts |
||||
@values -min 1 -max -1 |
||||
cmdname -type string |
||||
cmdarg -type any -multiple 1 -optional 1 |
||||
}] |
||||
#run in the way tcl unknown does - but without regard to auto_noexec |
||||
proc runconsole {args} { |
||||
set argd [punk::args::parse $args withid ::shellrun::runconsole] |
||||
lassign [dict values $argd] leaders opts values received |
||||
set cmdname [dict get $values cmdname] |
||||
if {[dict exists $received cmdarg]} { |
||||
set arglist [dict get $values cmdarg] |
||||
} else { |
||||
set arglist {} |
||||
} |
||||
|
||||
set resolved_cmdname [auto_execok $cmdname] |
||||
set repl_runid [punk::get_repl_runid] |
||||
#set ::punk::last_run_display [list] |
||||
|
||||
set redir ">&@stdout <@stdin" |
||||
uplevel 1 [list ::catch [concat exec $redir $resolved_cmdname $arglist] ::tcl::UnknownResult ::tcl::UnknownOptions] |
||||
#we can't detect stdout/stderr output from the exec |
||||
#for now emit an extra \n on stderr |
||||
#todo - there is probably no way around this but to somehow exec in the context of a completely separate console |
||||
#This is probably a tricky problem - especially to do cross-platform |
||||
# |
||||
# - use [dict get $::tcl::UnknownOptions -code] (0|1) exit |
||||
if {[dict get $::tcl::UnknownOptions -code] == 0} { |
||||
set c green |
||||
set m "ok" |
||||
} else { |
||||
set c yellow |
||||
set m "errorCode $::errorCode" |
||||
} |
||||
set chunklist [list] |
||||
lappend chunklist [list "info" "[a $c]$m[a] " ] |
||||
if {$repl_runid != 0} { |
||||
tsv::lappend repl runchunks-$repl_runid {*}$chunklist |
||||
} |
||||
|
||||
dict incr ::tcl::UnknownOptions -level |
||||
return -options $::tcl::UnknownOptions $::tcl::UnknownResult |
||||
} |
||||
lappend PUNKARGS [list { |
||||
@id -id ::shellrun::runout |
||||
@leaders -min 0 -max 0 |
||||
@opts |
||||
-echo -type none |
||||
-nonewline -type none |
||||
-tcl -type none -default 0 |
||||
-debug -type none -default 0 |
||||
--timeout= -type integer |
||||
@values -min 1 -max -1 |
||||
cmdname -type string |
||||
cmdarg -type any -multiple 1 -optional 1 |
||||
}] |
||||
proc runout {args} { |
||||
set argd [punk::args::parse $args withid ::shellrun::runout] |
||||
lassign [dict values $argd] leaders opts values received |
||||
|
||||
if {[dict exists $received "-nonewline"]} { |
||||
set nonewline 1 |
||||
} else { |
||||
set nonewline 0 |
||||
} |
||||
|
||||
#set_last_run_display [list] |
||||
variable runout |
||||
variable runerr |
||||
set runout "" |
||||
set runerr "" |
||||
set RST [a] |
||||
|
||||
#set splitargs [get_run_opts $args] |
||||
#set runopts [dict get $splitargs runopts] |
||||
#set cmdargs [dict get $splitargs cmdargs] |
||||
|
||||
|
||||
#puts stdout "RUNOUT cmdargs: $cmdargs" |
||||
|
||||
#todo add -data boolean and -data lastwrite to -settings with default being -data all |
||||
# because sometimes we're only interested in last char (e.g to detect something was output) |
||||
|
||||
#set outvar_stackid [shellfilter::stack::add commandout tee_to_var -action float -settings {-varname ::runout}] |
||||
# |
||||
#when not echoing - use float-locked so that the repl's stack is bypassed |
||||
if {[dict exists $received "-echo"]} { |
||||
set stdout_stackid [shellfilter::stack::add stdout tee_to_var -action float-locked -settings {-varname ::shellrun::runout}] |
||||
set stderr_stackid [shellfilter::stack::add stderr tee_to_var -action float-locked -settings {-varname ::shellrun::runerr}] |
||||
#set stderr_stackid [shellfilter::stack::add stderr tee_to_var -action sink-locked -settings {-varname ::shellrun::runerr}] |
||||
} else { |
||||
set stdout_stackid [shellfilter::stack::add stdout var -action float-locked -settings {-varname ::shellrun::runout}] |
||||
set stderr_stackid [shellfilter::stack::add stderr var -action float-locked -settings {-varname ::shellrun::runerr}] |
||||
} |
||||
|
||||
set callopts [dict create] |
||||
if {[dict exists $received "-tcl"]} { |
||||
dict set callopts -tclscript 1 |
||||
} |
||||
if {[dict exists $received "-debug"]} { |
||||
dict set callopts -debug 1 |
||||
} |
||||
if {[dict exists $received --timeout]} { |
||||
dict set callopts -timeout [dict get $opts --timeout] ;#convert to single dash |
||||
} |
||||
set cmdname [dict get $values cmdname] |
||||
if {[dict exists $received cmdarg]} { |
||||
set cmdarglist [dict get $values cmdarg] |
||||
} else { |
||||
set cmdarglist {} |
||||
} |
||||
set cmdargs [concat $cmdname $cmdarglist] |
||||
|
||||
#shellfilter::run [lrange $args 1 end] -teehandle punksh -outchan stdout -inbuffering none -outbuffering none -stdinhandler ::repl::repl_handler |
||||
set exitinfo [shellfilter::run $cmdargs {*}$callopts -teehandle punksh -inbuffering none -outbuffering none ] |
||||
|
||||
flush stderr |
||||
flush stdout |
||||
|
||||
shellfilter::stack::remove stdout $stdout_stackid |
||||
shellfilter::stack::remove stderr $stderr_stackid |
||||
|
||||
#shellfilter::stack::remove commandout $outvar_stackid |
||||
|
||||
if {[dict exists $exitinfo error]} { |
||||
if {[dict exists $received "-tcl"]} { |
||||
|
||||
} else { |
||||
#we must raise an error. |
||||
#todo - check errorInfo makes sense.. return -code? tailcall? |
||||
# |
||||
set msg "" |
||||
append msg [dict get $exitinfo error] |
||||
append msg "\n(add -tcl option to run as a tcl command/script instead of an external command)" |
||||
error $msg |
||||
} |
||||
} |
||||
|
||||
set chunklist [list] |
||||
|
||||
#exitcode not part of return value for runout - colourcode appropriately |
||||
set n $RST |
||||
set c "" |
||||
|
||||
if {[dict exists $exitinfo exitcode]} { |
||||
set code [dict get $exitinfo exitcode] |
||||
if {$code == 0} { |
||||
set c [a+ green] |
||||
} else { |
||||
set c [a+ white bold] |
||||
} |
||||
lappend chunklist [list "info" "$c$exitinfo$n"] |
||||
} elseif {[dict exists $exitinfo error]} { |
||||
set c [a+ yellow bold] |
||||
lappend chunklist [list "info" "${c}error [dict get $exitinfo error]$n"] |
||||
lappend chunklist [list "info" "errorCode [dict get $exitinfo errorCode]"] |
||||
#lappend chunklist [list "info" "errorInfo [list [dict get $exitinfo errorInfo]]"] |
||||
lappend chunklist [list "info" errorInfo] |
||||
lappend chunklist [list "stderr" [dict get $exitinfo errorInfo]] |
||||
} else { |
||||
set c [a+ Yellow red bold] |
||||
#lappend chunklist [list "info" "$c$exitinfo$n"] |
||||
lappend chunklist [list "info" [punk::ansi::ansiwrap_raw $c \x1b\[m "" $exitinfo]] |
||||
} |
||||
|
||||
|
||||
set chunk "[a+ red bold]stderr$RST" |
||||
lappend chunklist [list "info" $chunk] |
||||
|
||||
set chunk "" |
||||
if {[string length $::shellrun::runerr]} { |
||||
if {$nonewline} { |
||||
set e [string trimright $::shellrun::runerr \r\n] |
||||
} else { |
||||
set e $::shellrun::runerr |
||||
} |
||||
#append chunk "[a+ red normal]$e$RST\n" |
||||
append chunk "[a+ red normal]$e$RST" |
||||
} |
||||
lappend chunklist [list stderr $chunk] |
||||
|
||||
|
||||
|
||||
|
||||
lappend chunklist [list "info" "[a+ white bold]stdout$RST"] |
||||
set chunk "" |
||||
if {[string length $::shellrun::runout]} { |
||||
if {$nonewline} { |
||||
set o [string trimright $::shellrun::runout \r\n] |
||||
} else { |
||||
set o $::shellrun::runout |
||||
} |
||||
append chunk "$o" |
||||
} |
||||
lappend chunklist [list result $chunk] |
||||
|
||||
|
||||
#set_last_run_display $chunklist |
||||
tsv::lappend repl runchunks-[tsv::get repl runid] {*}$chunklist |
||||
|
||||
if {$nonewline} { |
||||
return [string trimright $::shellrun::runout \r\n] |
||||
} else { |
||||
return $::shellrun::runout |
||||
} |
||||
} |
||||
|
||||
lappend PUNKARGS [list { |
||||
@id -id ::shellrun::runerr |
||||
@leaders -min 0 -max 0 |
||||
@opts |
||||
-echo -type none |
||||
-nonewline -type none |
||||
-tcl -type none -default 0 |
||||
-debug -type none -default 0 |
||||
--timeout= -type integer |
||||
@values -min 1 -max -1 |
||||
cmdname -type string |
||||
cmdarg -type any -multiple 1 -optional 1 |
||||
}] |
||||
proc runerr {args} { |
||||
set argd [punk::args::parse $args withid ::shellrun::runout] |
||||
lassign [dict values $argd] leaders opts values received |
||||
|
||||
if {[dict exists $received "-nonewline"]} { |
||||
set nonewline 1 |
||||
} else { |
||||
set nonewline 0 |
||||
} |
||||
|
||||
#set_last_run_display [list] |
||||
variable runout |
||||
variable runerr |
||||
set runout "" |
||||
set runerr "" |
||||
|
||||
#set splitargs [get_run_opts $args] |
||||
#set runopts [dict get $splitargs runopts] |
||||
#set cmdargs [dict get $splitargs cmdargs] |
||||
|
||||
set callopts [dict create] |
||||
if {[dict exists $received "-tcl"]} { |
||||
dict set callopts -tclscript 1 |
||||
} |
||||
if {[dict exists $received "-debug"]} { |
||||
dict set callopts -debug 1 |
||||
} |
||||
if {[dict exists $received --timeout]} { |
||||
dict set callopts -timeout [dict get $opts --timeout] ;#convert to single dash |
||||
} |
||||
set cmdname [dict get $values cmdname] |
||||
if {[dict exists $received cmdarg]} { |
||||
set cmdarglist [dict get $values cmdarg] |
||||
} else { |
||||
set cmdarglist {} |
||||
} |
||||
set cmdargs [concat $cmdname $cmdarglist] |
||||
|
||||
if {[dict exists $received "-tcl"]} { |
||||
append callopts " -tclscript 1" |
||||
} |
||||
if {[dict exists $received "-echo"]} { |
||||
set stderr_stackid [shellfilter::stack::add stderr tee_to_var -action float-locked -settings {-varname ::shellrun::runerr}] |
||||
set stdout_stackid [shellfilter::stack::add stdout tee_to_var -action float-locked -settings {-varname ::shellrun::runout}] |
||||
} else { |
||||
set stderr_stackid [shellfilter::stack::add stderr var -action float-locked -settings {-varname ::shellrun::runerr}] |
||||
set stdout_stackid [shellfilter::stack::add stdout var -action float-locked -settings {-varname ::shellrun::runout}] |
||||
} |
||||
|
||||
|
||||
set exitinfo [shellfilter::run $cmdargs {*}$callopts -teehandle punksh -inbuffering none -outbuffering none -stdinhandler ::repl::repl_handler] |
||||
shellfilter::stack::remove stderr $stderr_stackid |
||||
shellfilter::stack::remove stdout $stdout_stackid |
||||
|
||||
|
||||
flush stderr |
||||
flush stdout |
||||
|
||||
#we raise an error because an error during calling is different to collecting stderr from a command, and the caller should be able to wrap in a catch |
||||
# to determine something other than just a nonzero exit code or output on stderr. |
||||
if {[dict exists $exitinfo error]} { |
||||
if {[dict exists $received "-tcl"]} { |
||||
|
||||
} else { |
||||
#todo - check errorInfo makes sense.. return -code? tailcall? |
||||
error [dict get $exitinfo error] |
||||
} |
||||
} |
||||
|
||||
set chunklist [list] |
||||
|
||||
set n [a] |
||||
set c "" |
||||
if {[dict exists $exitinfo exitcode]} { |
||||
set code [dict get $exitinfo exitcode] |
||||
if {$code == 0} { |
||||
set c [a+ green] |
||||
} else { |
||||
set c [a+ white bold] |
||||
} |
||||
lappend chunklist [list "info" "$c$exitinfo$n"] |
||||
} elseif {[dict exists $exitinfo error]} { |
||||
set c [a+ yellow bold] |
||||
lappend chunklist [list "info" "error [dict get $exitinfo error]"] |
||||
lappend chunklist [list "info" "errorCode [dict get $exitinfo errorCode]"] |
||||
lappend chunklist [list "info" "errorInfo [list [dict get $exitinfo errorInfo]]"] |
||||
} else { |
||||
set c [a+ Yellow red bold] |
||||
#lappend chunklist [list "info" "$c$exitinfo$n"] |
||||
lappend chunklist [list "info" [punk::ansi::ansiwrap_raw $c "\x1b\[m" "" $exitinfo]] |
||||
} |
||||
|
||||
|
||||
lappend chunklist [list "info" "[a+ white bold]stdout[a]"] |
||||
set chunk "" |
||||
if {[string length $::shellrun::runout]} { |
||||
if {$nonewline} { |
||||
set o [string trimright $::shellrun::runout \r\n] |
||||
} else { |
||||
set o $::shellrun::runout |
||||
} |
||||
append chunk "[a+ white normal]$o[a]\n" ;#this newline is the display output separator - always there whether data has trailing newline or not. |
||||
} |
||||
lappend chunklist [list stdout $chunk] |
||||
|
||||
|
||||
#set c_stderr [punk::config] |
||||
set chunk "[a+ red bold]stderr[a]" |
||||
lappend chunklist [list "info" $chunk] |
||||
|
||||
set chunk "" |
||||
if {[string length $::shellrun::runerr]} { |
||||
if {$nonewline} { |
||||
set e [string trimright $::shellrun::runerr \r\n] |
||||
} else { |
||||
set e $::shellrun::runerr |
||||
} |
||||
append chunk "$e" |
||||
} |
||||
lappend chunklist [list resulterr $chunk] |
||||
|
||||
|
||||
#set_last_run_display $chunklist |
||||
tsv::lappend repl runchunks-[tsv::get repl runid] {*}$chunklist |
||||
|
||||
if {$nonewline} { |
||||
return [string trimright $::shellrun::runerr \r\n] |
||||
} |
||||
return $::shellrun::runerr |
||||
} |
||||
|
||||
|
||||
proc runx {args} { |
||||
#set_last_run_display [list] |
||||
variable runout |
||||
variable runerr |
||||
set runout "" |
||||
set runerr "" |
||||
|
||||
set splitargs [get_run_opts $args] |
||||
set runopts [dict get $splitargs runopts] |
||||
set cmdargs [dict get $splitargs cmdargs] |
||||
|
||||
if {"-nonewline" in $runopts} { |
||||
set nonewline 1 |
||||
} else { |
||||
set nonewline 0 |
||||
} |
||||
|
||||
#shellfilter::stack::remove stdout $::repl::id_outstack |
||||
|
||||
if {"-echo" in $runopts} { |
||||
#float to ensure repl transform doesn't interfere with the output data |
||||
set stderr_stackid [shellfilter::stack::add stderr tee_to_var -action float -settings {-varname ::shellrun::runerr}] |
||||
set stdout_stackid [shellfilter::stack::add stdout tee_to_var -action float -settings {-varname ::shellrun::runout}] |
||||
} else { |
||||
#set stderr_stackid [shellfilter::stack::add stderr var -action sink-locked -settings {-varname ::shellrun::runerr}] |
||||
#set stdout_stackid [shellfilter::stack::add stdout var -action sink-locked -settings {-varname ::shellrun::runout}] |
||||
|
||||
#float above the repl's tee_to_var to deliberately block it. |
||||
#a var transform is naturally a junction point because there is no flow-through.. |
||||
# - but mark it with -junction 1 just to be explicit |
||||
set stderr_stackid [shellfilter::stack::add stderr var -action float-locked -junction 1 -settings {-varname ::shellrun::runerr}] |
||||
set stdout_stackid [shellfilter::stack::add stdout var -action float-locked -junction 1 -settings {-varname ::shellrun::runout}] |
||||
} |
||||
|
||||
set callopts "" |
||||
if {"-tcl" in $runopts} { |
||||
append callopts " -tclscript 1" |
||||
} |
||||
#set exitinfo [shellfilter::run $cmdargs -teehandle punksh -inbuffering none -outbuffering none -stdinhandler ::repl::repl_handler] |
||||
set exitinfo [shellfilter::run $cmdargs {*}$callopts -teehandle punksh -inbuffering none -outbuffering none] |
||||
|
||||
shellfilter::stack::remove stdout $stdout_stackid |
||||
shellfilter::stack::remove stderr $stderr_stackid |
||||
|
||||
|
||||
flush stderr |
||||
flush stdout |
||||
|
||||
if {[dict exists $exitinfo error]} { |
||||
if {"-tcl" in $runopts} { |
||||
|
||||
} else { |
||||
#todo - check errorInfo makes sense.. return -code? tailcall? |
||||
error [dict get $exitinfo error] |
||||
} |
||||
} |
||||
|
||||
#set x [shellfilter::stack::add stdout var -action sink-locked -settings {-varname ::repl::runxoutput}] |
||||
|
||||
set chunk "" |
||||
if {[string length $::shellrun::runout]} { |
||||
if {$nonewline} { |
||||
set o [string trimright $::shellrun::runout \r\n] |
||||
} else { |
||||
set o $::shellrun::runout |
||||
} |
||||
set chunk $o |
||||
} |
||||
set chunklist [list] |
||||
lappend chunklist [list "info" " "] |
||||
lappend chunklist [list "result" stdout] ;#key 'stdout' forms part of the resulting dictionary output |
||||
lappend chunklist [list "info" "[a+ white bold]stdout[a]"] |
||||
lappend chunklist [list result $chunk] ;#value corresponding to 'stdout' key in resulting dict |
||||
|
||||
|
||||
lappend chunklist [list "info" " "] |
||||
set chunk "[a+ red bold]stderr[a]" |
||||
lappend chunklist [list "result" $chunk] |
||||
lappend chunklist [list "info" stderr] |
||||
|
||||
set chunk "" |
||||
if {[string length $::shellrun::runerr]} { |
||||
if {$nonewline} { |
||||
set e [string trimright $::shellrun::runerr \r\n] |
||||
} else { |
||||
set e $::shellrun::runerr |
||||
} |
||||
set chunk $e |
||||
} |
||||
#stderr is part of the result |
||||
lappend chunklist [list "resulterr" $chunk] |
||||
|
||||
|
||||
|
||||
set n [a] |
||||
set c "" |
||||
if {[dict exists $exitinfo exitcode]} { |
||||
set code [dict get $exitinfo exitcode] |
||||
if {$code == 0} { |
||||
set c [a+ green] |
||||
} else { |
||||
set c [a+ yellow bold] |
||||
} |
||||
lappend chunklist [list "info" " "] |
||||
lappend chunklist [list "result" exitcode] |
||||
lappend chunklist [list "info" "exitcode $code"] |
||||
lappend chunklist [list "result" "$c$code$n"] |
||||
set exitdict [list exitcode $code] |
||||
} elseif {[dict exists $exitinfo result]} { |
||||
# presumably from a -tcl call |
||||
set val [dict get $exitinfo result] |
||||
lappend chunklist [list "info" " "] |
||||
lappend chunklist [list "result" result] |
||||
lappend chunklist [list "info" result] |
||||
lappend chunklist [list "result" $val] |
||||
set exitdict [list result $val] |
||||
} elseif {[dict exists $exitinfo error]} { |
||||
# -tcl call with error |
||||
#set exitdict [dict create] |
||||
lappend chunklist [list "info" " "] |
||||
lappend chunklist [list "result" error] |
||||
lappend chunklist [list "info" error] |
||||
lappend chunklist [list "result" [dict get $exitinfo error]] |
||||
|
||||
lappend chunklist [list "info" " "] |
||||
lappend chunklist [list "result" errorCode] |
||||
lappend chunklist [list "info" errorCode] |
||||
lappend chunklist [list "result" [dict get $exitinfo errorCode]] |
||||
|
||||
lappend chunklist [list "info" " "] |
||||
lappend chunklist [list "result" errorInfo] |
||||
lappend chunklist [list "info" errorInfo] |
||||
lappend chunklist [list "result" [dict get $exitinfo errorInfo]] |
||||
|
||||
set exitdict $exitinfo |
||||
} else { |
||||
#review - if no exitcode or result. then what is it? |
||||
lappend chunklist [list "info" exitinfo] |
||||
set c [a+ yellow bold] |
||||
lappend chunklist [list result "$c$exitinfo$n"] |
||||
set exitdict [list exitinfo $exitinfo] |
||||
} |
||||
|
||||
#set_last_run_display $chunklist |
||||
tsv::lappend repl runchunks-[tsv::get repl runid] {*}$chunklist |
||||
|
||||
#set ::repl::result_print 0 |
||||
#return [lindex [list [list stdout $::runout stderr $::runerr {*}$exitinfo] [shellfilter::stack::remove stdout $x][puts -nonewline stdout $pretty][set ::repl::output ""]] 0] |
||||
|
||||
|
||||
if {$nonewline} { |
||||
return [list {*}$exitdict stdout [string trimright $::shellrun::runout \r\n] stderr [string trimright $::shellrun::runerr \r\n]] |
||||
} |
||||
#always return exitinfo $code at beginning of dict (so that punk unknown can interpret the exit code as a unix-style bool if double evaluated) |
||||
return [list {*}$exitdict stdout $::shellrun::runout stderr $::shellrun::runerr] |
||||
} |
||||
|
||||
#an experiment |
||||
# |
||||
#run as raw string instead of tcl-list - no variable subst etc |
||||
# |
||||
#dummy repl_runraw that repl will intercept |
||||
proc repl_runraw {args} { |
||||
error "runraw: only available in repl as direct call - not from script" |
||||
} |
||||
#we can only call runraw with a single (presumably braced) string if we want to use it from both repl and tcl scripts (why? todo with unbalanced quotes/braces?) |
||||
proc runraw {commandline} { |
||||
#runraw fails as intended - because we can't bypass exec/open interference quoting :/ |
||||
#set_last_run_display [list] |
||||
variable runout |
||||
variable runerr |
||||
set runout "" |
||||
set runerr "" |
||||
|
||||
#return [shellfilter::run [lrange $args 1 end] -teehandle punksh -inbuffering none -outbuffering none -stdinhandler ::repl::repl_handler] |
||||
puts stdout ">>runraw got: $commandline" |
||||
|
||||
#run always echoes anyway.. as we aren't diverting stdout/stderr off for capturing |
||||
#for consistency with other runxxx commands - we'll just consume it. (review) |
||||
|
||||
set reallyraw 1 |
||||
if {$reallyraw} { |
||||
set wordparts [regexp -inline -all {\S+} $commandline] |
||||
set runwords $wordparts |
||||
} else { |
||||
#shell style args parsing not suitable for windows where we can't assume matched quotes etc. |
||||
package require string::token::shell |
||||
set parts [string token shell -indices -- $commandline] |
||||
puts stdout ">>shellparts: $parts" |
||||
set runwords [list] |
||||
foreach p $parts { |
||||
set ptype [lindex $p 0] |
||||
set pval [lindex $p 3] |
||||
if {$ptype eq "PLAIN"} { |
||||
lappend runwords [lindex $p 3] |
||||
} elseif {$ptype eq "D:QUOTED"} { |
||||
set v {"} |
||||
append v $pval |
||||
append v {"} |
||||
lappend runwords $v |
||||
} elseif {$ptype eq "S:QUOTED"} { |
||||
set v {'} |
||||
append v $pval |
||||
append v {'} |
||||
lappend runwords $v |
||||
} |
||||
} |
||||
} |
||||
|
||||
puts stdout ">>runraw runwords: $runwords" |
||||
set runwords [lrange $runwords 1 end] |
||||
|
||||
puts stdout ">>runraw runwords: $runwords" |
||||
#set args [lrange $args 1 end] |
||||
#set runwords [lrange $wordparts 1 end] |
||||
|
||||
set known_runopts [list "-echo" "-e" "-terminal" "-t"] |
||||
set aliases [list "-e" "-echo" "-echo" "-echo" "-t" "-terminal" "-terminal" "-terminal"] ;#include map to self |
||||
set runopts [list] |
||||
set cmdwords [list] |
||||
set idx_first_cmdarg [lsearch -not $runwords "-*"] |
||||
set runopts [lrange $runwords 0 $idx_first_cmdarg-1] |
||||
set cmdwords [lrange $runwords $idx_first_cmdarg end] |
||||
|
||||
foreach o $runopts { |
||||
if {$o ni $known_runopts} { |
||||
error "runraw: Unknown runoption $o" |
||||
} |
||||
} |
||||
set runopts [lmap o $runopts {dict get $aliases $o}] |
||||
|
||||
set cmd_as_string [join $cmdwords " "] |
||||
puts stdout ">>cmd_as_string: $cmd_as_string" |
||||
|
||||
if {"-terminal" in $runopts} { |
||||
#fake terminal using 'script' command. |
||||
#not ideal: smushes stdout & stderr together amongst other problems |
||||
set tcmd [shellfilter::get_scriptrun_from_cmdlist_dquote_if_not $cmdwords] |
||||
puts stdout ">>tcmd: $tcmd" |
||||
set exitinfo [shellfilter::run $tcmd -teehandle punksh -inbuffering line -outbuffering none ] |
||||
set exitinfo "exitcode not-implemented" |
||||
} else { |
||||
set exitinfo [shellfilter::run $cmdwords -teehandle punksh -inbuffering line -outbuffering none ] |
||||
} |
||||
|
||||
if {[dict exists $exitinfo error]} { |
||||
#todo - check errorInfo makes sense.. return -code? tailcall? |
||||
error [dict get $exitinfo error] |
||||
} |
||||
set code [dict get $exitinfo exitcode] |
||||
if {$code == 0} { |
||||
set c [a+ green] |
||||
} else { |
||||
set c [a+ white bold] |
||||
} |
||||
puts stderr $c |
||||
return $exitinfo |
||||
} |
||||
|
||||
proc sh_run {args} { |
||||
set splitargs [get_run_opts $args] |
||||
set runopts [dict get $splitargs runopts] |
||||
set cmdargs [dict get $splitargs cmdargs] |
||||
#e.g sh -c "ls -l *" |
||||
#we pass cmdargs to sh -c as a list, not individually |
||||
tailcall shellrun::run {*}$runopts sh -c $cmdargs |
||||
} |
||||
proc sh_runout {args} { |
||||
set splitargs [get_run_opts $args] |
||||
set runopts [dict get $splitargs runopts] |
||||
set cmdargs [dict get $splitargs cmdargs] |
||||
tailcall shellrun::runout {*}$runopts sh -c $cmdargs |
||||
} |
||||
proc sh_runerr {args} { |
||||
set splitargs [get_run_opts $args] |
||||
set runopts [dict get $splitargs runopts] |
||||
set cmdargs [dict get $splitargs cmdargs] |
||||
tailcall shellrun::runerr {*}$runopts sh -c $cmdargs |
||||
} |
||||
proc sh_runx {args} { |
||||
set splitargs [get_run_opts $args] |
||||
set runopts [dict get $splitargs runopts] |
||||
set cmdargs [dict get $splitargs cmdargs] |
||||
tailcall shellrun::runx {*}$runopts sh -c $cmdargs |
||||
} |
||||
} |
||||
|
||||
namespace eval shellrun { |
||||
interp alias {} run {} shellrun::run |
||||
interp alias {} sh_run {} shellrun::sh_run |
||||
interp alias {} runout {} shellrun::runout |
||||
interp alias {} sh_runout {} shellrun::sh_runout |
||||
interp alias {} runerr {} shellrun::runerr |
||||
interp alias {} sh_runerr {} shellrun::sh_runerr |
||||
interp alias {} runx {} shellrun::runx |
||||
interp alias {} sh_runx {} shellrun::sh_runx |
||||
|
||||
interp alias {} runc {} shellrun::runconsole |
||||
interp alias {} runraw {} shellrun::runraw |
||||
|
||||
|
||||
#the shortened versions deliberately don't get pretty output from the repl |
||||
interp alias {} r {} shellrun::run |
||||
interp alias {} ro {} shellrun::runout |
||||
interp alias {} re {} shellrun::runerr |
||||
interp alias {} rx {} shellrun::runx |
||||
|
||||
|
||||
} |
||||
|
||||
namespace eval shellrun { |
||||
proc test_cffi {} { |
||||
package require test_cffi |
||||
cffi::Wrapper create ::shellrun::kernel32 [file join $env(windir) system32 Kernel32.dll] |
||||
::shellrun::kernel32 stdcall CreateProcessA |
||||
#todo - stuff. |
||||
return ::shellrun::kernel32 |
||||
} |
||||
|
||||
} |
||||
namespace eval ::punk::args::register { |
||||
#use fully qualified so 8.6 doesn't find existing var in global namespace |
||||
lappend ::punk::args::register::NAMESPACES ::shellrun |
||||
} |
||||
|
||||
|
||||
package provide shellrun [namespace eval shellrun { |
||||
variable version |
||||
set version 0.1.1 |
||||
}] |
||||
@ -0,0 +1,826 @@
|
||||
#package require logger |
||||
|
||||
|
||||
package require Thread |
||||
|
||||
namespace eval shellthread { |
||||
|
||||
proc iso8601 {{tsmicros ""}} { |
||||
if {$tsmicros eq ""} { |
||||
set tsmicros [tcl::clock::microseconds] |
||||
} else { |
||||
set microsnow [tcl::clock::microseconds] |
||||
if {[tcl::string::length $tsmicros] != [tcl::string::length $microsnow]} { |
||||
error "iso8601 requires 'clock micros' or empty string to create timestamp" |
||||
} |
||||
} |
||||
set seconds [expr {$tsmicros / 1000000}] |
||||
return [tcl::clock::format $seconds -format "%Y-%m-%d_%H-%M-%S"] |
||||
} |
||||
} |
||||
|
||||
namespace eval shellthread::worker { |
||||
variable settings |
||||
variable sysloghost_port |
||||
variable sock |
||||
variable logfile "" |
||||
variable fd |
||||
variable client_ids [list] |
||||
variable ts_start_micros |
||||
variable errorlist [list] |
||||
variable inpipe "" |
||||
|
||||
proc bgerror {args} { |
||||
variable errorlist |
||||
lappend errorlist $args |
||||
} |
||||
proc send_errors_now {tidcli} { |
||||
variable errorlist |
||||
thread::send -async $tidcli [list shellthread::manager::report_worker_errors [list worker_tid [thread::id] errors $errorlist]] |
||||
} |
||||
proc add_client_tid {tidcli} { |
||||
variable client_ids |
||||
if {$tidcli ni $client_ids} { |
||||
lappend client_ids $tidcli |
||||
} |
||||
} |
||||
proc init {tidclient start_m settingsdict} { |
||||
variable sysloghost_port |
||||
variable logfile |
||||
variable settings |
||||
interp bgerror {} shellthread::worker::bgerror |
||||
#package require overtype ;#overtype uses tcllib textutil, punk::char etc - currently too heavyweight in terms of loading time for use in threads. |
||||
variable client_ids |
||||
variable ts_start_micros |
||||
lappend client_ids $tidclient |
||||
set ts_start_micros $start_m |
||||
|
||||
set defaults [list -raw 0 -file "" -syslog "" -direction out] |
||||
set settings [dict merge $defaults $settingsdict] |
||||
|
||||
set syslog [dict get $settings -syslog] |
||||
if {[string length $syslog]} { |
||||
lassign [split $syslog :] s_host s_port |
||||
set sysloghost_port [list $s_host $s_port] |
||||
if {[catch {package require udp} errm]} { |
||||
#disable rather than bomb and interfere with any -file being written |
||||
#review - log/notify? |
||||
set sysloghost_port "" |
||||
} |
||||
} else { |
||||
set sysloghost_port "" |
||||
} |
||||
|
||||
set logfile [dict get $settings -file] |
||||
} |
||||
|
||||
proc start_pipe_read {source readchan args} { |
||||
#assume 1 inpipe for now |
||||
variable inpipe |
||||
variable sysloghost_port |
||||
variable logfile |
||||
|
||||
set defaults [dict create -buffering \uFFFF ] |
||||
set opts [dict merge $defaults $args] |
||||
if {[dict exists $opts -readbuffering]} { |
||||
set readbuffering [dict get $opts -readbuffering] |
||||
} else { |
||||
if {[dict get $opts -buffering] eq "\uFFFF"} { |
||||
#get buffering setting from the channel as it was set prior to thread::transfer |
||||
set readbuffering [chan configure $readchan -buffering] |
||||
} else { |
||||
set readbuffering [dict get $opts -buffering] |
||||
chan configure $readchan -buffering $readbuffering |
||||
} |
||||
} |
||||
if {[dict exists $opts -writebuffering]} { |
||||
set writebuffering [dict get $opts -writebuffering] |
||||
} else { |
||||
if {[dict get $opts -buffering] eq "\uFFFF"} { |
||||
set writebuffering line |
||||
#set writebuffering [chan configure $writechan -buffering] |
||||
} else { |
||||
set writebuffering [dict get $opts -buffering] |
||||
#can configure $writechan -buffering $writebuffering |
||||
} |
||||
} |
||||
|
||||
chan configure $readchan -translation lf |
||||
|
||||
if {$readchan ni [chan names]} { |
||||
error "shellthread::worker::start_pipe_read - inpipe not configured. Use shellthread::manager::set_pipe_read_from_client to thread::transfer the pipe end" |
||||
} |
||||
set inpipe $readchan |
||||
chan configure $readchan -blocking 0 |
||||
set waitvar ::shellthread::worker::wait($inpipe,[clock micros]) |
||||
|
||||
#tcl::chan::fifo2 based pipe seems slower to establish events upon than Memchan |
||||
chan event $readchan readable [list ::shellthread::worker::pipe_read $readchan $source $waitvar $readbuffering $writebuffering] |
||||
vwait $waitvar |
||||
} |
||||
proc pipe_read {chan source waitfor readbuffering writebuffering} { |
||||
if {$readbuffering eq "line"} { |
||||
set chunksize [chan gets $chan chunk] |
||||
if {$chunksize >= 0} { |
||||
if {![chan eof $chan]} { |
||||
::shellthread::worker::log pipe 0 - $source - info $chunk\n $writebuffering |
||||
} else { |
||||
::shellthread::worker::log pipe 0 - $source - info $chunk $writebuffering |
||||
} |
||||
} |
||||
} else { |
||||
set chunk [chan read $chan] |
||||
::shellthread::worker::log pipe 0 - $source - info $chunk $writebuffering |
||||
} |
||||
if {[chan eof $chan]} { |
||||
chan event $chan readable {} |
||||
set $waitfor "pipe" |
||||
chan close $chan |
||||
} |
||||
} |
||||
|
||||
proc start_pipe_write {source writechan args} { |
||||
variable outpipe |
||||
set defaults [dict create -buffering \uFFFF ] |
||||
set opts [dict merge $defaults $args] |
||||
|
||||
#todo! |
||||
set readchan stdin |
||||
|
||||
if {[dict exists $opts -readbuffering]} { |
||||
set readbuffering [dict get $opts -readbuffering] |
||||
} else { |
||||
if {[dict get $opts -buffering] eq "\uFFFF"} { |
||||
set readbuffering [chan configure $readchan -buffering] |
||||
} else { |
||||
set readbuffering [dict get $opts -buffering] |
||||
chan configure $readchan -buffering $readbuffering |
||||
} |
||||
} |
||||
if {[dict exists $opts -writebuffering]} { |
||||
set writebuffering [dict get $opts -writebuffering] |
||||
} else { |
||||
if {[dict get $opts -buffering] eq "\uFFFF"} { |
||||
#nothing explicitly set - take from transferred channel |
||||
set writebuffering [chan configure $writechan -buffering] |
||||
} else { |
||||
set writebuffering [dict get $opts -buffering] |
||||
can configure $writechan -buffering $writebuffering |
||||
} |
||||
} |
||||
|
||||
if {$writechan ni [chan names]} { |
||||
error "shellthread::worker::start_pipe_write - outpipe not configured. Use shellthread::manager::set_pipe_write_to_client to thread::transfer the pipe end" |
||||
} |
||||
set outpipe $writechan |
||||
chan configure $readchan -blocking 0 |
||||
chan configure $writechan -blocking 0 |
||||
set waitvar ::shellthread::worker::wait($outpipe,[clock micros]) |
||||
|
||||
chan event $readchan readable [list apply {{chan writechan source waitfor readbuffering} { |
||||
if {$readbuffering eq "line"} { |
||||
set chunksize [chan gets $chan chunk] |
||||
if {$chunksize >= 0} { |
||||
if {![chan eof $chan]} { |
||||
puts $writechan $chunk |
||||
} else { |
||||
puts -nonewline $writechan $chunk |
||||
} |
||||
} |
||||
} else { |
||||
set chunk [chan read $chan] |
||||
puts -nonewline $writechan $chunk |
||||
} |
||||
if {[chan eof $chan]} { |
||||
chan event $chan readable {} |
||||
set $waitfor "pipe" |
||||
chan close $writechan |
||||
if {$chan ne "stdin"} { |
||||
chan close $chan |
||||
} |
||||
} |
||||
}} $readchan $writechan $source $waitvar $readbuffering] |
||||
|
||||
vwait $waitvar |
||||
} |
||||
|
||||
|
||||
proc _initsock {} { |
||||
variable sysloghost_port |
||||
variable sock |
||||
if {[string length $sysloghost_port]} { |
||||
if {[catch {chan configure $sock} state]} { |
||||
set sock [udp_open] |
||||
chan configure $sock -buffering none -translation binary |
||||
chan configure $sock -remote $sysloghost_port |
||||
} |
||||
} |
||||
} |
||||
proc _reconnect {} { |
||||
variable sock |
||||
catch {close $sock} |
||||
_initsock |
||||
return [chan configure $sock] |
||||
} |
||||
|
||||
proc send_info {client_tid ts_sent source msg} { |
||||
set ts_received [clock micros] |
||||
set lag_micros [expr {$ts_received - $ts_sent}] |
||||
set lag [expr {$lag_micros / 1000000.0}] ;#lag as x.xxxxxx seconds |
||||
log $client_tid $ts_sent $lag $source - info $msg line 1 |
||||
} |
||||
proc log {client_tid ts_sent lag source service level msg writebuffering {islog 0}} { |
||||
variable sock |
||||
variable fd |
||||
variable sysloghost_port |
||||
variable logfile |
||||
variable settings |
||||
|
||||
set logchunk $msg |
||||
|
||||
if {![dict get $settings -raw]} { |
||||
set tail_crlf 0 |
||||
set tail_lf 0 |
||||
set tail_cr 0 |
||||
#for cooked - always remove the trailing newline before splitting.. |
||||
# |
||||
#note that if we got our data from reading a non-line-buffered binary channel - then this naive line splitting will not split neatly for mixed line-endings. |
||||
# |
||||
#Possibly not critical as cooked is for logging and we are still preserving all \r and \n chars - but review and consider implementing a better split |
||||
#but add it back exactly as it was afterwards |
||||
#we can always split on \n - and any adjacent \r will be preserved in the rejoin |
||||
set lastchar [string range $logchunk end end] |
||||
if {[string range $logchunk end-1 end] eq "\r\n"} { |
||||
set tail_crlf 1 |
||||
set logchunk [string range $logchunk 0 end-2] |
||||
} else { |
||||
if {$lastchar eq "\n"} { |
||||
set tail_lf 1 |
||||
set logchunk [string range $logchunk 0 end-1] |
||||
} elseif {$lastchar eq "\r"} { |
||||
#\r line-endings are obsolete..and unlikely... and ugly as they can hide characters on the console. but we'll pass through anyway. |
||||
set tail_cr 1 |
||||
set logchunk [string range $logchunk 0 end-1] |
||||
} else { |
||||
#possibly a single line with no linefeed.. or has linefeeds only in the middle |
||||
} |
||||
} |
||||
|
||||
if {$ts_sent != 0} { |
||||
set micros [lindex [split [expr {$ts_sent / 1000000.0}] .] end] |
||||
set time_info [::shellthread::iso8601 $ts_sent].$micros |
||||
#set time_info "${time_info}+$lag" |
||||
set lagfp "+[format %f $lag]" |
||||
} else { |
||||
#from pipe - no ts_sent/lag info available |
||||
set time_info "" |
||||
set lagfp "" |
||||
} |
||||
|
||||
set idtail [string range $client_tid end-8 end] ;#enough for display purposes id - mostly zeros anyway |
||||
|
||||
|
||||
#set col0 [string repeat " " 9] |
||||
#set col1 [string repeat " " 27] |
||||
#set col2 [string repeat " " 11] |
||||
#set col3 [string repeat " " 22] |
||||
##do not columnize the final data column or append to tail - or we could muck up the crlf integrity |
||||
#lassign [list [overtype::left $col0 $idtail] [overtype::left $col1 $time_info] [overtype::left $col2 $lagfp] [overtype::left $col3 $source]] c0 c1 c2 c3 |
||||
|
||||
set w0 9 |
||||
set w1 27 |
||||
set w2 11 |
||||
set w3 22 ;#review - this can truncate source name without indication tail is missing |
||||
#do not columnize the final data column or append to tail - or we could muck up the crlf integrity |
||||
lassign [list \ |
||||
[format %-${w0}s $idtail]\ |
||||
[format %-${w1}s $time_info]\ |
||||
[format %-${w2}s $lagfp]\ |
||||
[format %-${w3}s $source]\ |
||||
] c0 c1 c2 c3 |
||||
set c2_blank [string repeat " " $w2] |
||||
|
||||
|
||||
#split on \n no matter the actual line-ending in use |
||||
#shouldn't matter as long as we don't add anything at the end of the line other than the raw data |
||||
#ie - don't quote or add spaces |
||||
set lines [split $logchunk \n] |
||||
|
||||
set i 1 |
||||
set outlines [list] |
||||
foreach ln $lines { |
||||
if {$i == 1} { |
||||
lappend outlines "$c0 $c1 $c2 $c3 $ln" |
||||
} else { |
||||
lappend outlines "$c0 $c1 $c2_blank $c3 $ln" |
||||
} |
||||
incr i |
||||
} |
||||
if {$tail_lf} { |
||||
set logchunk "[join $outlines \n]\n" |
||||
} elseif {$tail_crlf} { |
||||
set logchunk "[join $outlines \r\n]\r\n" |
||||
} elseif {$tail_cr} { |
||||
set logchunk "[join $outlines \r]\r" |
||||
} else { |
||||
#no trailing linefeed |
||||
set logchunk [join $outlines \n] |
||||
|
||||
} |
||||
|
||||
#set logchunk "[overtype::left $col0 $idtail] [overtype::left $col1 $time_info] [overtype::left $col2 "+$lagfp"] [overtype::left $col3 $source] $msg" |
||||
} |
||||
|
||||
if {[string length $sysloghost_port]} { |
||||
_initsock |
||||
catch {puts -nonewline $sock $logchunk} |
||||
} |
||||
#todo - sockets etc? |
||||
if {[string length $logfile]} { |
||||
#todo - setting to maintain open filehandle and reduce io. |
||||
# possible settings for buffersize - and maybe logrotation, although this could be left to client |
||||
#for now - default to safe option of open/close each write despite the overhead. |
||||
set fd [open $logfile a] |
||||
chan configure $fd -translation auto -buffering $writebuffering |
||||
#whether line buffered or not - by now our logchunk includes newlines |
||||
puts -nonewline $fd $logchunk |
||||
close $fd |
||||
} |
||||
} |
||||
|
||||
# - withdraw just this client |
||||
proc finish {tidclient} { |
||||
variable client_ids |
||||
if {($tidclient in $clientids) && ([llength $clientids] == 1)} { |
||||
terminate $tidclient |
||||
} else { |
||||
set posn [lsearch $client_ids $tidclient] |
||||
set client_ids [lreplace $clientids $posn $posn] |
||||
} |
||||
} |
||||
|
||||
#allow any client to terminate |
||||
proc terminate {tidclient} { |
||||
variable sock |
||||
variable fd |
||||
variable client_ids |
||||
if {$tidclient in $client_ids} { |
||||
catch {close $sock} |
||||
catch {close $fd} |
||||
set client_ids [list] |
||||
#review use of thread::release -wait |
||||
#docs indicate deprecated for regular use, and that we should use thread::join |
||||
#however.. how can we set a timeout on a thread::join ? |
||||
#by telling the thread to release itself - we can wait on the thread::send variable |
||||
# This needs review - because it's unclear that -wait even works on self |
||||
# (what does it mean to wait for the target thread to exit if the target is self??) |
||||
thread::release -wait |
||||
return [thread::id] |
||||
} else { |
||||
return "" |
||||
} |
||||
} |
||||
|
||||
|
||||
} |
||||
|
||||
|
||||
namespace eval shellthread::manager { |
||||
variable workers [dict create] |
||||
variable worker_errors [list] |
||||
variable timeouts |
||||
|
||||
variable free_threads [list] |
||||
#variable log_threads |
||||
|
||||
proc dict_getdef {dictValue args} { |
||||
if {[llength $args] < 2} { |
||||
error {wrong # args: should be "dict_getdef dictValue ?key ...? key default"} |
||||
} |
||||
set keys [lrange $args 0 end-1] |
||||
if {[tcl::dict::exists $dictValue {*}$keys]} { |
||||
return [tcl::dict::get $dictValue {*}$keys] |
||||
} else { |
||||
return [lindex $args end] |
||||
} |
||||
} |
||||
#new datastructure regarding workers and sourcetags required. |
||||
#one worker can service multiple sourcetags - but each sourcetag may be used by multiple threads too. |
||||
#generally each thread will use a specific sourcetag - but we may have pools doing similar things which log to same destination. |
||||
# |
||||
#As a convention we may use a sourcetag for the thread which started the worker that isn't actually used for logging - but as a common target for joins |
||||
#If the thread which started the thread calls leave_worker with that 'primary' sourcetag it means others won't be able to use that target - which seems reasonable. |
||||
#If another thread want's to maintain joinability beyond the span provided by the starting client, |
||||
#it can join with both the primary tag and a tag it will actually use for logging. |
||||
#A thread can join the logger with any existingtag - not just the 'primary' |
||||
#(which is arbitrary anyway. It will usually be the first in the list - but may be unsubscribed by clients and disappear) |
||||
proc join_worker {existingtag sourcetaglist} { |
||||
set client_tid [thread::id] |
||||
#todo - allow a source to piggyback on existing worker by referencing one of the sourcetags already using the worker |
||||
} |
||||
|
||||
proc new_pipe_worker {sourcetaglist {settingsdict {}}} { |
||||
if {[dict exists $settingsdict -workertype]} { |
||||
if {[string tolower [dict get $settingsdict -workertype]] ne "pipe"} { |
||||
error "new_pipe_worker error: -workertype ne 'pipe'. Set to 'pipe' or leave empty" |
||||
} |
||||
} |
||||
dict set settingsdict -workertype pipe |
||||
new_worker $sourcetaglist $settingsdict |
||||
} |
||||
|
||||
#it is up to caller to use a unique sourcetag (e.g by prefixing with own thread::id etc) |
||||
# This allows multiple threads to more easily write to the same named sourcetag if necessary |
||||
# todo - change sourcetag for a list of tags which will be handled by the same thread. e.g for multiple threads logging to same file |
||||
# |
||||
# todo - some protection mechanism for case where target is a file to stop creation of multiple worker threads writing to same file. |
||||
# Even if we use open fd,close fd wrapped around writes.. it is probably undesirable to have multiple threads with same target |
||||
# On the other hand socket targets such as UDP can happily be written to by multiple threads. |
||||
# For now the mechanism is that a call to new_worker (rename to open_worker?) will join the same thread if a sourcetag matches. |
||||
# but, as sourcetags can get removed(unsubbed via leave_worker) this doesn't guarantee two threads with same -file settings won't fight. |
||||
# Also.. the settingsdict is ignored when joining with a tag that exists.. this is problematic.. e.g logrotation where previous file still being written by existing worker |
||||
# todo - rename 'sourcetag' concept to 'targettag' ?? the concept is a mixture of both.. it is somewhat analagous to a syslog 'facility' |
||||
# probably new_worker should disallow auto-joining and we allow different workers to handle same tags simultaneously to support overlap during logrotation etc. |
||||
proc new_worker {sourcetaglist {settingsdict {}}} { |
||||
variable workers |
||||
set ts_start [clock micros] |
||||
set tidclient [thread::id] |
||||
set sourcetag [lindex $sourcetaglist 0] ;#todo - use all |
||||
|
||||
set defaults [dict create\ |
||||
-workertype message\ |
||||
] |
||||
set settingsdict [dict merge $defaults $settingsdict] |
||||
|
||||
set workertype [string tolower [dict get $settingsdict -workertype]] |
||||
set known_workertypes [list pipe message] |
||||
if {$workertype ni $known_workertypes} { |
||||
error "new_worker - unknown -workertype $workertype. Expected one of '$known_workertypes'" |
||||
} |
||||
|
||||
if {[dict exists $workers $sourcetag]} { |
||||
set winfo [dict get $workers $sourcetag] |
||||
if {[dict get $winfo tid] ne "noop" && [thread::exists [dict get $winfo tid]]} { |
||||
#add our client-info to existing worker thread |
||||
dict lappend winfo list_client_tids $tidclient |
||||
dict set workers $sourcetag $winfo ;#writeback |
||||
return [dict get $winfo tid] |
||||
} |
||||
} |
||||
|
||||
#noop fake worker for empty syslog and empty file |
||||
if {$workertype eq "message"} { |
||||
if {[dict_getdef $settingsdict -syslog ""] eq "" && [dict_getdef $settingsdict -file ""] eq ""} { |
||||
set winfo [dict create tid noop list_client_tids [list $tidclient] ts_start $ts_start ts_end_list [list] workertype "message"] |
||||
dict set workers $sourcetag $winfo |
||||
return noop |
||||
} |
||||
} |
||||
|
||||
#check if there is an existing unsubscribed thread first |
||||
#don't use free_threads for pipe workertype for now.. |
||||
variable free_threads |
||||
if {$workertype ne "pipe"} { |
||||
if {[llength $free_threads]} { |
||||
#todo - re-use from tail - as most likely to have been doing similar work?? review |
||||
|
||||
set free_threads [lassign $free_threads tidworker] |
||||
#todo - keep track of real ts_start of free threads... kill when too old |
||||
set winfo [dict create tid $tidworker list_client_tids [list $tidclient] ts_start $ts_start ts_end_list [list] workertype [dict get $settingsdict -workertype]] |
||||
#puts stderr "shellfilter::new_worker Re-using free worker thread: $tidworker with tag $sourcetag" |
||||
dict set workers $sourcetag $winfo |
||||
return $tidworker |
||||
} |
||||
} |
||||
|
||||
|
||||
#set ts_start [::shellthread::iso8601] |
||||
set tidworker [thread::create -preserved] |
||||
set init_script [string map [list %ts_start% $ts_start %mp% [tcl::tm::list] %ap% $::auto_path %tidcli% $tidclient %sd% $settingsdict] { |
||||
#set tclbase [file dirname [file dirname [info nameofexecutable]]] |
||||
#set tcllib $tclbase/lib |
||||
#if {$tcllib ni $::auto_path} { |
||||
# lappend ::auto_path $tcllib |
||||
#} |
||||
|
||||
set ::settingsinfo [dict create %sd%] |
||||
#if the executable running things is something like a tclkit, |
||||
# then it's likely we will need to use the caller's auto_path and tcl::tm::list to find things |
||||
#The caller can tune the thread's package search by providing a settingsdict |
||||
#tcl::tm::add * must add in reverse order to get reulting list in same order as original |
||||
if {![dict exists $::settingsinfo tcl_tm_list]} { |
||||
#JMN2 |
||||
::tcl::tm::add {*}[lreverse [list %mp%]] |
||||
} else { |
||||
tcl::tm::remove {*}[tcl::tm::list] |
||||
::tcl::tm::add {*}[lreverse [dict get $::settingsinfo tcl_tm_list]] |
||||
} |
||||
if {![dict exists $::settingsinfo auto_path]} { |
||||
set ::auto_path [list %ap%] |
||||
} else { |
||||
set ::auto_path [dict get $::settingsinfo auto_path] |
||||
} |
||||
|
||||
package require punk::packagepreference |
||||
punk::packagepreference::install |
||||
|
||||
package require Thread |
||||
package require shellthread |
||||
if {![catch {::shellthread::worker::init %tidcli% %ts_start% $::settingsinfo} errmsg]} { |
||||
unset ::settingsinfo |
||||
set ::shellthread_init "ok" |
||||
} else { |
||||
unset ::settingsinfo |
||||
set ::shellthread_init "err $errmsg" |
||||
} |
||||
}] |
||||
|
||||
thread::send -async $tidworker $init_script |
||||
#thread::send $tidworker $init_script |
||||
set winfo [dict create tid $tidworker list_client_tids [list $tidclient] ts_start $ts_start ts_end_list [list]] |
||||
dict set workers $sourcetag $winfo |
||||
return $tidworker |
||||
} |
||||
|
||||
proc set_pipe_read_from_client {tag_pipename worker_tid rchan args} { |
||||
variable workers |
||||
if {![dict exists $workers $tag_pipename]} { |
||||
error "workerthread::manager::set_pipe_read_from_client source/pipename $tag_pipename not found" |
||||
} |
||||
set match_worker_tid [dict get $workers $tag_pipename tid] |
||||
if {$worker_tid ne $match_worker_tid} { |
||||
error "workerthread::manager::set_pipe_read_from_client source/pipename $tag_pipename workert_tid mismatch '$worker_tid' vs existing:'$match_worker_tid'" |
||||
} |
||||
#buffering set during channel creation will be preserved on thread::transfer |
||||
thread::transfer $worker_tid $rchan |
||||
#start_pipe_read will vwait - so we have to send async |
||||
thread::send -async $worker_tid [list ::shellthread::worker::start_pipe_read $tag_pipename $rchan] |
||||
#client may start writing immediately - but presumably it will buffer in fifo2 |
||||
} |
||||
|
||||
proc set_pipe_write_to_client {tag_pipename worker_tid wchan args} { |
||||
variable workers |
||||
if {![dict exists $workers $tag_pipename]} { |
||||
error "workerthread::manager::set_pipe_write_to_client pipename $tag_pipename not found" |
||||
} |
||||
set match_worker_tid [dict get $workers $tag_pipename tid] |
||||
if {$worker_tid ne $match_worker_tid} { |
||||
error "workerthread::manager::set_pipe_write_to_client pipename $tag_pipename workert_tid mismatch '$worker_tid' vs existing:'$match_worker_tid'" |
||||
} |
||||
#buffering set during channel creation will be preserved on thread::transfer |
||||
thread::transfer $worker_tid $wchan |
||||
thread::send -async $worker_tid [list ::shellthread::worker::start_pipe_write $tag_pipename $wchan] |
||||
} |
||||
|
||||
proc write_log {source msg args} { |
||||
variable workers |
||||
set ts_micros_sent [clock micros] |
||||
set defaults [list -async 1 -level info] |
||||
set opts [dict merge $defaults $args] |
||||
|
||||
if {[dict exists $workers $source]} { |
||||
set tidworker [dict get $workers $source tid] |
||||
if {$tidworker eq "noop"} { |
||||
return |
||||
} |
||||
if {![thread::exists $tidworker]} { |
||||
# -syslog -file ? |
||||
set tidworker [new_worker $source] |
||||
} |
||||
} else { |
||||
#auto create with no requirement to call new_worker.. warn? |
||||
# -syslog -file ? |
||||
error "write_log no log opened for source: $source" |
||||
set tidworker [new_worker $source] |
||||
} |
||||
set client_tid [thread::id] |
||||
if {[dict get $opts -async]} { |
||||
thread::send -async $tidworker [list ::shellthread::worker::send_info $client_tid $ts_micros_sent $source $msg] |
||||
} else { |
||||
thread::send $tidworker [list ::shellthread::worker::send_info $client_tid $ts_micros_sent $source $msg] |
||||
} |
||||
} |
||||
proc report_worker_errors {errdict} { |
||||
variable workers |
||||
set reporting_tid [dict get $errdict worker_tid] |
||||
dict for {src srcinfo} $workers { |
||||
if {[dict get $srcinfo tid] eq $reporting_tid} { |
||||
dict set srcinfo errors [dict get $errdict errors] |
||||
dict set workers $src $srcinfo ;#writeback updated |
||||
break |
||||
} |
||||
} |
||||
} |
||||
|
||||
#aka leave_worker |
||||
#Note that the tags may be on separate workertids, or some tags may share workertids |
||||
proc unsubscribe {sourcetaglist} { |
||||
variable workers |
||||
#workers structure example: |
||||
#[list sourcetag1 [list tid <tidworker> list_client_tids <clients>] ts_start <ts_start> ts_end_list {}] |
||||
variable free_threads |
||||
set mytid [thread::id] ;#caller of shellthread::manager::xxx is the client thread |
||||
|
||||
set subscriberless_tags [list] |
||||
foreach source $sourcetaglist { |
||||
if {[dict exists $workers $source]} { |
||||
set list_client_tids [dict get $workers $source list_client_tids] |
||||
if {[set posn [lsearch $list_client_tids $mytid]] >= 0} { |
||||
set list_client_tids [lreplace $list_client_tids $posn $posn] |
||||
dict set workers $source list_client_tids $list_client_tids |
||||
} |
||||
if {![llength $list_client_tids]} { |
||||
lappend subscriberless_tags $source |
||||
} |
||||
} |
||||
} |
||||
|
||||
#we've removed our own tid from all the tags - possibly across multiplew workertids, and possibly leaving some workertids with no subscribers for a particular tag - or no subscribers at all. |
||||
|
||||
set subscriberless_workers [list] |
||||
set shuttingdown_workers [list] |
||||
foreach deadtag $subscriberless_tags { |
||||
set workertid [dict get $workers $deadtag tid] |
||||
set worker_tags [get_worker_tagstate $workertid] |
||||
set subscriber_count 0 |
||||
set kill_count 0 ;#number of ts_end_list entries - even one indicates thread is doomed |
||||
foreach taginfo $worker_tags { |
||||
incr subscriber_count [llength [dict get $taginfo list_client_tids]] |
||||
incr kill_count [llength [dict get $taginfo ts_end_list]] |
||||
} |
||||
if {$subscriber_count == 0} { |
||||
lappend subscriberless_workers $workertid |
||||
} |
||||
if {$kill_count > 0} { |
||||
lappend shuttingdown_workers $workertid |
||||
} |
||||
} |
||||
|
||||
#if worker isn't shutting down - add it to free_threads list |
||||
foreach workertid $subscriberless_workers { |
||||
if {$workertid ni $shuttingdown_workers} { |
||||
if {$workertid ni $free_threads && $workertid ne "noop"} { |
||||
lappend free_threads $workertid |
||||
} |
||||
} |
||||
} |
||||
|
||||
#todo |
||||
#unsub this client_tid from the sourcetags in the sourcetaglist. if no more client_tids exist for sourcetag, remove sourcetag, |
||||
#if no more sourcetags - add worker to free_threads |
||||
} |
||||
proc get_worker_tagstate {workertid} { |
||||
variable workers |
||||
set taginfo_list [list] |
||||
dict for {source sourceinfo} $workers { |
||||
if {[dict get $sourceinfo tid] eq $workertid} { |
||||
lappend taginfo_list $sourceinfo |
||||
} |
||||
} |
||||
return $taginfo_list |
||||
} |
||||
|
||||
#finalisation |
||||
proc shutdown_free_threads {{timeout 2500}} { |
||||
variable free_threads |
||||
if {![llength $free_threads]} { |
||||
return |
||||
} |
||||
upvar ::shellthread::manager::timeouts timeoutarr |
||||
if {[info exists timeoutarr(shutdown_free_threads)]} { |
||||
#already called |
||||
return false |
||||
} |
||||
#set timeoutarr(shutdown_free_threads) waiting |
||||
#after $timeout [list set timeoutarr(shutdown_free_threads) timed-out] |
||||
set ::shellthread::waitfor waiting |
||||
after $timeout [list set ::shellthread::waitfor] |
||||
|
||||
set waiting_for [list] |
||||
set ended [list] |
||||
set timedout 0 |
||||
foreach tid $free_threads { |
||||
if {[thread::exists $tid]} { |
||||
lappend waiting_for $tid |
||||
#thread::send -async $tid [list shellthread::worker::terminate [thread::id]] timeoutarr(shutdown_free_threads) |
||||
thread::send -async $tid [list shellthread::worker::terminate [thread::id]] ::shellthread::waitfor |
||||
} |
||||
} |
||||
if {[llength $waiting_for]} { |
||||
for {set i 0} {$i < [llength $waiting_for]} {incr i} { |
||||
vwait ::shellthread::waitfor |
||||
if {$::shellthread::waitfor eq "timed-out"} { |
||||
set timedout 1 |
||||
break |
||||
} else { |
||||
lappend ended $::shellthread::waitfor |
||||
} |
||||
} |
||||
} |
||||
set free_threads [list] |
||||
return [dict create existed $waiting_for ended $ended timedout $timedout] |
||||
} |
||||
|
||||
#TODO - important. |
||||
#REVIEW! |
||||
#since moving to the unsubscribe mechansm - close_worker $source isn't being called |
||||
# - we need to set a limit to the number of free threads and shut down excess when detected during unsubscription |
||||
#instruction to shut-down the thread that has this source. |
||||
#instruction to shut-down the thread that has this source. |
||||
proc close_worker {source {timeout 2500}} { |
||||
variable workers |
||||
variable worker_errors |
||||
variable free_threads |
||||
upvar ::shellthread::manager::timeouts timeoutarr |
||||
set ts_now [clock micros] |
||||
#puts stderr "close_worker $source" |
||||
if {[dict exists $workers $source]} { |
||||
set tidworker [dict get $workers $source tid] |
||||
if {$tidworker in $freethreads} { |
||||
#make sure a thread that is being closed is removed from the free_threads list |
||||
set posn [lsearch $freethreads $tidworker] |
||||
set freethreads [lreplace $freethreads $posn $posn] |
||||
} |
||||
set mytid [thread::id] |
||||
set client_tids [dict get $workers $source list_client_tids] |
||||
if {[set posn [lsearch $client_tids $mytid]] >= 0} { |
||||
set client_tids [lreplace $client_tids $posn $posn] |
||||
#remove self from list of clients |
||||
dict set workers $source list_client_tids $client_tids |
||||
} |
||||
set ts_end_list [dict get $workers $source ts_end_list] ;#ts_end_list is just a list of timestamps of closing calls for this source - only one is needed to close, but they may all come in a flurry. |
||||
if {[llength $ts_end_list]} { |
||||
set last_end_ts [lindex $ts_end_list end] |
||||
if {(($tsnow - $last_end_ts) / 1000) >= $timeout} { |
||||
lappend ts_end_list $ts_now |
||||
dict set workers $source ts_end_list $ts_end_list |
||||
} else { |
||||
#existing close in progress.. assume it will work |
||||
return |
||||
} |
||||
} |
||||
|
||||
if {[thread::exists $tidworker]} { |
||||
#puts stderr "shellthread::manager::close_worker: thread $tidworker for source $source still running.. terminating" |
||||
|
||||
#review - timeoutarr is local var (?) |
||||
set timeoutarr($source) 0 |
||||
after $timeout [list set timeoutarr($source) 2] |
||||
|
||||
thread::send -async $tidworker [list shellthread::worker::send_errors_now [thread::id]] |
||||
thread::send -async $tidworker [list shellthread::worker::terminate [thread::id]] timeoutarr($source) |
||||
|
||||
#thread::send -async $tidworker [string map [list %tidclient% [thread::id]] { |
||||
# shellthread::worker::terminate %tidclient% |
||||
#}] timeoutarr($source) |
||||
|
||||
vwait timeoutarr($source) |
||||
#puts stderr "shellthread::manager::close_worker: thread $tidworker for source $source DONE1" |
||||
|
||||
thread::release $tidworker |
||||
#puts stderr "shellthread::manager::close_worker: thread $tidworker for source $source DONE2" |
||||
if {[dict exists $workers $source errors]} { |
||||
set errlist [dict get $workers $source errors] |
||||
if {[llength $errlist]} { |
||||
lappend worker_errors [list $source [dict get $workers $source]] |
||||
} |
||||
} |
||||
dict unset workers $source |
||||
} else { |
||||
#thread may have been closed by call to close_worker with another source with same worker |
||||
#clear workers record for this source |
||||
#REVIEW - race condition for re-creation of source with new workerid? |
||||
#check that record is subscriberless to avoid this |
||||
if {[llength [dict get $workers $source list_client_tids]] == 0} { |
||||
dict unset workers $source |
||||
} |
||||
} |
||||
} |
||||
#puts stdout "close_worker $source - end" |
||||
} |
||||
|
||||
#worker errors only available for a source after close_worker called on that source |
||||
#It is possible for there to be multiple entries for a source because new_worker can be called multiple times with same sourcetag, |
||||
proc get_and_clear_errors {source} { |
||||
variable worker_errors |
||||
set source_errors [lsearch -all -inline -index 0 $worker_errors $source] |
||||
set worker_errors [lsearch -all -inline -index 0 -not $worker_errors $source] |
||||
return $source_errors |
||||
} |
||||
|
||||
|
||||
} |
||||
|
||||
package provide shellthread [namespace eval shellthread { |
||||
variable version |
||||
set version 1.6.1 |
||||
}] |
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
@ -0,0 +1,890 @@
|
||||
# vim: set ft=tcl |
||||
# |
||||
#purpose: handle the run commands that call shellfilter::run |
||||
#e.g run,runout,runerr,runx |
||||
|
||||
package require shellfilter |
||||
package require punk::ansi |
||||
|
||||
#NOTE: the run,runout,runerr,runx commands only produce an error if the command didn't run. |
||||
# - If it did run, but there was a non-zero exitcode it is up to the application to check that. |
||||
#This is deliberate, but means 'catch' doesn't catch errors within the command itself - the exitcode has to be checked. |
||||
#The user can always use exec for different process error semantics (they don't get exitcode with exec) |
||||
|
||||
namespace eval shellrun { |
||||
variable PUNKARGS |
||||
variable runout |
||||
variable runerr |
||||
|
||||
#do we need these? |
||||
#variable punkout |
||||
#variable punkerr |
||||
|
||||
#some ugly coupling with punk/punk::config for now |
||||
#todo - something better |
||||
if {[info exists ::punk::config::configdata]} { |
||||
set conf_running [punk::config::configure running] |
||||
set syslog_stdout [dict get $conf_running syslog_stdout] |
||||
set syslog_stderr [dict get $conf_running syslog_stderr] |
||||
set logfile_stdout [dict get $conf_running logfile_stdout] |
||||
set logfile_stderr [dict get $conf_running logfile_stderr] |
||||
} else { |
||||
lassign [list "" "" "" ""] syslog_stdout syslog_stderr logfile_stdout logfile_stderr |
||||
} |
||||
if {"punkshout" ni [shellfilter::stack::items]} { |
||||
set outdevice [shellfilter::stack::new punkshout -settings [list -tag "punkshout" -buffering none -raw 1 -syslog $syslog_stdout -file $logfile_stdout]] |
||||
set out [dict get $outdevice localchan] |
||||
} else { |
||||
set out [dict get [shellfilter::stack::item punkshout] device localchan] |
||||
} |
||||
if {"punksherr" ni [shellfilter::stack::items]} { |
||||
set errdevice [shellfilter::stack::new punksherr -settings [list -tag "punksherr" -buffering none -raw 1 -syslog $syslog_stderr -file $logfile_stderr]] |
||||
set err [dict get $errdevice localchan] |
||||
} else { |
||||
set err [dict get [shellfilter::stack::item punksherr] device localchan] |
||||
} |
||||
|
||||
namespace import ::punk::ansi::a+ |
||||
namespace import ::punk::ansi::a |
||||
|
||||
|
||||
|
||||
|
||||
#repltelemetry - additional/alternative display info used in a repl context i.e info directed towards the screen |
||||
#todo - package up in repltelemetry module and rewrite proc based on whether the module was found/loaded. |
||||
#somewhat strong coupling to punk - but let's try to behave decently if it's not loaded |
||||
#The last_run_display is actually intended for the repl - but is resident in the punk namespace with a view to the possibility of a different repl being in use. |
||||
proc set_last_run_display {chunklist} { |
||||
#chunklist as understood by the |
||||
if {![info exists ::punk::repltelemetry_emmitters]} { |
||||
namespace eval ::punk { |
||||
variable repltelemetry_emmitters |
||||
set repltelemetry_emmitters "shellrun" |
||||
} |
||||
} else { |
||||
if {"shellrun" ni $::punk::repltelemetry_emmitters} { |
||||
lappend punk::repltelemetry_emmitters "shellrun" |
||||
} |
||||
} |
||||
|
||||
#most basic of validity tests here.. just that it is a list (can be empty). We don't want to duplicate or over-constrain the way repls/shells/terminals interpet the info |
||||
if {[catch {llength $chunklist} errMsg]} { |
||||
error "set_last_run_display expects a list. Value supplied doesn't appear to be a well formed tcl list. '$errMsg'" |
||||
} |
||||
#todo - |
||||
tsv::lappend repl runchunks-[tsv::get repl runid] {*}$chunklist |
||||
} |
||||
|
||||
|
||||
|
||||
#maintenance: similar used in punk::ns & punk::winrun |
||||
#todo - take runopts + aliases as args |
||||
#longopts must be passed as a single item ie --timeout=100 not --timeout 100 |
||||
proc get_run_opts {arglist} { |
||||
if {[catch { |
||||
set callerinfo [info level -1] |
||||
} errM]} { |
||||
set caller "" |
||||
} else { |
||||
set caller [lindex $callerinfo 0] |
||||
} |
||||
|
||||
#we provide -nonewline even for 'run' even though run doesn't deliver stderr or stdout to the tcl return value |
||||
#This is for compatibility with other runX commands, and the difference is also visible when calling from repl. |
||||
set known_runopts [list "-echo" "-e" "-nonewline" "-n" "-tcl" "-debug"] |
||||
set known_longopts [list "--timeout"] |
||||
set known_longopts_msg "" |
||||
foreach lng $known_longopts { |
||||
append known_longopts_msg "${lng}=val " |
||||
} |
||||
set aliases [list "-e" "-echo" "-echo" "-echo" "-n" "-nonewline" "-nonewline" "-nonewline" "-tcl" "-tcl" "-debug" "-debug"] ;#include map to self |
||||
set runopts [list] |
||||
set runoptslong [list] |
||||
set cmdargs [list] |
||||
|
||||
set idx_first_cmdarg [lsearch -not $arglist "-*"] |
||||
|
||||
set allopts [lrange $arglist 0 $idx_first_cmdarg-1] |
||||
set cmdargs [lrange $arglist $idx_first_cmdarg end] |
||||
foreach o $allopts { |
||||
if {[string match --* $o]} { |
||||
lassign [split $o =] flagpart valpart |
||||
if {$valpart eq ""} { |
||||
error "$caller: longopt $o seems to be missing a value - must be of form --option=value" |
||||
} |
||||
if {$flagpart ni $known_longopts} { |
||||
error "$caller: Unknown runoption $o - known options $known_runopts $known_longopts_msg" |
||||
} |
||||
lappend runoptslong $flagpart $valpart |
||||
} else { |
||||
if {$o ni $known_runopts} { |
||||
error "$caller: Unknown runoption $o - known options $known_runopts $known_longopts_msg" |
||||
} |
||||
lappend runopts [dict get $aliases $o] |
||||
} |
||||
} |
||||
return [list runopts $runopts runoptslong $runoptslong cmdargs $cmdargs] |
||||
} |
||||
|
||||
|
||||
#todo - investigate cause of punk86 run hanging sometimes. An 'after 500' before exit in the called script fixes the issue. punk87 doesn't seem to be affected. |
||||
lappend PUNKARGS [list { |
||||
@id -id ::shellrun::run |
||||
@leaders -min 0 -max 0 |
||||
@opts |
||||
-nonewline -type none |
||||
-tcl -type none -default 0 |
||||
-debug -type none -default 0 |
||||
--timeout= -type integer |
||||
@values -min 1 -max -1 |
||||
cmdname -type string |
||||
cmdarg -type any -multiple 1 -optional 1 |
||||
}] |
||||
proc run {args} { |
||||
#set_last_run_display [list] |
||||
|
||||
#set splitargs [get_run_opts $args] |
||||
#set runopts [dict get $splitargs runopts] |
||||
#set runoptslong [dict get $splitargs runoptslong] |
||||
#set cmdargs [dict get $splitargs cmdargs] |
||||
set argd [punk::args::parse $args withid ::shellrun::run] |
||||
lassign [dict values $argd] leaders opts values received |
||||
|
||||
if {[dict exists $received "-nonewline"]} { |
||||
set nonewline 1 |
||||
} else { |
||||
set nonewline 0 |
||||
} |
||||
#review nonewline does nothing here.. |
||||
|
||||
set idlist_stderr [list] |
||||
#we leave stdout without imposed ansi colouring - because the source may be colourised and because ansi-wrapping a stream at whatever boundaries it comes in at isn't a really nice thing to do. |
||||
#stderr might have source colouring - but it usually doesn't seem to, and the visual distiction of red stderr can be very handy for the run command. |
||||
#A further enhancement could be to detect well-known options such as --color and/or use a configuration for specific commands that have useful colourised stderr, |
||||
#but having an option to configure stderr to red is a compromise. |
||||
#Note that the other run commands, runout,runerr, runx don't emit in real-time - so for those commands there may be options to detect and/or post-process stdout and stderr. |
||||
#TODO - fix. This has no effect if/when the repl adds an ansiwrap transform |
||||
# what we probably want to do is 'aside' that transform for runxxx commands only. |
||||
#lappend idlist_stderr [shellfilter::stack::add stderr ansiwrap -settings {-colour {red bold}}] |
||||
|
||||
set callopts [dict create] |
||||
if {[dict exists $received "-tcl"]} { |
||||
dict set callopts -tclscript 1 |
||||
} |
||||
if {[dict exists $received "-debug"]} { |
||||
dict set callopts -debug 1 |
||||
} |
||||
if {[dict exists $received --timeout]} { |
||||
dict set callopts -timeout [dict get $opts --timeout] ;#convert to single dash |
||||
} |
||||
set cmdname [dict get $values cmdname] |
||||
if {[dict exists $received cmdarg]} { |
||||
set cmdarglist [dict get $values cmdarg] |
||||
} else { |
||||
set cmdarglist {} |
||||
} |
||||
set cmdargs [concat $cmdname $cmdarglist] |
||||
#--------------------------------------------------------------------------------------------- |
||||
set exitinfo [shellfilter::run $cmdargs {*}$callopts -teehandle punksh -inbuffering none -outbuffering none ] |
||||
#--------------------------------------------------------------------------------------------- |
||||
|
||||
foreach id $idlist_stderr { |
||||
shellfilter::stack::remove stderr $id |
||||
} |
||||
|
||||
flush stderr |
||||
flush stdout |
||||
|
||||
if {[dict exists $exitinfo error]} { |
||||
error "[dict get $exitinfo error]\n$exitinfo" |
||||
} |
||||
|
||||
return $exitinfo |
||||
} |
||||
|
||||
lappend PUNKARGS [list { |
||||
@id -id ::shellrun::runconsole |
||||
@leaders -min 0 -max 0 |
||||
@opts |
||||
@values -min 1 -max -1 |
||||
cmdname -type string |
||||
cmdarg -type any -multiple 1 -optional 1 |
||||
}] |
||||
#run in the way tcl unknown does - but without regard to auto_noexec |
||||
proc runconsole {args} { |
||||
set argd [punk::args::parse $args withid ::shellrun::runconsole] |
||||
lassign [dict values $argd] leaders opts values received |
||||
set cmdname [dict get $values cmdname] |
||||
if {[dict exists $received cmdarg]} { |
||||
set arglist [dict get $values cmdarg] |
||||
} else { |
||||
set arglist {} |
||||
} |
||||
|
||||
set resolved_cmdname [auto_execok $cmdname] |
||||
set repl_runid [punk::get_repl_runid] |
||||
#set ::punk::last_run_display [list] |
||||
|
||||
set redir ">&@stdout <@stdin" |
||||
uplevel 1 [list ::catch [concat exec $redir $resolved_cmdname $arglist] ::tcl::UnknownResult ::tcl::UnknownOptions] |
||||
#we can't detect stdout/stderr output from the exec |
||||
#for now emit an extra \n on stderr |
||||
#todo - there is probably no way around this but to somehow exec in the context of a completely separate console |
||||
#This is probably a tricky problem - especially to do cross-platform |
||||
# |
||||
# - use [dict get $::tcl::UnknownOptions -code] (0|1) exit |
||||
if {[dict get $::tcl::UnknownOptions -code] == 0} { |
||||
set c green |
||||
set m "ok" |
||||
} else { |
||||
set c yellow |
||||
set m "errorCode $::errorCode" |
||||
} |
||||
set chunklist [list] |
||||
lappend chunklist [list "info" "[a $c]$m[a] " ] |
||||
if {$repl_runid != 0} { |
||||
tsv::lappend repl runchunks-$repl_runid {*}$chunklist |
||||
} |
||||
|
||||
dict incr ::tcl::UnknownOptions -level |
||||
return -options $::tcl::UnknownOptions $::tcl::UnknownResult |
||||
} |
||||
lappend PUNKARGS [list { |
||||
@id -id ::shellrun::runout |
||||
@leaders -min 0 -max 0 |
||||
@opts |
||||
-echo -type none |
||||
-nonewline -type none |
||||
-tcl -type none -default 0 |
||||
-debug -type none -default 0 |
||||
--timeout= -type integer |
||||
@values -min 1 -max -1 |
||||
cmdname -type string |
||||
cmdarg -type any -multiple 1 -optional 1 |
||||
}] |
||||
proc runout {args} { |
||||
set argd [punk::args::parse $args withid ::shellrun::runout] |
||||
lassign [dict values $argd] leaders opts values received |
||||
|
||||
if {[dict exists $received "-nonewline"]} { |
||||
set nonewline 1 |
||||
} else { |
||||
set nonewline 0 |
||||
} |
||||
|
||||
#set_last_run_display [list] |
||||
variable runout |
||||
variable runerr |
||||
set runout "" |
||||
set runerr "" |
||||
set RST [a] |
||||
|
||||
#set splitargs [get_run_opts $args] |
||||
#set runopts [dict get $splitargs runopts] |
||||
#set cmdargs [dict get $splitargs cmdargs] |
||||
|
||||
|
||||
#puts stdout "RUNOUT cmdargs: $cmdargs" |
||||
|
||||
#todo add -data boolean and -data lastwrite to -settings with default being -data all |
||||
# because sometimes we're only interested in last char (e.g to detect something was output) |
||||
|
||||
#set outvar_stackid [shellfilter::stack::add commandout tee_to_var -action float -settings {-varname ::runout}] |
||||
# |
||||
#when not echoing - use float-locked so that the repl's stack is bypassed |
||||
if {[dict exists $received "-echo"]} { |
||||
set stdout_stackid [shellfilter::stack::add stdout tee_to_var -action float-locked -settings {-varname ::shellrun::runout}] |
||||
set stderr_stackid [shellfilter::stack::add stderr tee_to_var -action float-locked -settings {-varname ::shellrun::runerr}] |
||||
#set stderr_stackid [shellfilter::stack::add stderr tee_to_var -action sink-locked -settings {-varname ::shellrun::runerr}] |
||||
} else { |
||||
set stdout_stackid [shellfilter::stack::add stdout var -action float-locked -settings {-varname ::shellrun::runout}] |
||||
set stderr_stackid [shellfilter::stack::add stderr var -action float-locked -settings {-varname ::shellrun::runerr}] |
||||
} |
||||
|
||||
set callopts [dict create] |
||||
if {[dict exists $received "-tcl"]} { |
||||
dict set callopts -tclscript 1 |
||||
} |
||||
if {[dict exists $received "-debug"]} { |
||||
dict set callopts -debug 1 |
||||
} |
||||
if {[dict exists $received --timeout]} { |
||||
dict set callopts -timeout [dict get $opts --timeout] ;#convert to single dash |
||||
} |
||||
set cmdname [dict get $values cmdname] |
||||
if {[dict exists $received cmdarg]} { |
||||
set cmdarglist [dict get $values cmdarg] |
||||
} else { |
||||
set cmdarglist {} |
||||
} |
||||
set cmdargs [concat $cmdname $cmdarglist] |
||||
|
||||
#shellfilter::run [lrange $args 1 end] -teehandle punksh -outchan stdout -inbuffering none -outbuffering none -stdinhandler ::repl::repl_handler |
||||
set exitinfo [shellfilter::run $cmdargs {*}$callopts -teehandle punksh -inbuffering none -outbuffering none ] |
||||
|
||||
flush stderr |
||||
flush stdout |
||||
|
||||
shellfilter::stack::remove stdout $stdout_stackid |
||||
shellfilter::stack::remove stderr $stderr_stackid |
||||
|
||||
#shellfilter::stack::remove commandout $outvar_stackid |
||||
|
||||
if {[dict exists $exitinfo error]} { |
||||
if {[dict exists $received "-tcl"]} { |
||||
|
||||
} else { |
||||
#we must raise an error. |
||||
#todo - check errorInfo makes sense.. return -code? tailcall? |
||||
# |
||||
set msg "" |
||||
append msg [dict get $exitinfo error] |
||||
append msg "\n(add -tcl option to run as a tcl command/script instead of an external command)" |
||||
error $msg |
||||
} |
||||
} |
||||
|
||||
set chunklist [list] |
||||
|
||||
#exitcode not part of return value for runout - colourcode appropriately |
||||
set n $RST |
||||
set c "" |
||||
|
||||
if {[dict exists $exitinfo exitcode]} { |
||||
set code [dict get $exitinfo exitcode] |
||||
if {$code == 0} { |
||||
set c [a+ green] |
||||
} else { |
||||
set c [a+ white bold] |
||||
} |
||||
lappend chunklist [list "info" "$c$exitinfo$n"] |
||||
} elseif {[dict exists $exitinfo error]} { |
||||
set c [a+ yellow bold] |
||||
lappend chunklist [list "info" "${c}error [dict get $exitinfo error]$n"] |
||||
lappend chunklist [list "info" "errorCode [dict get $exitinfo errorCode]"] |
||||
#lappend chunklist [list "info" "errorInfo [list [dict get $exitinfo errorInfo]]"] |
||||
lappend chunklist [list "info" errorInfo] |
||||
lappend chunklist [list "stderr" [dict get $exitinfo errorInfo]] |
||||
} else { |
||||
set c [a+ Yellow red bold] |
||||
#lappend chunklist [list "info" "$c$exitinfo$n"] |
||||
lappend chunklist [list "info" [punk::ansi::ansiwrap_raw $c \x1b\[m "" $exitinfo]] |
||||
} |
||||
|
||||
|
||||
set chunk "[a+ red bold]stderr$RST" |
||||
lappend chunklist [list "info" $chunk] |
||||
|
||||
set chunk "" |
||||
if {[string length $::shellrun::runerr]} { |
||||
if {$nonewline} { |
||||
set e [string trimright $::shellrun::runerr \r\n] |
||||
} else { |
||||
set e $::shellrun::runerr |
||||
} |
||||
#append chunk "[a+ red normal]$e$RST\n" |
||||
append chunk "[a+ red normal]$e$RST" |
||||
} |
||||
lappend chunklist [list stderr $chunk] |
||||
|
||||
|
||||
|
||||
|
||||
lappend chunklist [list "info" "[a+ white bold]stdout$RST"] |
||||
set chunk "" |
||||
if {[string length $::shellrun::runout]} { |
||||
if {$nonewline} { |
||||
set o [string trimright $::shellrun::runout \r\n] |
||||
} else { |
||||
set o $::shellrun::runout |
||||
} |
||||
append chunk "$o" |
||||
} |
||||
lappend chunklist [list result $chunk] |
||||
|
||||
|
||||
#set_last_run_display $chunklist |
||||
tsv::lappend repl runchunks-[tsv::get repl runid] {*}$chunklist |
||||
|
||||
if {$nonewline} { |
||||
return [string trimright $::shellrun::runout \r\n] |
||||
} else { |
||||
return $::shellrun::runout |
||||
} |
||||
} |
||||
|
||||
lappend PUNKARGS [list { |
||||
@id -id ::shellrun::runerr |
||||
@leaders -min 0 -max 0 |
||||
@opts |
||||
-echo -type none |
||||
-nonewline -type none |
||||
-tcl -type none -default 0 |
||||
-debug -type none -default 0 |
||||
--timeout= -type integer |
||||
@values -min 1 -max -1 |
||||
cmdname -type string |
||||
cmdarg -type any -multiple 1 -optional 1 |
||||
}] |
||||
proc runerr {args} { |
||||
set argd [punk::args::parse $args withid ::shellrun::runout] |
||||
lassign [dict values $argd] leaders opts values received |
||||
|
||||
if {[dict exists $received "-nonewline"]} { |
||||
set nonewline 1 |
||||
} else { |
||||
set nonewline 0 |
||||
} |
||||
|
||||
#set_last_run_display [list] |
||||
variable runout |
||||
variable runerr |
||||
set runout "" |
||||
set runerr "" |
||||
|
||||
#set splitargs [get_run_opts $args] |
||||
#set runopts [dict get $splitargs runopts] |
||||
#set cmdargs [dict get $splitargs cmdargs] |
||||
|
||||
set callopts [dict create] |
||||
if {[dict exists $received "-tcl"]} { |
||||
dict set callopts -tclscript 1 |
||||
} |
||||
if {[dict exists $received "-debug"]} { |
||||
dict set callopts -debug 1 |
||||
} |
||||
if {[dict exists $received --timeout]} { |
||||
dict set callopts -timeout [dict get $opts --timeout] ;#convert to single dash |
||||
} |
||||
set cmdname [dict get $values cmdname] |
||||
if {[dict exists $received cmdarg]} { |
||||
set cmdarglist [dict get $values cmdarg] |
||||
} else { |
||||
set cmdarglist {} |
||||
} |
||||
set cmdargs [concat $cmdname $cmdarglist] |
||||
|
||||
if {[dict exists $received "-tcl"]} { |
||||
append callopts " -tclscript 1" |
||||
} |
||||
if {[dict exists $received "-echo"]} { |
||||
set stderr_stackid [shellfilter::stack::add stderr tee_to_var -action float-locked -settings {-varname ::shellrun::runerr}] |
||||
set stdout_stackid [shellfilter::stack::add stdout tee_to_var -action float-locked -settings {-varname ::shellrun::runout}] |
||||
} else { |
||||
set stderr_stackid [shellfilter::stack::add stderr var -action float-locked -settings {-varname ::shellrun::runerr}] |
||||
set stdout_stackid [shellfilter::stack::add stdout var -action float-locked -settings {-varname ::shellrun::runout}] |
||||
} |
||||
|
||||
|
||||
set exitinfo [shellfilter::run $cmdargs {*}$callopts -teehandle punksh -inbuffering none -outbuffering none -stdinhandler ::repl::repl_handler] |
||||
shellfilter::stack::remove stderr $stderr_stackid |
||||
shellfilter::stack::remove stdout $stdout_stackid |
||||
|
||||
|
||||
flush stderr |
||||
flush stdout |
||||
|
||||
#we raise an error because an error during calling is different to collecting stderr from a command, and the caller should be able to wrap in a catch |
||||
# to determine something other than just a nonzero exit code or output on stderr. |
||||
if {[dict exists $exitinfo error]} { |
||||
if {[dict exists $received "-tcl"]} { |
||||
|
||||
} else { |
||||
#todo - check errorInfo makes sense.. return -code? tailcall? |
||||
error [dict get $exitinfo error] |
||||
} |
||||
} |
||||
|
||||
set chunklist [list] |
||||
|
||||
set n [a] |
||||
set c "" |
||||
if {[dict exists $exitinfo exitcode]} { |
||||
set code [dict get $exitinfo exitcode] |
||||
if {$code == 0} { |
||||
set c [a+ green] |
||||
} else { |
||||
set c [a+ white bold] |
||||
} |
||||
lappend chunklist [list "info" "$c$exitinfo$n"] |
||||
} elseif {[dict exists $exitinfo error]} { |
||||
set c [a+ yellow bold] |
||||
lappend chunklist [list "info" "error [dict get $exitinfo error]"] |
||||
lappend chunklist [list "info" "errorCode [dict get $exitinfo errorCode]"] |
||||
lappend chunklist [list "info" "errorInfo [list [dict get $exitinfo errorInfo]]"] |
||||
} else { |
||||
set c [a+ Yellow red bold] |
||||
#lappend chunklist [list "info" "$c$exitinfo$n"] |
||||
lappend chunklist [list "info" [punk::ansi::ansiwrap_raw $c "\x1b\[m" "" $exitinfo]] |
||||
} |
||||
|
||||
|
||||
lappend chunklist [list "info" "[a+ white bold]stdout[a]"] |
||||
set chunk "" |
||||
if {[string length $::shellrun::runout]} { |
||||
if {$nonewline} { |
||||
set o [string trimright $::shellrun::runout \r\n] |
||||
} else { |
||||
set o $::shellrun::runout |
||||
} |
||||
append chunk "[a+ white normal]$o[a]\n" ;#this newline is the display output separator - always there whether data has trailing newline or not. |
||||
} |
||||
lappend chunklist [list stdout $chunk] |
||||
|
||||
|
||||
#set c_stderr [punk::config] |
||||
set chunk "[a+ red bold]stderr[a]" |
||||
lappend chunklist [list "info" $chunk] |
||||
|
||||
set chunk "" |
||||
if {[string length $::shellrun::runerr]} { |
||||
if {$nonewline} { |
||||
set e [string trimright $::shellrun::runerr \r\n] |
||||
} else { |
||||
set e $::shellrun::runerr |
||||
} |
||||
append chunk "$e" |
||||
} |
||||
lappend chunklist [list resulterr $chunk] |
||||
|
||||
|
||||
#set_last_run_display $chunklist |
||||
tsv::lappend repl runchunks-[tsv::get repl runid] {*}$chunklist |
||||
|
||||
if {$nonewline} { |
||||
return [string trimright $::shellrun::runerr \r\n] |
||||
} |
||||
return $::shellrun::runerr |
||||
} |
||||
|
||||
|
||||
proc runx {args} { |
||||
#set_last_run_display [list] |
||||
variable runout |
||||
variable runerr |
||||
set runout "" |
||||
set runerr "" |
||||
|
||||
set splitargs [get_run_opts $args] |
||||
set runopts [dict get $splitargs runopts] |
||||
set cmdargs [dict get $splitargs cmdargs] |
||||
|
||||
if {"-nonewline" in $runopts} { |
||||
set nonewline 1 |
||||
} else { |
||||
set nonewline 0 |
||||
} |
||||
|
||||
#shellfilter::stack::remove stdout $::repl::id_outstack |
||||
|
||||
if {"-echo" in $runopts} { |
||||
#float to ensure repl transform doesn't interfere with the output data |
||||
set stderr_stackid [shellfilter::stack::add stderr tee_to_var -action float -settings {-varname ::shellrun::runerr}] |
||||
set stdout_stackid [shellfilter::stack::add stdout tee_to_var -action float -settings {-varname ::shellrun::runout}] |
||||
} else { |
||||
#set stderr_stackid [shellfilter::stack::add stderr var -action sink-locked -settings {-varname ::shellrun::runerr}] |
||||
#set stdout_stackid [shellfilter::stack::add stdout var -action sink-locked -settings {-varname ::shellrun::runout}] |
||||
|
||||
#float above the repl's tee_to_var to deliberately block it. |
||||
#a var transform is naturally a junction point because there is no flow-through.. |
||||
# - but mark it with -junction 1 just to be explicit |
||||
set stderr_stackid [shellfilter::stack::add stderr var -action float-locked -junction 1 -settings {-varname ::shellrun::runerr}] |
||||
set stdout_stackid [shellfilter::stack::add stdout var -action float-locked -junction 1 -settings {-varname ::shellrun::runout}] |
||||
} |
||||
|
||||
set callopts "" |
||||
if {"-tcl" in $runopts} { |
||||
append callopts " -tclscript 1" |
||||
} |
||||
#set exitinfo [shellfilter::run $cmdargs -teehandle punksh -inbuffering none -outbuffering none -stdinhandler ::repl::repl_handler] |
||||
set exitinfo [shellfilter::run $cmdargs {*}$callopts -teehandle punksh -inbuffering none -outbuffering none] |
||||
|
||||
shellfilter::stack::remove stdout $stdout_stackid |
||||
shellfilter::stack::remove stderr $stderr_stackid |
||||
|
||||
|
||||
flush stderr |
||||
flush stdout |
||||
|
||||
if {[dict exists $exitinfo error]} { |
||||
if {"-tcl" in $runopts} { |
||||
|
||||
} else { |
||||
#todo - check errorInfo makes sense.. return -code? tailcall? |
||||
error [dict get $exitinfo error] |
||||
} |
||||
} |
||||
|
||||
#set x [shellfilter::stack::add stdout var -action sink-locked -settings {-varname ::repl::runxoutput}] |
||||
|
||||
set chunk "" |
||||
if {[string length $::shellrun::runout]} { |
||||
if {$nonewline} { |
||||
set o [string trimright $::shellrun::runout \r\n] |
||||
} else { |
||||
set o $::shellrun::runout |
||||
} |
||||
set chunk $o |
||||
} |
||||
set chunklist [list] |
||||
lappend chunklist [list "info" " "] |
||||
lappend chunklist [list "result" stdout] ;#key 'stdout' forms part of the resulting dictionary output |
||||
lappend chunklist [list "info" "[a+ white bold]stdout[a]"] |
||||
lappend chunklist [list result $chunk] ;#value corresponding to 'stdout' key in resulting dict |
||||
|
||||
|
||||
lappend chunklist [list "info" " "] |
||||
set chunk "[a+ red bold]stderr[a]" |
||||
lappend chunklist [list "result" $chunk] |
||||
lappend chunklist [list "info" stderr] |
||||
|
||||
set chunk "" |
||||
if {[string length $::shellrun::runerr]} { |
||||
if {$nonewline} { |
||||
set e [string trimright $::shellrun::runerr \r\n] |
||||
} else { |
||||
set e $::shellrun::runerr |
||||
} |
||||
set chunk $e |
||||
} |
||||
#stderr is part of the result |
||||
lappend chunklist [list "resulterr" $chunk] |
||||
|
||||
|
||||
|
||||
set n [a] |
||||
set c "" |
||||
if {[dict exists $exitinfo exitcode]} { |
||||
set code [dict get $exitinfo exitcode] |
||||
if {$code == 0} { |
||||
set c [a+ green] |
||||
} else { |
||||
set c [a+ yellow bold] |
||||
} |
||||
lappend chunklist [list "info" " "] |
||||
lappend chunklist [list "result" exitcode] |
||||
lappend chunklist [list "info" "exitcode $code"] |
||||
lappend chunklist [list "result" "$c$code$n"] |
||||
set exitdict [list exitcode $code] |
||||
} elseif {[dict exists $exitinfo result]} { |
||||
# presumably from a -tcl call |
||||
set val [dict get $exitinfo result] |
||||
lappend chunklist [list "info" " "] |
||||
lappend chunklist [list "result" result] |
||||
lappend chunklist [list "info" result] |
||||
lappend chunklist [list "result" $val] |
||||
set exitdict [list result $val] |
||||
} elseif {[dict exists $exitinfo error]} { |
||||
# -tcl call with error |
||||
#set exitdict [dict create] |
||||
lappend chunklist [list "info" " "] |
||||
lappend chunklist [list "result" error] |
||||
lappend chunklist [list "info" error] |
||||
lappend chunklist [list "result" [dict get $exitinfo error]] |
||||
|
||||
lappend chunklist [list "info" " "] |
||||
lappend chunklist [list "result" errorCode] |
||||
lappend chunklist [list "info" errorCode] |
||||
lappend chunklist [list "result" [dict get $exitinfo errorCode]] |
||||
|
||||
lappend chunklist [list "info" " "] |
||||
lappend chunklist [list "result" errorInfo] |
||||
lappend chunklist [list "info" errorInfo] |
||||
lappend chunklist [list "result" [dict get $exitinfo errorInfo]] |
||||
|
||||
set exitdict $exitinfo |
||||
} else { |
||||
#review - if no exitcode or result. then what is it? |
||||
lappend chunklist [list "info" exitinfo] |
||||
set c [a+ yellow bold] |
||||
lappend chunklist [list result "$c$exitinfo$n"] |
||||
set exitdict [list exitinfo $exitinfo] |
||||
} |
||||
|
||||
#set_last_run_display $chunklist |
||||
tsv::lappend repl runchunks-[tsv::get repl runid] {*}$chunklist |
||||
|
||||
#set ::repl::result_print 0 |
||||
#return [lindex [list [list stdout $::runout stderr $::runerr {*}$exitinfo] [shellfilter::stack::remove stdout $x][puts -nonewline stdout $pretty][set ::repl::output ""]] 0] |
||||
|
||||
|
||||
if {$nonewline} { |
||||
return [list {*}$exitdict stdout [string trimright $::shellrun::runout \r\n] stderr [string trimright $::shellrun::runerr \r\n]] |
||||
} |
||||
#always return exitinfo $code at beginning of dict (so that punk unknown can interpret the exit code as a unix-style bool if double evaluated) |
||||
return [list {*}$exitdict stdout $::shellrun::runout stderr $::shellrun::runerr] |
||||
} |
||||
|
||||
#an experiment |
||||
# |
||||
#run as raw string instead of tcl-list - no variable subst etc |
||||
# |
||||
#dummy repl_runraw that repl will intercept |
||||
proc repl_runraw {args} { |
||||
error "runraw: only available in repl as direct call - not from script" |
||||
} |
||||
#we can only call runraw with a single (presumably braced) string if we want to use it from both repl and tcl scripts (why? todo with unbalanced quotes/braces?) |
||||
proc runraw {commandline} { |
||||
#runraw fails as intended - because we can't bypass exec/open interference quoting :/ |
||||
#set_last_run_display [list] |
||||
variable runout |
||||
variable runerr |
||||
set runout "" |
||||
set runerr "" |
||||
|
||||
#return [shellfilter::run [lrange $args 1 end] -teehandle punksh -inbuffering none -outbuffering none -stdinhandler ::repl::repl_handler] |
||||
puts stdout ">>runraw got: $commandline" |
||||
|
||||
#run always echoes anyway.. as we aren't diverting stdout/stderr off for capturing |
||||
#for consistency with other runxxx commands - we'll just consume it. (review) |
||||
|
||||
set reallyraw 1 |
||||
if {$reallyraw} { |
||||
set wordparts [regexp -inline -all {\S+} $commandline] |
||||
set runwords $wordparts |
||||
} else { |
||||
#shell style args parsing not suitable for windows where we can't assume matched quotes etc. |
||||
package require string::token::shell |
||||
set parts [string token shell -indices -- $commandline] |
||||
puts stdout ">>shellparts: $parts" |
||||
set runwords [list] |
||||
foreach p $parts { |
||||
set ptype [lindex $p 0] |
||||
set pval [lindex $p 3] |
||||
if {$ptype eq "PLAIN"} { |
||||
lappend runwords [lindex $p 3] |
||||
} elseif {$ptype eq "D:QUOTED"} { |
||||
set v {"} |
||||
append v $pval |
||||
append v {"} |
||||
lappend runwords $v |
||||
} elseif {$ptype eq "S:QUOTED"} { |
||||
set v {'} |
||||
append v $pval |
||||
append v {'} |
||||
lappend runwords $v |
||||
} |
||||
} |
||||
} |
||||
|
||||
puts stdout ">>runraw runwords: $runwords" |
||||
set runwords [lrange $runwords 1 end] |
||||
|
||||
puts stdout ">>runraw runwords: $runwords" |
||||
#set args [lrange $args 1 end] |
||||
#set runwords [lrange $wordparts 1 end] |
||||
|
||||
set known_runopts [list "-echo" "-e" "-terminal" "-t"] |
||||
set aliases [list "-e" "-echo" "-echo" "-echo" "-t" "-terminal" "-terminal" "-terminal"] ;#include map to self |
||||
set runopts [list] |
||||
set cmdwords [list] |
||||
set idx_first_cmdarg [lsearch -not $runwords "-*"] |
||||
set runopts [lrange $runwords 0 $idx_first_cmdarg-1] |
||||
set cmdwords [lrange $runwords $idx_first_cmdarg end] |
||||
|
||||
foreach o $runopts { |
||||
if {$o ni $known_runopts} { |
||||
error "runraw: Unknown runoption $o" |
||||
} |
||||
} |
||||
set runopts [lmap o $runopts {dict get $aliases $o}] |
||||
|
||||
set cmd_as_string [join $cmdwords " "] |
||||
puts stdout ">>cmd_as_string: $cmd_as_string" |
||||
|
||||
if {"-terminal" in $runopts} { |
||||
#fake terminal using 'script' command. |
||||
#not ideal: smushes stdout & stderr together amongst other problems |
||||
set tcmd [shellfilter::get_scriptrun_from_cmdlist_dquote_if_not $cmdwords] |
||||
puts stdout ">>tcmd: $tcmd" |
||||
set exitinfo [shellfilter::run $tcmd -teehandle punksh -inbuffering line -outbuffering none ] |
||||
set exitinfo "exitcode not-implemented" |
||||
} else { |
||||
set exitinfo [shellfilter::run $cmdwords -teehandle punksh -inbuffering line -outbuffering none ] |
||||
} |
||||
|
||||
if {[dict exists $exitinfo error]} { |
||||
#todo - check errorInfo makes sense.. return -code? tailcall? |
||||
error [dict get $exitinfo error] |
||||
} |
||||
set code [dict get $exitinfo exitcode] |
||||
if {$code == 0} { |
||||
set c [a+ green] |
||||
} else { |
||||
set c [a+ white bold] |
||||
} |
||||
puts stderr $c |
||||
return $exitinfo |
||||
} |
||||
|
||||
proc sh_run {args} { |
||||
set splitargs [get_run_opts $args] |
||||
set runopts [dict get $splitargs runopts] |
||||
set cmdargs [dict get $splitargs cmdargs] |
||||
#e.g sh -c "ls -l *" |
||||
#we pass cmdargs to sh -c as a list, not individually |
||||
tailcall shellrun::run {*}$runopts sh -c $cmdargs |
||||
} |
||||
proc sh_runout {args} { |
||||
set splitargs [get_run_opts $args] |
||||
set runopts [dict get $splitargs runopts] |
||||
set cmdargs [dict get $splitargs cmdargs] |
||||
tailcall shellrun::runout {*}$runopts sh -c $cmdargs |
||||
} |
||||
proc sh_runerr {args} { |
||||
set splitargs [get_run_opts $args] |
||||
set runopts [dict get $splitargs runopts] |
||||
set cmdargs [dict get $splitargs cmdargs] |
||||
tailcall shellrun::runerr {*}$runopts sh -c $cmdargs |
||||
} |
||||
proc sh_runx {args} { |
||||
set splitargs [get_run_opts $args] |
||||
set runopts [dict get $splitargs runopts] |
||||
set cmdargs [dict get $splitargs cmdargs] |
||||
tailcall shellrun::runx {*}$runopts sh -c $cmdargs |
||||
} |
||||
} |
||||
|
||||
namespace eval shellrun { |
||||
interp alias {} run {} shellrun::run |
||||
interp alias {} sh_run {} shellrun::sh_run |
||||
interp alias {} runout {} shellrun::runout |
||||
interp alias {} sh_runout {} shellrun::sh_runout |
||||
interp alias {} runerr {} shellrun::runerr |
||||
interp alias {} sh_runerr {} shellrun::sh_runerr |
||||
interp alias {} runx {} shellrun::runx |
||||
interp alias {} sh_runx {} shellrun::sh_runx |
||||
|
||||
interp alias {} runc {} shellrun::runconsole |
||||
interp alias {} runraw {} shellrun::runraw |
||||
|
||||
|
||||
#the shortened versions deliberately don't get pretty output from the repl |
||||
interp alias {} r {} shellrun::run |
||||
interp alias {} ro {} shellrun::runout |
||||
interp alias {} re {} shellrun::runerr |
||||
interp alias {} rx {} shellrun::runx |
||||
|
||||
|
||||
} |
||||
|
||||
namespace eval shellrun { |
||||
proc test_cffi {} { |
||||
package require test_cffi |
||||
cffi::Wrapper create ::shellrun::kernel32 [file join $env(windir) system32 Kernel32.dll] |
||||
::shellrun::kernel32 stdcall CreateProcessA |
||||
#todo - stuff. |
||||
return ::shellrun::kernel32 |
||||
} |
||||
|
||||
} |
||||
namespace eval ::punk::args::register { |
||||
#use fully qualified so 8.6 doesn't find existing var in global namespace |
||||
lappend ::punk::args::register::NAMESPACES ::shellrun |
||||
} |
||||
|
||||
|
||||
package provide shellrun [namespace eval shellrun { |
||||
variable version |
||||
set version 0.1.1 |
||||
}] |
||||
@ -0,0 +1,826 @@
|
||||
#package require logger |
||||
|
||||
|
||||
package require Thread |
||||
|
||||
namespace eval shellthread { |
||||
|
||||
proc iso8601 {{tsmicros ""}} { |
||||
if {$tsmicros eq ""} { |
||||
set tsmicros [tcl::clock::microseconds] |
||||
} else { |
||||
set microsnow [tcl::clock::microseconds] |
||||
if {[tcl::string::length $tsmicros] != [tcl::string::length $microsnow]} { |
||||
error "iso8601 requires 'clock micros' or empty string to create timestamp" |
||||
} |
||||
} |
||||
set seconds [expr {$tsmicros / 1000000}] |
||||
return [tcl::clock::format $seconds -format "%Y-%m-%d_%H-%M-%S"] |
||||
} |
||||
} |
||||
|
||||
namespace eval shellthread::worker { |
||||
variable settings |
||||
variable sysloghost_port |
||||
variable sock |
||||
variable logfile "" |
||||
variable fd |
||||
variable client_ids [list] |
||||
variable ts_start_micros |
||||
variable errorlist [list] |
||||
variable inpipe "" |
||||
|
||||
proc bgerror {args} { |
||||
variable errorlist |
||||
lappend errorlist $args |
||||
} |
||||
proc send_errors_now {tidcli} { |
||||
variable errorlist |
||||
thread::send -async $tidcli [list shellthread::manager::report_worker_errors [list worker_tid [thread::id] errors $errorlist]] |
||||
} |
||||
proc add_client_tid {tidcli} { |
||||
variable client_ids |
||||
if {$tidcli ni $client_ids} { |
||||
lappend client_ids $tidcli |
||||
} |
||||
} |
||||
proc init {tidclient start_m settingsdict} { |
||||
variable sysloghost_port |
||||
variable logfile |
||||
variable settings |
||||
interp bgerror {} shellthread::worker::bgerror |
||||
#package require overtype ;#overtype uses tcllib textutil, punk::char etc - currently too heavyweight in terms of loading time for use in threads. |
||||
variable client_ids |
||||
variable ts_start_micros |
||||
lappend client_ids $tidclient |
||||
set ts_start_micros $start_m |
||||
|
||||
set defaults [list -raw 0 -file "" -syslog "" -direction out] |
||||
set settings [dict merge $defaults $settingsdict] |
||||
|
||||
set syslog [dict get $settings -syslog] |
||||
if {[string length $syslog]} { |
||||
lassign [split $syslog :] s_host s_port |
||||
set sysloghost_port [list $s_host $s_port] |
||||
if {[catch {package require udp} errm]} { |
||||
#disable rather than bomb and interfere with any -file being written |
||||
#review - log/notify? |
||||
set sysloghost_port "" |
||||
} |
||||
} else { |
||||
set sysloghost_port "" |
||||
} |
||||
|
||||
set logfile [dict get $settings -file] |
||||
} |
||||
|
||||
proc start_pipe_read {source readchan args} { |
||||
#assume 1 inpipe for now |
||||
variable inpipe |
||||
variable sysloghost_port |
||||
variable logfile |
||||
|
||||
set defaults [dict create -buffering \uFFFF ] |
||||
set opts [dict merge $defaults $args] |
||||
if {[dict exists $opts -readbuffering]} { |
||||
set readbuffering [dict get $opts -readbuffering] |
||||
} else { |
||||
if {[dict get $opts -buffering] eq "\uFFFF"} { |
||||
#get buffering setting from the channel as it was set prior to thread::transfer |
||||
set readbuffering [chan configure $readchan -buffering] |
||||
} else { |
||||
set readbuffering [dict get $opts -buffering] |
||||
chan configure $readchan -buffering $readbuffering |
||||
} |
||||
} |
||||
if {[dict exists $opts -writebuffering]} { |
||||
set writebuffering [dict get $opts -writebuffering] |
||||
} else { |
||||
if {[dict get $opts -buffering] eq "\uFFFF"} { |
||||
set writebuffering line |
||||
#set writebuffering [chan configure $writechan -buffering] |
||||
} else { |
||||
set writebuffering [dict get $opts -buffering] |
||||
#can configure $writechan -buffering $writebuffering |
||||
} |
||||
} |
||||
|
||||
chan configure $readchan -translation lf |
||||
|
||||
if {$readchan ni [chan names]} { |
||||
error "shellthread::worker::start_pipe_read - inpipe not configured. Use shellthread::manager::set_pipe_read_from_client to thread::transfer the pipe end" |
||||
} |
||||
set inpipe $readchan |
||||
chan configure $readchan -blocking 0 |
||||
set waitvar ::shellthread::worker::wait($inpipe,[clock micros]) |
||||
|
||||
#tcl::chan::fifo2 based pipe seems slower to establish events upon than Memchan |
||||
chan event $readchan readable [list ::shellthread::worker::pipe_read $readchan $source $waitvar $readbuffering $writebuffering] |
||||
vwait $waitvar |
||||
} |
||||
proc pipe_read {chan source waitfor readbuffering writebuffering} { |
||||
if {$readbuffering eq "line"} { |
||||
set chunksize [chan gets $chan chunk] |
||||
if {$chunksize >= 0} { |
||||
if {![chan eof $chan]} { |
||||
::shellthread::worker::log pipe 0 - $source - info $chunk\n $writebuffering |
||||
} else { |
||||
::shellthread::worker::log pipe 0 - $source - info $chunk $writebuffering |
||||
} |
||||
} |
||||
} else { |
||||
set chunk [chan read $chan] |
||||
::shellthread::worker::log pipe 0 - $source - info $chunk $writebuffering |
||||
} |
||||
if {[chan eof $chan]} { |
||||
chan event $chan readable {} |
||||
set $waitfor "pipe" |
||||
chan close $chan |
||||
} |
||||
} |
||||
|
||||
proc start_pipe_write {source writechan args} { |
||||
variable outpipe |
||||
set defaults [dict create -buffering \uFFFF ] |
||||
set opts [dict merge $defaults $args] |
||||
|
||||
#todo! |
||||
set readchan stdin |
||||
|
||||
if {[dict exists $opts -readbuffering]} { |
||||
set readbuffering [dict get $opts -readbuffering] |
||||
} else { |
||||
if {[dict get $opts -buffering] eq "\uFFFF"} { |
||||
set readbuffering [chan configure $readchan -buffering] |
||||
} else { |
||||
set readbuffering [dict get $opts -buffering] |
||||
chan configure $readchan -buffering $readbuffering |
||||
} |
||||
} |
||||
if {[dict exists $opts -writebuffering]} { |
||||
set writebuffering [dict get $opts -writebuffering] |
||||
} else { |
||||
if {[dict get $opts -buffering] eq "\uFFFF"} { |
||||
#nothing explicitly set - take from transferred channel |
||||
set writebuffering [chan configure $writechan -buffering] |
||||
} else { |
||||
set writebuffering [dict get $opts -buffering] |
||||
can configure $writechan -buffering $writebuffering |
||||
} |
||||
} |
||||
|
||||
if {$writechan ni [chan names]} { |
||||
error "shellthread::worker::start_pipe_write - outpipe not configured. Use shellthread::manager::set_pipe_write_to_client to thread::transfer the pipe end" |
||||
} |
||||
set outpipe $writechan |
||||
chan configure $readchan -blocking 0 |
||||
chan configure $writechan -blocking 0 |
||||
set waitvar ::shellthread::worker::wait($outpipe,[clock micros]) |
||||
|
||||
chan event $readchan readable [list apply {{chan writechan source waitfor readbuffering} { |
||||
if {$readbuffering eq "line"} { |
||||
set chunksize [chan gets $chan chunk] |
||||
if {$chunksize >= 0} { |
||||
if {![chan eof $chan]} { |
||||
puts $writechan $chunk |
||||
} else { |
||||
puts -nonewline $writechan $chunk |
||||
} |
||||
} |
||||
} else { |
||||
set chunk [chan read $chan] |
||||
puts -nonewline $writechan $chunk |
||||
} |
||||
if {[chan eof $chan]} { |
||||
chan event $chan readable {} |
||||
set $waitfor "pipe" |
||||
chan close $writechan |
||||
if {$chan ne "stdin"} { |
||||
chan close $chan |
||||
} |
||||
} |
||||
}} $readchan $writechan $source $waitvar $readbuffering] |
||||
|
||||
vwait $waitvar |
||||
} |
||||
|
||||
|
||||
proc _initsock {} { |
||||
variable sysloghost_port |
||||
variable sock |
||||
if {[string length $sysloghost_port]} { |
||||
if {[catch {chan configure $sock} state]} { |
||||
set sock [udp_open] |
||||
chan configure $sock -buffering none -translation binary |
||||
chan configure $sock -remote $sysloghost_port |
||||
} |
||||
} |
||||
} |
||||
proc _reconnect {} { |
||||
variable sock |
||||
catch {close $sock} |
||||
_initsock |
||||
return [chan configure $sock] |
||||
} |
||||
|
||||
proc send_info {client_tid ts_sent source msg} { |
||||
set ts_received [clock micros] |
||||
set lag_micros [expr {$ts_received - $ts_sent}] |
||||
set lag [expr {$lag_micros / 1000000.0}] ;#lag as x.xxxxxx seconds |
||||
log $client_tid $ts_sent $lag $source - info $msg line 1 |
||||
} |
||||
proc log {client_tid ts_sent lag source service level msg writebuffering {islog 0}} { |
||||
variable sock |
||||
variable fd |
||||
variable sysloghost_port |
||||
variable logfile |
||||
variable settings |
||||
|
||||
set logchunk $msg |
||||
|
||||
if {![dict get $settings -raw]} { |
||||
set tail_crlf 0 |
||||
set tail_lf 0 |
||||
set tail_cr 0 |
||||
#for cooked - always remove the trailing newline before splitting.. |
||||
# |
||||
#note that if we got our data from reading a non-line-buffered binary channel - then this naive line splitting will not split neatly for mixed line-endings. |
||||
# |
||||
#Possibly not critical as cooked is for logging and we are still preserving all \r and \n chars - but review and consider implementing a better split |
||||
#but add it back exactly as it was afterwards |
||||
#we can always split on \n - and any adjacent \r will be preserved in the rejoin |
||||
set lastchar [string range $logchunk end end] |
||||
if {[string range $logchunk end-1 end] eq "\r\n"} { |
||||
set tail_crlf 1 |
||||
set logchunk [string range $logchunk 0 end-2] |
||||
} else { |
||||
if {$lastchar eq "\n"} { |
||||
set tail_lf 1 |
||||
set logchunk [string range $logchunk 0 end-1] |
||||
} elseif {$lastchar eq "\r"} { |
||||
#\r line-endings are obsolete..and unlikely... and ugly as they can hide characters on the console. but we'll pass through anyway. |
||||
set tail_cr 1 |
||||
set logchunk [string range $logchunk 0 end-1] |
||||
} else { |
||||
#possibly a single line with no linefeed.. or has linefeeds only in the middle |
||||
} |
||||
} |
||||
|
||||
if {$ts_sent != 0} { |
||||
set micros [lindex [split [expr {$ts_sent / 1000000.0}] .] end] |
||||
set time_info [::shellthread::iso8601 $ts_sent].$micros |
||||
#set time_info "${time_info}+$lag" |
||||
set lagfp "+[format %f $lag]" |
||||
} else { |
||||
#from pipe - no ts_sent/lag info available |
||||
set time_info "" |
||||
set lagfp "" |
||||
} |
||||
|
||||
set idtail [string range $client_tid end-8 end] ;#enough for display purposes id - mostly zeros anyway |
||||
|
||||
|
||||
#set col0 [string repeat " " 9] |
||||
#set col1 [string repeat " " 27] |
||||
#set col2 [string repeat " " 11] |
||||
#set col3 [string repeat " " 22] |
||||
##do not columnize the final data column or append to tail - or we could muck up the crlf integrity |
||||
#lassign [list [overtype::left $col0 $idtail] [overtype::left $col1 $time_info] [overtype::left $col2 $lagfp] [overtype::left $col3 $source]] c0 c1 c2 c3 |
||||
|
||||
set w0 9 |
||||
set w1 27 |
||||
set w2 11 |
||||
set w3 22 ;#review - this can truncate source name without indication tail is missing |
||||
#do not columnize the final data column or append to tail - or we could muck up the crlf integrity |
||||
lassign [list \ |
||||
[format %-${w0}s $idtail]\ |
||||
[format %-${w1}s $time_info]\ |
||||
[format %-${w2}s $lagfp]\ |
||||
[format %-${w3}s $source]\ |
||||
] c0 c1 c2 c3 |
||||
set c2_blank [string repeat " " $w2] |
||||
|
||||
|
||||
#split on \n no matter the actual line-ending in use |
||||
#shouldn't matter as long as we don't add anything at the end of the line other than the raw data |
||||
#ie - don't quote or add spaces |
||||
set lines [split $logchunk \n] |
||||
|
||||
set i 1 |
||||
set outlines [list] |
||||
foreach ln $lines { |
||||
if {$i == 1} { |
||||
lappend outlines "$c0 $c1 $c2 $c3 $ln" |
||||
} else { |
||||
lappend outlines "$c0 $c1 $c2_blank $c3 $ln" |
||||
} |
||||
incr i |
||||
} |
||||
if {$tail_lf} { |
||||
set logchunk "[join $outlines \n]\n" |
||||
} elseif {$tail_crlf} { |
||||
set logchunk "[join $outlines \r\n]\r\n" |
||||
} elseif {$tail_cr} { |
||||
set logchunk "[join $outlines \r]\r" |
||||
} else { |
||||
#no trailing linefeed |
||||
set logchunk [join $outlines \n] |
||||
|
||||
} |
||||
|
||||
#set logchunk "[overtype::left $col0 $idtail] [overtype::left $col1 $time_info] [overtype::left $col2 "+$lagfp"] [overtype::left $col3 $source] $msg" |
||||
} |
||||
|
||||
if {[string length $sysloghost_port]} { |
||||
_initsock |
||||
catch {puts -nonewline $sock $logchunk} |
||||
} |
||||
#todo - sockets etc? |
||||
if {[string length $logfile]} { |
||||
#todo - setting to maintain open filehandle and reduce io. |
||||
# possible settings for buffersize - and maybe logrotation, although this could be left to client |
||||
#for now - default to safe option of open/close each write despite the overhead. |
||||
set fd [open $logfile a] |
||||
chan configure $fd -translation auto -buffering $writebuffering |
||||
#whether line buffered or not - by now our logchunk includes newlines |
||||
puts -nonewline $fd $logchunk |
||||
close $fd |
||||
} |
||||
} |
||||
|
||||
# - withdraw just this client |
||||
proc finish {tidclient} { |
||||
variable client_ids |
||||
if {($tidclient in $clientids) && ([llength $clientids] == 1)} { |
||||
terminate $tidclient |
||||
} else { |
||||
set posn [lsearch $client_ids $tidclient] |
||||
set client_ids [lreplace $clientids $posn $posn] |
||||
} |
||||
} |
||||
|
||||
#allow any client to terminate |
||||
proc terminate {tidclient} { |
||||
variable sock |
||||
variable fd |
||||
variable client_ids |
||||
if {$tidclient in $client_ids} { |
||||
catch {close $sock} |
||||
catch {close $fd} |
||||
set client_ids [list] |
||||
#review use of thread::release -wait |
||||
#docs indicate deprecated for regular use, and that we should use thread::join |
||||
#however.. how can we set a timeout on a thread::join ? |
||||
#by telling the thread to release itself - we can wait on the thread::send variable |
||||
# This needs review - because it's unclear that -wait even works on self |
||||
# (what does it mean to wait for the target thread to exit if the target is self??) |
||||
thread::release -wait |
||||
return [thread::id] |
||||
} else { |
||||
return "" |
||||
} |
||||
} |
||||
|
||||
|
||||
} |
||||
|
||||
|
||||
namespace eval shellthread::manager { |
||||
variable workers [dict create] |
||||
variable worker_errors [list] |
||||
variable timeouts |
||||
|
||||
variable free_threads [list] |
||||
#variable log_threads |
||||
|
||||
proc dict_getdef {dictValue args} { |
||||
if {[llength $args] < 2} { |
||||
error {wrong # args: should be "dict_getdef dictValue ?key ...? key default"} |
||||
} |
||||
set keys [lrange $args 0 end-1] |
||||
if {[tcl::dict::exists $dictValue {*}$keys]} { |
||||
return [tcl::dict::get $dictValue {*}$keys] |
||||
} else { |
||||
return [lindex $args end] |
||||
} |
||||
} |
||||
#new datastructure regarding workers and sourcetags required. |
||||
#one worker can service multiple sourcetags - but each sourcetag may be used by multiple threads too. |
||||
#generally each thread will use a specific sourcetag - but we may have pools doing similar things which log to same destination. |
||||
# |
||||
#As a convention we may use a sourcetag for the thread which started the worker that isn't actually used for logging - but as a common target for joins |
||||
#If the thread which started the thread calls leave_worker with that 'primary' sourcetag it means others won't be able to use that target - which seems reasonable. |
||||
#If another thread want's to maintain joinability beyond the span provided by the starting client, |
||||
#it can join with both the primary tag and a tag it will actually use for logging. |
||||
#A thread can join the logger with any existingtag - not just the 'primary' |
||||
#(which is arbitrary anyway. It will usually be the first in the list - but may be unsubscribed by clients and disappear) |
||||
proc join_worker {existingtag sourcetaglist} { |
||||
set client_tid [thread::id] |
||||
#todo - allow a source to piggyback on existing worker by referencing one of the sourcetags already using the worker |
||||
} |
||||
|
||||
proc new_pipe_worker {sourcetaglist {settingsdict {}}} { |
||||
if {[dict exists $settingsdict -workertype]} { |
||||
if {[string tolower [dict get $settingsdict -workertype]] ne "pipe"} { |
||||
error "new_pipe_worker error: -workertype ne 'pipe'. Set to 'pipe' or leave empty" |
||||
} |
||||
} |
||||
dict set settingsdict -workertype pipe |
||||
new_worker $sourcetaglist $settingsdict |
||||
} |
||||
|
||||
#it is up to caller to use a unique sourcetag (e.g by prefixing with own thread::id etc) |
||||
# This allows multiple threads to more easily write to the same named sourcetag if necessary |
||||
# todo - change sourcetag for a list of tags which will be handled by the same thread. e.g for multiple threads logging to same file |
||||
# |
||||
# todo - some protection mechanism for case where target is a file to stop creation of multiple worker threads writing to same file. |
||||
# Even if we use open fd,close fd wrapped around writes.. it is probably undesirable to have multiple threads with same target |
||||
# On the other hand socket targets such as UDP can happily be written to by multiple threads. |
||||
# For now the mechanism is that a call to new_worker (rename to open_worker?) will join the same thread if a sourcetag matches. |
||||
# but, as sourcetags can get removed(unsubbed via leave_worker) this doesn't guarantee two threads with same -file settings won't fight. |
||||
# Also.. the settingsdict is ignored when joining with a tag that exists.. this is problematic.. e.g logrotation where previous file still being written by existing worker |
||||
# todo - rename 'sourcetag' concept to 'targettag' ?? the concept is a mixture of both.. it is somewhat analagous to a syslog 'facility' |
||||
# probably new_worker should disallow auto-joining and we allow different workers to handle same tags simultaneously to support overlap during logrotation etc. |
||||
proc new_worker {sourcetaglist {settingsdict {}}} { |
||||
variable workers |
||||
set ts_start [clock micros] |
||||
set tidclient [thread::id] |
||||
set sourcetag [lindex $sourcetaglist 0] ;#todo - use all |
||||
|
||||
set defaults [dict create\ |
||||
-workertype message\ |
||||
] |
||||
set settingsdict [dict merge $defaults $settingsdict] |
||||
|
||||
set workertype [string tolower [dict get $settingsdict -workertype]] |
||||
set known_workertypes [list pipe message] |
||||
if {$workertype ni $known_workertypes} { |
||||
error "new_worker - unknown -workertype $workertype. Expected one of '$known_workertypes'" |
||||
} |
||||
|
||||
if {[dict exists $workers $sourcetag]} { |
||||
set winfo [dict get $workers $sourcetag] |
||||
if {[dict get $winfo tid] ne "noop" && [thread::exists [dict get $winfo tid]]} { |
||||
#add our client-info to existing worker thread |
||||
dict lappend winfo list_client_tids $tidclient |
||||
dict set workers $sourcetag $winfo ;#writeback |
||||
return [dict get $winfo tid] |
||||
} |
||||
} |
||||
|
||||
#noop fake worker for empty syslog and empty file |
||||
if {$workertype eq "message"} { |
||||
if {[dict_getdef $settingsdict -syslog ""] eq "" && [dict_getdef $settingsdict -file ""] eq ""} { |
||||
set winfo [dict create tid noop list_client_tids [list $tidclient] ts_start $ts_start ts_end_list [list] workertype "message"] |
||||
dict set workers $sourcetag $winfo |
||||
return noop |
||||
} |
||||
} |
||||
|
||||
#check if there is an existing unsubscribed thread first |
||||
#don't use free_threads for pipe workertype for now.. |
||||
variable free_threads |
||||
if {$workertype ne "pipe"} { |
||||
if {[llength $free_threads]} { |
||||
#todo - re-use from tail - as most likely to have been doing similar work?? review |
||||
|
||||
set free_threads [lassign $free_threads tidworker] |
||||
#todo - keep track of real ts_start of free threads... kill when too old |
||||
set winfo [dict create tid $tidworker list_client_tids [list $tidclient] ts_start $ts_start ts_end_list [list] workertype [dict get $settingsdict -workertype]] |
||||
#puts stderr "shellfilter::new_worker Re-using free worker thread: $tidworker with tag $sourcetag" |
||||
dict set workers $sourcetag $winfo |
||||
return $tidworker |
||||
} |
||||
} |
||||
|
||||
|
||||
#set ts_start [::shellthread::iso8601] |
||||
set tidworker [thread::create -preserved] |
||||
set init_script [string map [list %ts_start% $ts_start %mp% [tcl::tm::list] %ap% $::auto_path %tidcli% $tidclient %sd% $settingsdict] { |
||||
#set tclbase [file dirname [file dirname [info nameofexecutable]]] |
||||
#set tcllib $tclbase/lib |
||||
#if {$tcllib ni $::auto_path} { |
||||
# lappend ::auto_path $tcllib |
||||
#} |
||||
|
||||
set ::settingsinfo [dict create %sd%] |
||||
#if the executable running things is something like a tclkit, |
||||
# then it's likely we will need to use the caller's auto_path and tcl::tm::list to find things |
||||
#The caller can tune the thread's package search by providing a settingsdict |
||||
#tcl::tm::add * must add in reverse order to get reulting list in same order as original |
||||
if {![dict exists $::settingsinfo tcl_tm_list]} { |
||||
#JMN2 |
||||
::tcl::tm::add {*}[lreverse [list %mp%]] |
||||
} else { |
||||
tcl::tm::remove {*}[tcl::tm::list] |
||||
::tcl::tm::add {*}[lreverse [dict get $::settingsinfo tcl_tm_list]] |
||||
} |
||||
if {![dict exists $::settingsinfo auto_path]} { |
||||
set ::auto_path [list %ap%] |
||||
} else { |
||||
set ::auto_path [dict get $::settingsinfo auto_path] |
||||
} |
||||
|
||||
package require punk::packagepreference |
||||
punk::packagepreference::install |
||||
|
||||
package require Thread |
||||
package require shellthread |
||||
if {![catch {::shellthread::worker::init %tidcli% %ts_start% $::settingsinfo} errmsg]} { |
||||
unset ::settingsinfo |
||||
set ::shellthread_init "ok" |
||||
} else { |
||||
unset ::settingsinfo |
||||
set ::shellthread_init "err $errmsg" |
||||
} |
||||
}] |
||||
|
||||
thread::send -async $tidworker $init_script |
||||
#thread::send $tidworker $init_script |
||||
set winfo [dict create tid $tidworker list_client_tids [list $tidclient] ts_start $ts_start ts_end_list [list]] |
||||
dict set workers $sourcetag $winfo |
||||
return $tidworker |
||||
} |
||||
|
||||
proc set_pipe_read_from_client {tag_pipename worker_tid rchan args} { |
||||
variable workers |
||||
if {![dict exists $workers $tag_pipename]} { |
||||
error "workerthread::manager::set_pipe_read_from_client source/pipename $tag_pipename not found" |
||||
} |
||||
set match_worker_tid [dict get $workers $tag_pipename tid] |
||||
if {$worker_tid ne $match_worker_tid} { |
||||
error "workerthread::manager::set_pipe_read_from_client source/pipename $tag_pipename workert_tid mismatch '$worker_tid' vs existing:'$match_worker_tid'" |
||||
} |
||||
#buffering set during channel creation will be preserved on thread::transfer |
||||
thread::transfer $worker_tid $rchan |
||||
#start_pipe_read will vwait - so we have to send async |
||||
thread::send -async $worker_tid [list ::shellthread::worker::start_pipe_read $tag_pipename $rchan] |
||||
#client may start writing immediately - but presumably it will buffer in fifo2 |
||||
} |
||||
|
||||
proc set_pipe_write_to_client {tag_pipename worker_tid wchan args} { |
||||
variable workers |
||||
if {![dict exists $workers $tag_pipename]} { |
||||
error "workerthread::manager::set_pipe_write_to_client pipename $tag_pipename not found" |
||||
} |
||||
set match_worker_tid [dict get $workers $tag_pipename tid] |
||||
if {$worker_tid ne $match_worker_tid} { |
||||
error "workerthread::manager::set_pipe_write_to_client pipename $tag_pipename workert_tid mismatch '$worker_tid' vs existing:'$match_worker_tid'" |
||||
} |
||||
#buffering set during channel creation will be preserved on thread::transfer |
||||
thread::transfer $worker_tid $wchan |
||||
thread::send -async $worker_tid [list ::shellthread::worker::start_pipe_write $tag_pipename $wchan] |
||||
} |
||||
|
||||
proc write_log {source msg args} { |
||||
variable workers |
||||
set ts_micros_sent [clock micros] |
||||
set defaults [list -async 1 -level info] |
||||
set opts [dict merge $defaults $args] |
||||
|
||||
if {[dict exists $workers $source]} { |
||||
set tidworker [dict get $workers $source tid] |
||||
if {$tidworker eq "noop"} { |
||||
return |
||||
} |
||||
if {![thread::exists $tidworker]} { |
||||
# -syslog -file ? |
||||
set tidworker [new_worker $source] |
||||
} |
||||
} else { |
||||
#auto create with no requirement to call new_worker.. warn? |
||||
# -syslog -file ? |
||||
error "write_log no log opened for source: $source" |
||||
set tidworker [new_worker $source] |
||||
} |
||||
set client_tid [thread::id] |
||||
if {[dict get $opts -async]} { |
||||
thread::send -async $tidworker [list ::shellthread::worker::send_info $client_tid $ts_micros_sent $source $msg] |
||||
} else { |
||||
thread::send $tidworker [list ::shellthread::worker::send_info $client_tid $ts_micros_sent $source $msg] |
||||
} |
||||
} |
||||
proc report_worker_errors {errdict} { |
||||
variable workers |
||||
set reporting_tid [dict get $errdict worker_tid] |
||||
dict for {src srcinfo} $workers { |
||||
if {[dict get $srcinfo tid] eq $reporting_tid} { |
||||
dict set srcinfo errors [dict get $errdict errors] |
||||
dict set workers $src $srcinfo ;#writeback updated |
||||
break |
||||
} |
||||
} |
||||
} |
||||
|
||||
#aka leave_worker |
||||
#Note that the tags may be on separate workertids, or some tags may share workertids |
||||
proc unsubscribe {sourcetaglist} { |
||||
variable workers |
||||
#workers structure example: |
||||
#[list sourcetag1 [list tid <tidworker> list_client_tids <clients>] ts_start <ts_start> ts_end_list {}] |
||||
variable free_threads |
||||
set mytid [thread::id] ;#caller of shellthread::manager::xxx is the client thread |
||||
|
||||
set subscriberless_tags [list] |
||||
foreach source $sourcetaglist { |
||||
if {[dict exists $workers $source]} { |
||||
set list_client_tids [dict get $workers $source list_client_tids] |
||||
if {[set posn [lsearch $list_client_tids $mytid]] >= 0} { |
||||
set list_client_tids [lreplace $list_client_tids $posn $posn] |
||||
dict set workers $source list_client_tids $list_client_tids |
||||
} |
||||
if {![llength $list_client_tids]} { |
||||
lappend subscriberless_tags $source |
||||
} |
||||
} |
||||
} |
||||
|
||||
#we've removed our own tid from all the tags - possibly across multiplew workertids, and possibly leaving some workertids with no subscribers for a particular tag - or no subscribers at all. |
||||
|
||||
set subscriberless_workers [list] |
||||
set shuttingdown_workers [list] |
||||
foreach deadtag $subscriberless_tags { |
||||
set workertid [dict get $workers $deadtag tid] |
||||
set worker_tags [get_worker_tagstate $workertid] |
||||
set subscriber_count 0 |
||||
set kill_count 0 ;#number of ts_end_list entries - even one indicates thread is doomed |
||||
foreach taginfo $worker_tags { |
||||
incr subscriber_count [llength [dict get $taginfo list_client_tids]] |
||||
incr kill_count [llength [dict get $taginfo ts_end_list]] |
||||
} |
||||
if {$subscriber_count == 0} { |
||||
lappend subscriberless_workers $workertid |
||||
} |
||||
if {$kill_count > 0} { |
||||
lappend shuttingdown_workers $workertid |
||||
} |
||||
} |
||||
|
||||
#if worker isn't shutting down - add it to free_threads list |
||||
foreach workertid $subscriberless_workers { |
||||
if {$workertid ni $shuttingdown_workers} { |
||||
if {$workertid ni $free_threads && $workertid ne "noop"} { |
||||
lappend free_threads $workertid |
||||
} |
||||
} |
||||
} |
||||
|
||||
#todo |
||||
#unsub this client_tid from the sourcetags in the sourcetaglist. if no more client_tids exist for sourcetag, remove sourcetag, |
||||
#if no more sourcetags - add worker to free_threads |
||||
} |
||||
proc get_worker_tagstate {workertid} { |
||||
variable workers |
||||
set taginfo_list [list] |
||||
dict for {source sourceinfo} $workers { |
||||
if {[dict get $sourceinfo tid] eq $workertid} { |
||||
lappend taginfo_list $sourceinfo |
||||
} |
||||
} |
||||
return $taginfo_list |
||||
} |
||||
|
||||
#finalisation |
||||
proc shutdown_free_threads {{timeout 2500}} { |
||||
variable free_threads |
||||
if {![llength $free_threads]} { |
||||
return |
||||
} |
||||
upvar ::shellthread::manager::timeouts timeoutarr |
||||
if {[info exists timeoutarr(shutdown_free_threads)]} { |
||||
#already called |
||||
return false |
||||
} |
||||
#set timeoutarr(shutdown_free_threads) waiting |
||||
#after $timeout [list set timeoutarr(shutdown_free_threads) timed-out] |
||||
set ::shellthread::waitfor waiting |
||||
after $timeout [list set ::shellthread::waitfor] |
||||
|
||||
set waiting_for [list] |
||||
set ended [list] |
||||
set timedout 0 |
||||
foreach tid $free_threads { |
||||
if {[thread::exists $tid]} { |
||||
lappend waiting_for $tid |
||||
#thread::send -async $tid [list shellthread::worker::terminate [thread::id]] timeoutarr(shutdown_free_threads) |
||||
thread::send -async $tid [list shellthread::worker::terminate [thread::id]] ::shellthread::waitfor |
||||
} |
||||
} |
||||
if {[llength $waiting_for]} { |
||||
for {set i 0} {$i < [llength $waiting_for]} {incr i} { |
||||
vwait ::shellthread::waitfor |
||||
if {$::shellthread::waitfor eq "timed-out"} { |
||||
set timedout 1 |
||||
break |
||||
} else { |
||||
lappend ended $::shellthread::waitfor |
||||
} |
||||
} |
||||
} |
||||
set free_threads [list] |
||||
return [dict create existed $waiting_for ended $ended timedout $timedout] |
||||
} |
||||
|
||||
#TODO - important. |
||||
#REVIEW! |
||||
#since moving to the unsubscribe mechansm - close_worker $source isn't being called |
||||
# - we need to set a limit to the number of free threads and shut down excess when detected during unsubscription |
||||
#instruction to shut-down the thread that has this source. |
||||
#instruction to shut-down the thread that has this source. |
||||
proc close_worker {source {timeout 2500}} { |
||||
variable workers |
||||
variable worker_errors |
||||
variable free_threads |
||||
upvar ::shellthread::manager::timeouts timeoutarr |
||||
set ts_now [clock micros] |
||||
#puts stderr "close_worker $source" |
||||
if {[dict exists $workers $source]} { |
||||
set tidworker [dict get $workers $source tid] |
||||
if {$tidworker in $freethreads} { |
||||
#make sure a thread that is being closed is removed from the free_threads list |
||||
set posn [lsearch $freethreads $tidworker] |
||||
set freethreads [lreplace $freethreads $posn $posn] |
||||
} |
||||
set mytid [thread::id] |
||||
set client_tids [dict get $workers $source list_client_tids] |
||||
if {[set posn [lsearch $client_tids $mytid]] >= 0} { |
||||
set client_tids [lreplace $client_tids $posn $posn] |
||||
#remove self from list of clients |
||||
dict set workers $source list_client_tids $client_tids |
||||
} |
||||
set ts_end_list [dict get $workers $source ts_end_list] ;#ts_end_list is just a list of timestamps of closing calls for this source - only one is needed to close, but they may all come in a flurry. |
||||
if {[llength $ts_end_list]} { |
||||
set last_end_ts [lindex $ts_end_list end] |
||||
if {(($tsnow - $last_end_ts) / 1000) >= $timeout} { |
||||
lappend ts_end_list $ts_now |
||||
dict set workers $source ts_end_list $ts_end_list |
||||
} else { |
||||
#existing close in progress.. assume it will work |
||||
return |
||||
} |
||||
} |
||||
|
||||
if {[thread::exists $tidworker]} { |
||||
#puts stderr "shellthread::manager::close_worker: thread $tidworker for source $source still running.. terminating" |
||||
|
||||
#review - timeoutarr is local var (?) |
||||
set timeoutarr($source) 0 |
||||
after $timeout [list set timeoutarr($source) 2] |
||||
|
||||
thread::send -async $tidworker [list shellthread::worker::send_errors_now [thread::id]] |
||||
thread::send -async $tidworker [list shellthread::worker::terminate [thread::id]] timeoutarr($source) |
||||
|
||||
#thread::send -async $tidworker [string map [list %tidclient% [thread::id]] { |
||||
# shellthread::worker::terminate %tidclient% |
||||
#}] timeoutarr($source) |
||||
|
||||
vwait timeoutarr($source) |
||||
#puts stderr "shellthread::manager::close_worker: thread $tidworker for source $source DONE1" |
||||
|
||||
thread::release $tidworker |
||||
#puts stderr "shellthread::manager::close_worker: thread $tidworker for source $source DONE2" |
||||
if {[dict exists $workers $source errors]} { |
||||
set errlist [dict get $workers $source errors] |
||||
if {[llength $errlist]} { |
||||
lappend worker_errors [list $source [dict get $workers $source]] |
||||
} |
||||
} |
||||
dict unset workers $source |
||||
} else { |
||||
#thread may have been closed by call to close_worker with another source with same worker |
||||
#clear workers record for this source |
||||
#REVIEW - race condition for re-creation of source with new workerid? |
||||
#check that record is subscriberless to avoid this |
||||
if {[llength [dict get $workers $source list_client_tids]] == 0} { |
||||
dict unset workers $source |
||||
} |
||||
} |
||||
} |
||||
#puts stdout "close_worker $source - end" |
||||
} |
||||
|
||||
#worker errors only available for a source after close_worker called on that source |
||||
#It is possible for there to be multiple entries for a source because new_worker can be called multiple times with same sourcetag, |
||||
proc get_and_clear_errors {source} { |
||||
variable worker_errors |
||||
set source_errors [lsearch -all -inline -index 0 $worker_errors $source] |
||||
set worker_errors [lsearch -all -inline -index 0 -not $worker_errors $source] |
||||
return $source_errors |
||||
} |
||||
|
||||
|
||||
} |
||||
|
||||
package provide shellthread [namespace eval shellthread { |
||||
variable version |
||||
set version 1.6.1 |
||||
}] |
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
Loading…
Reference in new issue