# 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