Posted to tcl by hypnotoad at Wed Jun 09 11:17:16 GMT 2010view raw

  1. catch {rename puts console:oldputs$w}
  2. proc puts args [format {
  3. if {![winfo exists %s]} {
  4. rename puts {}
  5. rename console:oldputs%s puts
  6. return [uplevel #0 puts $args]
  7. }
  8. switch -glob -- "[llength $args] $args" {
  9. {1 *} {
  10. set msg [lindex $args 0]\n
  11. set tag ok
  12. }
  13. {2 stdout *} {
  14. set msg [lindex $args 1]\n
  15. set tag ok
  16. }
  17. {2 stderr *} {
  18. set msg [lindex $args 1]\n
  19. set tag err
  20. }
  21. {2 green *} {
  22. set msg [lindex $args 1]\n
  23. set tag grn
  24. }
  25. {2 purple *} {
  26. set msg [lindex $args 1]\n
  27. set tag purple
  28. }
  29. {2 lightblue *} {
  30. set msg [lindex $args 1]\n
  31. set tag lblue
  32. }
  33. {2 orange *} {
  34. set msg [lindex $args 1]\n
  35. set tag orange
  36. }
  37. {2 -nonewline *} {
  38. set msg [lindex $args 1]
  39. set tag ok
  40. }
  41. {3 -nonewline stdout *} {
  42. set msg [lindex $args 2]
  43. set tag ok
  44. }
  45. {3 -nonewline stderr *} {
  46. set msg [lindex $args 2]
  47. set tag err
  48. }
  49. default {
  50. uplevel #0 console:oldputs%s $args
  51. return
  52. }
  53. }
  54. console:Puts %s $msg $tag
  55. } $w $w $w $w.t]