Posted to tcl by hypnotoad at Fri Nov 30 21:31:01 GMT 2018view pretty

namespace eval ::test {}
package require taotk

oo::class create ::test::fake {
   constructor args {
     after 5000 [namespace code {my trigger}]
   }
   destructor {
      puts [list [self] is dead]
   }
   method trigger {} { set ::response ok }
}

proc ::test::dialog args {
  destroy .prompt
  set ::response {}
  set info [::tool::args_to_options {*}$args]
  set class ::taotk::dialog.[dict getnull $info type]
  if {[info command $class] eq {}} {
    set class ::taotk::dialog.ok
  }
  dict set info varname ::response
  puts [list CREATE OBJECT] ; update
  #set tempobj [$class create prompt .prompt {*}$info]
  set obj [::test::fake new]
  puts [list $obj -> .prompt]
  rename $obj .prompt
  set testobj .prompt

  if {[info coroutine] eq {}} {
    puts [list VWAIT] ; update
    ::vwait ::response
  } else {
    puts [list COROUTINE VWAIT] ; update
    ::coroutine::util::vwait ::response
  }
  puts [list DESTROY] ; update
  catch {$tempobj destroy}
  puts [list RETURN $::response] ; update
  return $::response
}

# Transcript with Tcl 8.6.8
#
# basra:tcl seandeelywoods$ fossil status
# repository:   /Users/seandeelywoods/odie/download/tcl.fos
# local-root:   /Users/seandeelywoods/build/irm-rage/tcl/
# config-db:    /Users/seandeelywoods/.fossil
# checkout:     1e46dacaaba10131046c0871878d93c462b877e8 2017-12-19 20:53:27 UTC
# parent:       fe783af8319aaef2c123a660cfcdb604b811cc49 2017-12-19 14:46:31 UTC
# merged-from:  1a04c85a4f9d8e4669b22fe31bd943c75f9780aa 2017-12-19 20:48:52 UTC
# child:        2a6e85361613b22ee679e4fb8de5d6c70e64a23d 2018-03-27 07:48:33 UTC
# merged-into:  357365b9054897d86397354d77a1aef974da35ae 2017-12-23 18:33:36 UTC
# tags:         release, core-8-6-8, core-8-6-8-rc
# comment:      merge 8.6; update changes (user: dgp)
#
# wish% source ~/OneDrive/Documents/crashtest.tcl
# wish% test::dialog
# CREATE OBJECT
# ::oo::Obj326 -> .prompt
# VWAIT
# DESTROY
# RETURN ok
# ok
# wish% test::dialog
# CREATE OBJECT
# ::oo::Obj327 -> .prompt
# can't rename to ".prompt": command already exists
# wish% .prompt trigger
# invalid command name ".prompt"
# wish% test::dialog
# CREATE OBJECT
# ::oo::Obj328 -> .prompt
# can't rename to ".prompt": command already exists
# wish% test::fake destroy
# {} is dead
# ::oo::Obj327 is dead
# ::oo::Obj328 is dead
# wish% 

# Transcript with Tcl 8.6.9
#
# basra:tcl seandeelywoods$ fossil status
# repository:   /Users/seandeelywoods/odie/download/tcl.fos
# local-root:   /Users/seandeelywoods/build/irm-rage/tcl/
# config-db:    /Users/seandeelywoods/.fossil
# checkout:     770e6649a47ac43aabb2530a01b6129700889528 2018-11-16 18:45:59 UTC
# parent:       27603fe3a87e844a1aae2299e763083914b813e6 2018-11-09 19:14:07 UTC
# merged-into:  7aa0a364d51ee29af35623e6f131d636ede6804e 2018-11-16 20:26:14 UTC
# tags:         release, core-8-6-9, core-8-6-9-rc
# comment:      [00d04c4f12] Repair broken edge cases in [binary encode base64]. (user: dgp)
#
# wish% source ~/OneDrive/Documents/crashtest.tcl
# wish% test::dialog
# CREATE OBJECT
# ::oo::Obj333 -> .prompt
# VWAIT
# DESTROY
# RETURN ok
# ok
# wish% test::dialog
# CREATE OBJECT
# ::oo::Obj334 -> .prompt
# can't rename to ".prompt": command already exists
# wish% .prompt trigger
# invalid command name ".prompt"
# wish% info commands .prompt
# wish% test::dialog
# CREATE OBJECT
# ::oo::Obj335 -> .prompt
# can't rename to ".prompt": command already exists
# wish% rename .prompt {}
# can't delete ".prompt": command doesn't exist
# wish% test::fake destroy
# ::oo::Obj335 is dead
# ::oo::Obj334 is dead
# ::test::.prompt is dead
# wish%