cursors.tcl 3.9 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186
  1. #
  2. # Map symbolic cursor names to platform-appropriate cursors.
  3. #
  4. # The following cursors are defined:
  5. #
  6. # standard -- default cursor for most controls
  7. # "" -- inherit cursor from parent window
  8. # none -- no cursor
  9. #
  10. # text -- editable widgets (entry, text)
  11. # link -- hyperlinks within text
  12. # crosshair -- graphic selection, fine control
  13. # busy -- operation in progress
  14. # forbidden -- action not allowed
  15. #
  16. # hresize -- horizontal resizing
  17. # vresize -- vertical resizing
  18. #
  19. # Also resize cursors for each of the compass points,
  20. # {nw,n,ne,w,e,sw,s,se}resize.
  21. #
  22. # Platform notes:
  23. #
  24. # Windows doesn't distinguish resizing at the 8 compass points,
  25. # only horizontal, vertical, and the two diagonals.
  26. #
  27. # OSX doesn't have resize cursors for nw, ne, sw, or se corners.
  28. # We use the Tk-defined X11 fallbacks for these.
  29. #
  30. # X11 doesn't have a "forbidden" cursor (usually a slashed circle);
  31. # "pirate" seems to be the conventional cursor for this purpose.
  32. #
  33. # Windows has an IDC_HELP cursor, but it's not available from Tk.
  34. #
  35. # Tk does not support "none" on Windows.
  36. #
  37. namespace eval ttk {
  38. variable Cursors
  39. # Use X11 cursor names as defaults, since Tk supplies these
  40. # on all platforms.
  41. #
  42. array set Cursors {
  43. "" ""
  44. none none
  45. standard left_ptr
  46. text xterm
  47. link hand2
  48. crosshair crosshair
  49. busy watch
  50. forbidden pirate
  51. hresize sb_h_double_arrow
  52. vresize sb_v_double_arrow
  53. nresize top_side
  54. sresize bottom_side
  55. wresize left_side
  56. eresize right_side
  57. nwresize top_left_corner
  58. neresize top_right_corner
  59. swresize bottom_left_corner
  60. seresize bottom_right_corner
  61. move fleur
  62. }
  63. # Platform-specific overrides for Windows and OSX.
  64. #
  65. switch [tk windowingsystem] {
  66. "win32" {
  67. array set Cursors {
  68. none {}
  69. standard arrow
  70. text ibeam
  71. link hand2
  72. crosshair crosshair
  73. busy wait
  74. forbidden no
  75. vresize size_ns
  76. nresize size_ns
  77. sresize size_ns
  78. wresize size_we
  79. eresize size_we
  80. hresize size_we
  81. nwresize size_nw_se
  82. swresize size_ne_sw
  83. neresize size_ne_sw
  84. seresize size_nw_se
  85. }
  86. }
  87. "aqua" {
  88. if {[package vsatisfies [package provide Tk] 8.5]} {
  89. # appeared 2007-04-23, Tk 8.5a6
  90. array set Cursors {
  91. standard arrow
  92. text ibeam
  93. link pointinghand
  94. crosshair crosshair
  95. busy watch
  96. forbidden notallowed
  97. hresize resizeleftright
  98. vresize resizeupdown
  99. nresize resizeup
  100. sresize resizedown
  101. wresize resizeleft
  102. eresize resizeright
  103. }
  104. }
  105. }
  106. }
  107. }
  108. ## ttk::cursor $cursor --
  109. # Return platform-specific cursor for specified symbolic cursor.
  110. #
  111. proc ttk::cursor {name} {
  112. variable Cursors
  113. return $Cursors($name)
  114. }
  115. ## ttk::setCursor $w $cursor --
  116. # Set the cursor for specified window.
  117. #
  118. # [ttk::setCursor] should be used in <Motion> bindings
  119. # instead of directly calling [$w configure -cursor ...],
  120. # as the latter always incurs a server round-trip and
  121. # can lead to high CPU load (see [#1184746])
  122. #
  123. proc ttk::setCursor {w name} {
  124. variable Cursors
  125. if {[$w cget -cursor] ne $Cursors($name)} {
  126. $w configure -cursor $Cursors($name)
  127. }
  128. }
  129. ## Interactive test harness:
  130. #
  131. proc ttk::CursorSampler {f} {
  132. ttk::frame $f
  133. set r 0
  134. foreach row {
  135. {nwresize nresize neresize}
  136. { wresize move eresize}
  137. {swresize sresize seresize}
  138. {text link crosshair}
  139. {hresize vresize ""}
  140. {busy forbidden ""}
  141. {none standard ""}
  142. } {
  143. set c 0
  144. foreach cursor $row {
  145. set w $f.${r}${c}
  146. ttk::label $w -text $cursor -cursor [ttk::cursor $cursor] \
  147. -relief solid -borderwidth 1 -padding 3
  148. grid $w -row $r -column $c -sticky nswe
  149. grid columnconfigure $f $c -uniform cols -weight 1
  150. incr c
  151. }
  152. grid rowconfigure $f $r -uniform rows -weight 1
  153. incr r
  154. }
  155. return $f
  156. }
  157. if {[info exists argv0] && $argv0 eq [info script]} {
  158. wm title . "[array size ::ttk::Cursors] cursors"
  159. pack [ttk::CursorSampler .f] -expand true -fill both
  160. bind . <KeyPress-Escape> [list destroy .]
  161. focus .f
  162. }
  163. #*EOF*