Posted to tcl by apw at Sun Sep 30 08:13:04 GMT 2007view raw

  1. ::itcl::struct ::ntk::classes::base {
  2. public variable parent [list]
  3. public variable children [list]
  4. public variable manager [list]
  5. public variable redraw [list]
  6. public variable destroy [list]
  7. public variable update 1
  8. public variable toplevel 0
  9. public variable removeFromManager [list]
  10. public variable renderTreeData [list]
  11. public variable bg [list]
  12. public variable obj [list]
  13. public variable path [list]
  14.  
  15. public option -reqwidth 0
  16. public option -reqheight 0
  17. public option -width 0
  18. public option -height 0
  19. public option -x 0
  20. public option -y 0
  21. public option -rotate 0
  22. public option -buttonrelease [list]
  23. public option -keypress [list]
  24. public option -keyrelease [list]
  25. public option -motion [list]
  26.  
  27. constructor {path width height obj parent {x 0} {y 0}
  28. {toplevel 0} {bg {}}} {
  29. configure -reqwidth $width
  30. configure -reqheight $height
  31. configure -width $width
  32. configure -height $height
  33. configure -x $x
  34. configure -y $y
  35. configure -obj $obj
  36. configure -parent $parent
  37. configure -toplevel $toplevel
  38. configure -bg $bg
  39. configure -path $path
  40. }
  41. public method getValue {what} {
  42. if {![info exists $what]} {
  43. return -code error "no such variable $what"
  44. }
  45. return [set $what]
  46. }
  47. public method setValue {what value} {
  48. if {![info exists $what]} {
  49. return -code error "no such variable $what"
  50. }
  51. if {[catch {set $what $value} err]} {
  52. return -code error $err
  53. }
  54. return $value
  55. }
  56. }
  57.  
  58. itcl::nwidget ::ntk::classes::window {
  59. private common cntWindows 0
  60. private common windows
  61. component base
  62. delegate option -reqwidth to base
  63. delegate option -reqheight to base
  64. delegate option -width to base
  65. delegate option -height to base
  66. delegate option -x to base
  67. delegate option -y to base
  68. delegate option -rotate to base
  69. delegate option -buttonpress to base
  70. delegate option -buttonrelease to base
  71. delegate option -keypress to base
  72. delegate option -keyrelease to base
  73. delegate method getValue to base
  74. delegate method setValue to base
  75. delegate method obj to base as [list getValue obj]
  76.  
  77. public proc parent {path} {
  78. puts stderr "path!$path!"
  79. set parent [string range $path 0 [expr {[string last . $path] - 1}]]
  80. if {$parent eq ""} {
  81. return .
  82. }
  83. return $parent
  84. }
  85. public proc toplevel {path} {
  86. set i [string first $path 1]
  87. if {$i < 0} {
  88. return $path
  89. } incr i -1
  90. return [string range $path 0 $i]
  91. }
  92. public method children {w} {
  93. return [$w getValue children]
  94. }
  95.  
  96. constructor {width height} {
  97. incr cntWindows
  98. set path [string trimleft $this :]
  99. if {[info exists windows($path)]} {
  100. return -code error "window $this already exists"
  101. }
  102. set windows($path) $path
  103. #
  104. # Append the child to the parent's window list
  105. #
  106. set parent [parent $path]
  107. puts stderr "parent!$parent!$path!"
  108. # set pchildren [$parent children]
  109. # lappend pchildren $path
  110. # $parent children $pchildren
  111. set obj [megaimage-blank $width $height]
  112. set base [::ntk::classes::base ::ntk::classes::_win$cntWindows $path $width $height $obj $parent 0 0 0 [list]]
  113. return $path
  114. }
  115. }
  116.  
  117.  
  118. public option -buttonpress [list]
  119.