Posted to tcl by mjanssen at Thu Oct 26 10:13:32 GMT 2006view raw

  1. namespace eval debug {
  2.  
  3. namespace export breakpoint
  4.  
  5. proc breakpoint {args} { puts "bp"}
  6.  
  7. proc _trigger {command op} {
  8. puts "breakpoint: [lindex $command end]"
  9. set clevel [uplevel 1 {info level}]
  10. set proc [lindex [uplevel 1 "info level 0"] 0]
  11. while 1 {
  12. puts -nonewline "(level #${clevel}) > "
  13. flush stdout
  14. gets stdin cmd
  15. if {$cmd ne "c"} {
  16. catch {puts [uplevel 1 $cmd]} err
  17. if {$err ne "" } {
  18. puts $err
  19. }
  20.  
  21. } else {break}
  22.  
  23. }
  24. }
  25.  
  26. proc on {} {
  27. trace add execution breakpoint enter ::debug::_trigger
  28. }
  29.  
  30. proc off {} {
  31. trace remove execution breakpoint enter ::debug::_trigger
  32. }
  33. }
  34.  
  35. package provide debug 0.1
  36.  
  37.  
  38. #Test
  39.  
  40. package require debug
  41.  
  42. proc test {a} {
  43. ::debug::breakpoint $a
  44. puts $a
  45. }
  46. ::debug::on
  47.  
  48. test 5
  49.  
  50. ::debug::off
  51.  
  52. test 6