Attachment "zcrash.tcl" to
ticket [2458202fff]
added by
patthoyts
2008-12-23 23:44:55.
# Sample program to illustrate a crash when exiting Tk having made use of
# reflected channels to create images.
#
# This file is self-sufficient. We present our own [memchan] implementation
# and a tiny virtual filesystem that lets [image create] use the data from
# the memchan.
package require Tcl 8.6
package require vfs
proc memchan {{filename {}}} {
return [chan create {read write} \
[list [namespace origin _memchan_handler] $filename]]
}
proc _memchan_handler {filename cmd chan args} {
upvar #0 _memchan(buf,$chan) buf
upvar #0 _memchan(pos,$chan) pos
upvar #0 _memchan(watch,$chan) watch
upvar #0 _memchan(timer,$chan) timer
upvar #0 _memchan(name,$chan) name
switch -exact -- $cmd {
initialize {
foreach {mode} $args break
set buf ""
set pos 0
set watch {}
set timer ""
set name $filename
return [list initialize finalize watch read write seek]
}
finalize {
puts stderr "$chan finalize"
after cancel $timer
unset buf pos watch timer name
}
seek {
foreach {offset base} $args break
switch -exact -- $base {
current { incr offset $pos }
end { incr offset [string length $buf] }
}
if {$offset < 0} {
return -code error "error during seek on \"$chan\":\
invalid argument"
} elseif {$offset > [string length $buf]} {
set extend [expr {$offset - [string length $buf]}]
append buf [binary format @$extend]
}
return [set pos $offset]
}
read {
foreach {count} $args break
set r [string range $buf $pos [expr {$pos + $count - 1}]]
incr pos [string length $r]
return $r
}
write {
foreach {data} $args break
set count [string length $data]
if { $pos >= [string length $buf] } {
append buf $data
} else {
set last [expr { $pos + $count - 1 }]
set buf [string replace $buf $pos $last $data]
}
incr pos $count
return $count
}
watch {
foreach {eventspec} $args break
after cancel $timer
set watch $eventspec
if {$eventspec ne {}} {
set timer [after 50 \
[list [namespace origin _memchan_handler] \
$filename timer $chan]]
}
}
timer {
# memchan channels are always writable and always readable
if {$watch ne {}} {
set event {}
if {"read" in $watch} { lappend event read }
if {"write" in $watch} { lappend event write }
if {[llength $event]} { chan postevent $chan $event }
set timer [after 50 [info level 0]]
}
}
}
}
# Create the channel containing the image data
set f [memchan]
chan configure $f -translation binary -encoding binary -eofchar {}
puts -nonewline $f [binary decode base64 {
R0lGODlhMAAwAOf/AAA4pgA3tAA6rQg6mgw7lRE9kRo0rAA/ygBBxQBB1F8S1QBE1QBK3QhOtQBK
5ABU1w5O2SJOqQBazQNX4QBg3BFa1gBh5ABq3gBq7SNkuBdm4gCBtyFyuAR59Sh0wTtttjVq2zBx
4RV+60B1sSh47ht+8yt74z9+uieF7CeJ3E6AqkGGtBiW1Fd+qkqDsx2P7y2M4DuF6DaOyFSFrzKK
8j2F7zOM7WmAnS+U00uOvF2IrWqEuXeDnDyR80aP61CL6XqGn3eKriqk9nyLnUyV60ic1lKZ70me
84eOo06h3G+Ww3yUsYuOqU2h9mOgw2KZ+Uav72Si7ZGZrW6e8pyZqk6y+WCq9Jeatmmq7nSn9GWu
+G6r952hsF2194Gm6G6u8nWr8Way9W+v9Hes8nmr+Hit9J6lunGx9new736t7qKmtoGs9ICu73qw
9oer7nK183my8aGqsYGv8Hqz8nyx+IOu9oit8IKw8Y2o/4Gy7ISv93y084Ox8oqu8XW49X219ISy
86eru3y38H+45KKuvH629oyw84a09n658ni7+ZSv83+685ew6JWy43i+9Y218JSy8IC89Kqyuo62
8qmxxp+2yH7B7Ja08oK+9q6ywXzB+Ze29IS/+K62vpK69oq/8pm49YbB+rS1vn7H94XE9pS8+IzB
9KG68o7D9pu99IjG+LC8yo7G8qK89La6yonI+pDF+J2/9ojL9qS99ZDI9YLP+KW+95/B+LTAzpjH
9ZLL94zO+ZnI9o7N/6zA85bN7JrJ95TM+ZnM86zE8JXO+pTQ9ZvN9LPC8K/D9sHCzJfP/LDE+JzP
9ZbS+JTV86HP8J3Q97XF8rLG+Z7R+LfG9J/S+ZnV+qLU7qDT+sHK0sfI0qHU+7nJ96PV/KHY+L3M
7ajW977K/7PT8KnX+MzM1sHM9KTb+8XN757f/avZ+qnb9brS/63a/LLb967c/ajf/8bR+rbb/tPU
3q/h+7bf+qrl/tXW4NTc5dne4dvg4+Xe6uDh6+bj6Onm6+jp8////yH+BlRrQ2hhdAAh+QQBCgD/
ACwAAAAAMAAwAAAI/gD/CRxIsKDBgwgTKlzIsKHDhxAjSpxIsSLFAgEQLEhwQMAAiw8NOFjz7Vy5
kiXDgWBAAGRCABNOHZspbR03m9KiLTtmAsIOlwUf1Jh1ypavYcukLVuG9BbRWVksRAD6rxGFJ40M
QYKUKpWvVMOQ2fJ6CpQhQ1MufACqwUadPloPGfLkaZKnrp4u6TWkBw8JDQMHCDiQYAGCAAUaSjDR
Z02ZO20g3XHz6FDlR5AeVQa0ho0eEgQYgAh38hu8defOeXFgIKGSEmCygCnDpjabNW7W3JHTZk3n
Pndm75gQ4pi0Ydy4lSvHbZi0Y8NOTQBwsIKNLbLLyKHNxo1t7rjZ/txhE8FCllmpbNlCJg2Ze6bq
T82q8cAgDSJiyqCBk+cRnDltsCHHeGjst8ccc3wAwhSKQHLKKb7EEsstvnyVyil6QdLIExQ0MlA/
R0QhhhhnlDFiHoWg6AeKKRYCRxllUNABHnqcpVlXqZRil1mXHKLHGnT4AJhA/ESxBYlvvCHIIp9w
8okppLBiSiifxEKKHxGQMB4bgBhimWaaQQIIIHcA14cbWchhggQC3fNCGH4ggsgiUKpCCy3AACMM
MLzQwgoqn2CAAhiO3QFIY2vo0UcfabjhnYBslLFGFluUoMQ//njgRyKaoEJKLsYAo0w12DBTjTLB
KGOMKq/E4MMW/rPJ0V1naIgBRm2P0lYGoWDEUIFAlFRhiZ3AGKMMNt1g8wyyyj5jDDPG9EDEbHPc
AQd/aAx4Rxlt7JEHIHnMAQcaWIhBBA0C2dOCLKPssouy44zTTTfexDtvN+M8Y4IV+Y2oXyEp5iEw
wHnsAUd+dIgBhxVH9CNQMiPU8gsz3lgzrzvutNOOO+ywk441zWSARZJn7OFIKaZwokkoqqBiyiea
fDKJIEkevIUR+QzkShBQGDOOOeqoszE7GbdDNDpJxKHFG4twsggpqAQDTDDBGEM1MKoEQ4rTi/iR
5Av7EKQNDs9444057YzTzjv0zFPPKDkMQQU5I5BiNy2oFGvM/rPNVMMMtFLTosrKi7zhgcMECSEO
MNfUosMMM6xwAw9ISKFGMvz8o0YKrKgydTB/d8PMvcn+bbXgllRBSUGDxPNMNTIwUUkmmUiSiSja
4FOQFCk0s0s14JAe7zjg2NsMM7vIIksL9hDkBAsbuLCEGfc0JA8XJzhTjDnpqN1OOt3LWy/IxYwy
QjIF6ROHGZLIA9E9aiBRBDrmdJwOxhjTY441ykIBhCtU0RkVhpCDUdRjHvRwBz280Q5zmMMbv8BB
NoCigAoOhB/JUIMUkMADHazABS3QQTGuAQtxCIEhFUyhClMoEBYWhB/aEIUobLeKSjBBBsqKxyAW
ssIeKqCFZhZsiD3MsAQXrIAFTnCICguyxIfIIxNmiIM+lBhEgrjwH00M4BUH4sIsUsWLQPwhGCm4
xTCWUYtVtOIY0fhDJvYwgG5soxrFmEY4nrGLdSRjHvGYR5CM8YprhKMgB0nIQhrykIgMCAA7
}]
flush $f
seek $f 0
# Create a vfs that just exposes one channel as a file.
namespace eval cvfs {}
proc cvfs::dispatch {what cmd root relative actpath args} {
eval [list $cmd $what $relative] $args
}
proc cvfs::stat {what name} {}
proc cvfs::access {what name mode} {}
proc cvfs::open {what name mode perm} { return [list $what {}] }
proc cvfs::matchindirectory {what path pattern type} { return [list $what] }
proc cvfs::createdirectory {what name} {}
proc cvfs::removedirectory {what name recursive} {}
proc cvfs::deletefile {what name} {}
proc cvfs::utime {what name atime mtime} {}
proc cvfs::fileattributes {what args} {
switch -- [length $args] {
0 {} 1 {} 2 {}
}
}
proc cvfs::Mount {chan root} {
vfs::filesystem mount $root [list ::cvfs::dispatch $chan]
vfs::RegisterMount $root [list vfs::filesystem unmount $root]
}
cvfs::Mount $f /Image
# Create an image and display it.
set img [image create photo -file /Image]
# Unmounting the vfs - there seems to be no channel to close
vfs::filesystem unmount /Image
pack [label .l -image $img]
bind . <Control-F2> {console show}
tkwait window .
# If we call exit here then the program exits cleanly.
# If we do not, then it crashes.
#exit
