본문으로 바로가기

oobgexec1 0.1

category Tcl & Tk/팁 (Tip) 2025. 9. 30. 15:18

출처: 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