출처: https://wiki.tcl-lang.org/page/Matthias+Hoffmann+-+Tcl-Code-Snippets+-+Misc+-+Bgexec
TclOO를 이용한 백그라운드 실행중 stdout을 캡쳐하는 클래스입니다.
package require TclOO
package require Tcl 8.5
package provide oobgexec1 0.1
oo::class create bgExec {
self variable objNr
self method nextObjNr {} {incr objNr}
self method activeObjects {} {info class instances bgExec}
self method activeObjectsCount {} {llength [my activeObjects]}; # := vwaitvar
###
# Generische Handler (werden über Fileevent gerufen, müssen also public sein...)
# $obj wird an den Userhandler übergeben, da hierüber bei Bedarf zusätzliche
# Daten gelesen werden können (siehe getInfos).
# Signatur UserHandler: proc callback {obj type {data ""}}.
self method onFileEvent {obj chan callback} {
if {[catch {gets $chan line} result]} {
$obj cancelTimeout
catch {uplevel 1 [list {*}$callback $obj error $result]}; # Fehler vor Close melden
$obj destroy
} elseif {$result >= 0} {
catch {uplevel 1 [list {*}$callback $obj data $line]} ; # Daten vorhanden
} else {
catch {uplevel 1 [list {*}$callback $obj nodata]} ; # keine Daten vorhanden (Idle)
}
if {[eof $chan]} {
$obj cancelTimeout
catch {uplevel 1 [list {*}$callback $obj eof]} ; # End-of-File vor Close melden
$obj destroy
}
}
self method onTimeout {obj callback pids} {
catch {uplevel 1 [list {*}$callback $obj timeout $pids]} ; # Timeout vor Close melden
$obj destroy
}
variable pipe cb chan timeoutID userData objNr waitvar
constructor {pipeline callback args} {
set options [dict create -timeout 0 -userdata "" -fconf "" -vwaitvar ::bgExecVwaitVar]
set keys [dict keys $options]
foreach {arg val} $args {
set key [lsearch -glob -nocase -inline $keys $arg*]
if {$key ne ""} {
dict set options $key $val
} else {
return -code error "invalid option. Allowed are: $keys."
}
}
set pipe $pipeline
set cb $callback
set fconf [dict merge {-blocking 0 -buffering line} [dict get $options -fconf]]
set timeoutID ""
set waitvar [dict get $options -vwaitvar]; # schon hier, weil im Falle des Scheiterns
incr $waitvar; # des open der Destruktor aufgerufen wird und dekrementiert!
set chan [open "| $pipeline 2>@1" r]; # aktuell wieder nur READ-Channel
fconfigure $chan {*}$fconf
if {[dict get $options -timeout]} {
set timeoutID [after [dict get $options -timeout] [list bgExec onTimeout [self] $callback [pid $chan]]]
}
set userData [dict get $options -userdata]
set objNr [bgExec nextObjNr]
fileevent $chan readable [list bgExec onFileEvent [self] $chan $callback]
}
destructor {
my cancelTimeout
catch {close $chan}; # falls nicht bereits explizit getätigt (catch erforderlich?)
incr $waitvar -1
}
method getInfos {} {
return [list $objNr $chan $pipe $userData $waitvar $timeoutID]
}
method cancelTimeout {} {
if {$timeoutID ne ""} {
after cancel $timeoutID
}
}
}
테스트는 아래와 같이 합니다.
proc callback {args} {
puts $args
}
set ::bgExecVwaitVar 0
puts [bgExec new "ping 127.0.0.1" callback -vwaitvar ::bgExecVwaitVar]
vwait ::bgExecVwaitVar
아래는 결과입니다.
C:\Temp>tclsh85 oobgexec.tcl
::oo::Obj12
::oo::Obj12 data {}
::oo::Obj12 data {Ping 127.0.0.1 32바이트 데이터 사용:}
::oo::Obj12 data {127.0.0.1의 응답: 바이트=32 시간<1ms TTL=128}
::oo::Obj12 data {127.0.0.1의 응답: 바이트=32 시간<1ms TTL=128}
::oo::Obj12 data {127.0.0.1의 응답: 바이트=32 시간<1ms TTL=128}
::oo::Obj12 data {127.0.0.1의 응답: 바이트=32 시간<1ms TTL=128}
::oo::Obj12 data {}
::oo::Obj12 data {127.0.0.1에 대한 Ping 통계:}
::oo::Obj12 data { 패킷: 보냄 = 4, 받음 = 4, 손실 = 0 (0% 손실),}
::oo::Obj12 data {왕복 시간(밀리초):}
::oo::Obj12 data { 최소 = 0ms, 최대 = 0ms, 평균 = 0ms}
::oo::Obj12 nodata
::oo::Obj12 eof
'Tcl & Tk > 팁 (Tip)' 카테고리의 다른 글
Tcl의 로고가 깃털인 이유 (0) | 2025.09.05 |
---|---|
값 호출과 참조 호출 (0) | 2025.09.05 |
Tcl 8.5의 임의 정밀도 계산 (0) | 2025.09.01 |
namespace ensemble (0) | 2025.09.01 |
메가위젯(Megawidget) 이란? (0) | 2025.08.18 |