Posted to tcl by hypnotoad at Fri Nov 30 21:14:14 GMT 2018view raw

  1. namespace eval ::test {}
  2. package require taotk
  3.  
  4. oo::class create ::test::fake {
  5. constructor args {
  6. after 5000 [namespace code {my trigger}]
  7. }
  8. destructor {
  9. puts [list [self] is dead]
  10. }
  11. method trigger {} { set ::response ok }
  12. }
  13.  
  14. proc ::test::dialog args {
  15. destroy .prompt
  16. set ::response {}
  17. set info [::tool::args_to_options {*}$args]
  18. set class ::taotk::dialog.[dict getnull $info type]
  19. if {[info command $class] eq {}} {
  20. set class ::taotk::dialog.ok
  21. }
  22. dict set info varname ::response
  23. puts [list CREATE OBJECT] ; update
  24. #set tempobj [$class create prompt .prompt {*}$info]
  25. set obj [::test::fake new]
  26. rename $obj .prompt
  27. set testobj .prompt
  28.  
  29. if {[info coroutine] eq {}} {
  30. puts [list VWAIT] ; update
  31. ::vwait ::response
  32. } else {
  33. puts [list COROUTINE VWAIT] ; update
  34. ::coroutine::util::vwait ::response
  35. }
  36. puts [list DESTROY] ; update
  37. catch {$tempobj destroy}
  38. puts [list RETURN $::response] ; update
  39. return $::response
  40. }
  41.  
  42.  
  43. # TRANSCRIPT
  44. # wish% source ~/OneDrive/Documents/crashtest.tcl
  45. # wish% test::dialog
  46. # CREATE OBJECT
  47. # invalid command name ":test::fake"
  48. # wish% source ~/OneDrive/Documents/crashtest.tcl
  49. # can't create object "::test::fake": command already exists with that name
  50. # wish% test::fake destroy
  51. # wish% source ~/OneDrive/Documents/crashtest.tcl
  52. # wish% test::dialog
  53. # CREATE OBJECT
  54. # VWAIT
  55. # DESTROY
  56. # RETURN ok
  57. # ok
  58. # wish% test::dialog
  59. # CREATE OBJECT
  60. # can't rename to ".prompt": command already exists
  61. # wish% .prompt foo
  62. # invalid command name ".prompt"
  63. # wish% test::fake destroy
  64. # ::oo::Obj328 is dead
  65. # ::test::.prompt is dead
  66. # wish%