luke
/
xschem
mirror of https://github.com/StefanSchippers/xschem.git
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

fix regression in tcl execute procedure ("execute 0 prog" blocking if prog closes stdout/stderr file descriptors)

This commit is contained in:
Stefan Frederik 2021-12-13 01:52:18 +01:00
parent a6004cde6c
commit b7af31d38c
1 changed files with 35 additions and 27 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

22
src/xschem.tcl
View File

@ -43,19 +43,19 @@ proc execute_fileevent {id} {
append execute(data,$id) [read $execute(pipe,$id) 1024] append execute(data,$id) [read $execute(pipe,$id) 1024]
if {[eof $execute(pipe,$id)]} { if {[eof $execute(pipe,$id)]} {
fileevent $execute(pipe,$id) readable "" fileevent $execute(pipe,$id) readable ""
if { $execute(status,$id) } {
# setting pipe to blocking before closing allows to see if pipeline failed # setting pipe to blocking before closing allows to see if pipeline failed
# do not ask status for processes that close stdout/stderr, as eof might # do not ask status for processes that close stdout/stderr, as eof might
# occur before process ends and following close blocks until process terminates. # occur before process ends and following close blocks until process terminates.
fconfigure $execute(pipe,$id) -blocking 1 fconfigure $execute(pipe,$id) -blocking 1
set status 0 set status 0
if { [ info tclversion] > 8.4} { if { [ info tclversion] > 8.4} {
set catch_return [eval catch [ list {close $execute(pipe,$id)} err options] ] set catch_return [eval catch [list {close $execute(pipe,$id)} err options] ]
} else { } else {
set catch_return [eval catch [ list {close $execute(pipe,$id)} err] ] set catch_return [eval catch [list {close $execute(pipe,$id)} err] ]
} }
if {$catch_return} { if {$catch_return} {
if { [ info tclversion] > 8.4} { if {[info tclversion] > 8.4} {
set details [dict get $options -errorcode] set details [dict get $options -errorcode]
if {[lindex $details 0] eq "CHILDSTATUS"} { if {[lindex $details 0] eq "CHILDSTATUS"} {
set status [lindex $details 2] set status [lindex $details 2]
@ -73,12 +73,19 @@ proc execute_fileevent {id} {
} }
} }
} }
if { $status == 0 } { if {$status == 0} {
if {$execute(status,$id) } { if {$execute(status,$id) } {
viewdata "Completed: $execute(cmd,$id)\ndata:\n$execute(data,$id)" ro viewdata "Completed: $execute(cmd,$id)\ndata:\n$execute(data,$id)" ro
} }
} }
if { [info exists execute(callback,$id)] } { eval $execute(callback,$id); unset execute(callback,$id) } } else {
# nonblocking close always succeed
close $execute(pipe,$id)
}
if {[info exists execute(callback,$id)]} {
eval $execute(callback,$id)
unset execute(callback,$id)
}
unset execute(pipe,$id) unset execute(pipe,$id)
unset execute(data,$id) unset execute(data,$id)
unset execute(status,$id) unset execute(status,$id)
@ -117,7 +124,8 @@ proc execute {status args} {
if { [catch {open "|$args" r} err] } { if { [catch {open "|$args" r} err] } {
puts stderr "Proc execute error: $err" puts stderr "Proc execute error: $err"
if { [info exists has_x]} { if { [info exists has_x]} {
tk_messageBox -message "Can not execute '$args': ensure it is available on the system. Error: $err" \ tk_messageBox -message \
"Can not execute '$args': ensure it is available on the system. Error: $err" \
-icon error -parent [xschem get topwindow] -type ok -icon error -parent [xschem get topwindow] -type ok
} }
return -1 return -1