Posted to tcl by tomk at Sat Jun 29 16:29:46 GMT 2013view raw

  1. # ACTIVESTATE TEAPOT-PKG BEGIN TM -*- tcl -*-
  2. # -- Tcl Module
  3.  
  4. # @@ Meta Begin
  5. # Package tooltip 1.4.4
  6. # Meta as::build::date 2012-03-31
  7. # Meta as::origin http://sourceforge.net/projects/tcllib
  8. # Meta category Tooltip management
  9. # Meta description Tooltip management
  10. # Meta license BSD
  11. # Meta platform tcl
  12. # Meta require {Tk 8.4}
  13. # Meta require msgcat
  14. # Meta subject hover help balloon tooltip
  15. # Meta summary tooltip
  16. # @@ Meta End
  17.  
  18.  
  19. # ACTIVESTATE TEAPOT-PKG BEGIN DECLARE
  20.  
  21. package provide tooltip 1.4.4
  22.  
  23. # ACTIVESTATE TEAPOT-PKG END DECLARE
  24. # ACTIVESTATE TEAPOT-PKG END TM
  25. # tooltip.tcl --
  26. #
  27. # Balloon help
  28. #
  29. # Copyright (c) 1996-2007 Jeffrey Hobbs
  30. #
  31. # See the file "license.terms" for information on usage and redistribution
  32. # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  33. #
  34. # RCS: @(#) $Id: tooltip.tcl,v 1.16 2008/12/01 23:37:16 hobbs Exp $
  35. #
  36. # Initiated: 28 October 1996
  37.  
  38.  
  39. package require Tk 8.4
  40. package require msgcat
  41.  
  42. #------------------------------------------------------------------------
  43. # PROCEDURE
  44. # tooltip::tooltip
  45. #
  46. # DESCRIPTION
  47. # Implements a tooltip (balloon help) system
  48. #
  49. # ARGUMENTS
  50. # tooltip <option> ?arg?
  51. #
  52. # clear ?pattern?
  53. # Stops the specified widgets (defaults to all) from showing tooltips
  54. #
  55. # delay ?millisecs?
  56. # Query or set the delay. The delay is in milliseconds and must
  57. # be at least 50. Returns the delay.
  58. #
  59. # disable OR off
  60. # Disables all tooltips.
  61. #
  62. # enable OR on
  63. # Enables tooltips for defined widgets.
  64. #
  65. # <widget> ?-index index? ?-items id? ?-tag tag? ?message?
  66. # If -index is specified, then <widget> is assumed to be a menu
  67. # and the index represents what index into the menu (either the
  68. # numerical index or the label) to associate the tooltip message with.
  69. # Tooltips do not appear for disabled menu items.
  70. # If -item is specified, then <widget> is assumed to be a listbox
  71. # or canvas and the itemId specifies one or more items.
  72. # If -tag is specified, then <widget> is assumed to be a text
  73. # and the tagId specifies a tag.
  74. # If message is {}, then the tooltip for that widget is removed.
  75. # The widget must exist prior to calling tooltip. The current
  76. # tooltip message for <widget> is returned, if any.
  77. #
  78. # RETURNS: varies (see methods above)
  79. #
  80. # NAMESPACE & STATE
  81. # The namespace tooltip is used.
  82. # Control toplevel name via ::tooltip::wname.
  83. #
  84. # EXAMPLE USAGE:
  85. # tooltip .button "A Button"
  86. # tooltip .menu -index "Load" "Loads a file"
  87. #
  88. #------------------------------------------------------------------------
  89.  
  90. namespace eval ::tooltip {
  91. namespace export -clear tooltip
  92. variable labelOpts
  93. variable tooltip
  94. variable G
  95.  
  96. if {![info exists G]} {
  97. array set G {
  98. enabled 1
  99. fade 1
  100. FADESTEP 0.2
  101. FADEID {}
  102. DELAY 500
  103. AFTERID {}
  104. LAST -1
  105. TOPLEVEL .__tooltip__
  106. }
  107. if {[tk windowingsystem] eq "x11"} {
  108. set G(fade) 0 ; # don't fade by default on X11
  109. }
  110. }
  111. if {![info exists labelOpts]} {
  112. # Undocumented variable that allows users to extend / override
  113. # label creation options. Must be set prior to first registry
  114. # of a tooltip, or destroy $::tooltip::G(TOPLEVEL) first.
  115. set labelOpts [list -highlightthickness 0 -relief solid -bd 1 \
  116. -background lightyellow -fg black]
  117. }
  118.  
  119. # The extra ::hide call in <Enter> is necessary to catch moving to
  120. # child widgets where the <Leave> event won't be generated
  121. bind Tooltip <Enter> [namespace code {
  122. #tooltip::hide
  123. variable tooltip
  124. variable G
  125. set G(LAST) -1
  126. if {$G(enabled) && [info exists tooltip(%W)]} {
  127. set G(AFTERID) \
  128. [after $G(DELAY) [namespace code [list show %W $tooltip(%W) cursor]]]
  129. }
  130. }]
  131.  
  132. bind Menu <<MenuSelect>> [namespace code { menuMotion %W }]
  133. bind Tooltip <Leave> [namespace code [list hide 1]] ; # fade ok
  134. bind Tooltip <Any-KeyPress> [namespace code hide]
  135. bind Tooltip <Any-Button> [namespace code hide]
  136. }
  137.  
  138. proc ::tooltip::tooltip {w args} {
  139. variable tooltip
  140. variable G
  141. switch -- $w {
  142. clear {
  143. if {[llength $args]==0} { set args .* }
  144. clear $args
  145. }
  146. delay {
  147. if {[llength $args]} {
  148. if {![string is integer -strict $args] || $args<50} {
  149. return -code error "tooltip delay must be an\
  150. integer greater than 50 (delay is in millisecs)"
  151. }
  152. return [set G(DELAY) $args]
  153. } else {
  154. return $G(DELAY)
  155. }
  156. }
  157. fade {
  158. if {[llength $args]} {
  159. set G(fade) [string is true -strict [lindex $args 0]]
  160. }
  161. return $G(fade)
  162. }
  163. off - disable {
  164. set G(enabled) 0
  165. hide
  166. }
  167. on - enable {
  168. set G(enabled) 1
  169. }
  170. default {
  171. set i $w
  172. if {[llength $args]} {
  173. set i [uplevel 1 [namespace code "register [list $w] $args"]]
  174. }
  175. set b $G(TOPLEVEL)
  176. if {![winfo exists $b]} {
  177. variable labelOpts
  178.  
  179. toplevel $b -class Tooltip
  180. if {[tk windowingsystem] eq "aqua"} {
  181. ::tk::unsupported::MacWindowStyle style $b help none
  182. } else {
  183. wm overrideredirect $b 1
  184. }
  185. catch {wm attributes $b -topmost 1}
  186. # avoid the blink issue with 1 to <1 alpha on Windows
  187. catch {wm attributes $b -alpha 0.99}
  188. wm positionfrom $b program
  189. wm withdraw $b
  190. eval [linsert $labelOpts 0 label $b.label]
  191. pack $b.label -ipadx 1
  192. }
  193. if {[info exists tooltip($i)]} { return $tooltip($i) }
  194. }
  195. }
  196. }
  197.  
  198. proc ::tooltip::register {w args} {
  199. variable tooltip
  200. set key [lindex $args 0]
  201. while {[string match -* $key]} {
  202. switch -- $key {
  203. -index {
  204. if {[catch {$w entrycget 1 -label}]} {
  205. return -code error "widget \"$w\" does not seem to be a\
  206. menu, which is required for the -index switch"
  207. }
  208. set index [lindex $args 1]
  209. set args [lreplace $args 0 1]
  210. }
  211. -item - -items {
  212. if {[winfo class $w] eq "Listbox"} {
  213. set items [lindex $args 1]
  214. } else {
  215. set namedItem [lindex $args 1]
  216. if {[catch {$w find withtag $namedItem} items]} {
  217. return -code error "widget \"$w\" is not a canvas, or\
  218. item \"$namedItem\" does not exist in the canvas"
  219. }
  220. }
  221. set args [lreplace $args 0 1]
  222. }
  223. -tag {
  224. set tag [lindex $args 1]
  225. set r [catch {lsearch -exact [$w tag names] $tag} ndx]
  226. if {$r || $ndx == -1} {
  227. return -code error "widget \"$w\" is not a text widget or\
  228. \"$tag\" is not a text tag"
  229. }
  230. set args [lreplace $args 0 1]
  231. }
  232. default {
  233. return -code error "unknown option \"$key\":\
  234. should be -index, -items or -tag"
  235. }
  236. }
  237. set key [lindex $args 0]
  238. }
  239. if {[llength $args] != 1} {
  240. return -code error "wrong # args: should be \"tooltip widget\
  241. ?-index index? ?-items item? ?-tag tag? message\""
  242. }
  243. if {$key eq ""} {
  244. clear $w
  245. } else {
  246. if {![winfo exists $w]} {
  247. return -code error "bad window path name \"$w\""
  248. }
  249. if {[info exists index]} {
  250. set tooltip($w,$index) $key
  251. return $w,$index
  252. } elseif {[info exists items]} {
  253. foreach item $items {
  254. set tooltip($w,$item) $key
  255. if {[winfo class $w] eq "Listbox"} {
  256. enableListbox $w $item
  257. } else {
  258. enableCanvas $w $item
  259. }
  260. }
  261. # Only need to return the first item for the purposes of
  262. # how this is called
  263. return $w,[lindex $items 0]
  264. } elseif {[info exists tag]} {
  265. set tooltip($w,t_$tag) $key
  266. enableTag $w $tag
  267. return $w,$tag
  268. } else {
  269. set tooltip($w) $key
  270. bindtags $w [linsert [bindtags $w] end "Tooltip"]
  271. return $w
  272. }
  273. }
  274. }
  275.  
  276. proc ::tooltip::clear {{pattern .*}} {
  277. variable tooltip
  278. # cache the current widget at pointer
  279. set ptrw [winfo containing [winfo pointerx .] [winfo pointery .]]
  280. foreach w [array names tooltip $pattern] {
  281. unset tooltip($w)
  282. if {[winfo exists $w]} {
  283. set tags [bindtags $w]
  284. if {[set i [lsearch -exact $tags "Tooltip"]] != -1} {
  285. bindtags $w [lreplace $tags $i $i]
  286. }
  287. ## We don't remove TooltipMenu because there
  288. ## might be other indices that use it
  289.  
  290. # Withdraw the tooltip if we clear the current contained item
  291. if {$ptrw eq $w} { hide }
  292. }
  293. }
  294. }
  295.  
  296. proc ::tooltip::show {w msg {i {}}} {
  297. if {![winfo exists $w]} { return }
  298.  
  299. # Use string match to allow that the help will be shown when
  300. # the pointer is in any child of the desired widget
  301. if {([winfo class $w] ne "Menu")
  302. && ![string match $w* [eval [list winfo containing] \
  303. [winfo pointerxy $w]]]} {
  304. return
  305. }
  306.  
  307. variable G
  308.  
  309. after cancel $G(FADEID)
  310. set b $G(TOPLEVEL)
  311. # Use late-binding msgcat (lazy translation) to support programs
  312. # that allow on-the-fly l10n changes
  313. $b.label configure -text [::msgcat::mc $msg] -justify left
  314. update idletasks
  315. set screenw [winfo screenwidth $w]
  316. set screenh [winfo screenheight $w]
  317. set reqw [winfo reqwidth $b]
  318. set reqh [winfo reqheight $b]
  319. # When adjusting for being on the screen boundary, check that we are
  320. # near the "edge" already, as Tk handles multiple monitors oddly
  321. if {$i eq "cursor"} {
  322. set y [expr {[winfo pointery $w]+20}]
  323. if {($y < $screenh) && ($y+$reqh) > $screenh} {
  324. set y [expr {[winfo pointery $w]-$reqh-5}]
  325. }
  326. } elseif {$i ne ""} {
  327. set y [expr {[winfo rooty $w]+[winfo vrooty $w]+[$w yposition $i]+25}]
  328. if {($y < $screenh) && ($y+$reqh) > $screenh} {
  329. # show above if we would be offscreen
  330. set y [expr {[winfo rooty $w]+[$w yposition $i]-$reqh-5}]
  331. }
  332. } else {
  333. set y [expr {[winfo rooty $w]+[winfo vrooty $w]+[winfo height $w]+5}]
  334. if {($y < $screenh) && ($y+$reqh) > $screenh} {
  335. # show above if we would be offscreen
  336. set y [expr {[winfo rooty $w]-$reqh-5}]
  337. }
  338. }
  339. if {$i eq "cursor"} {
  340. set x [winfo pointerx $w]
  341. } else {
  342. set x [expr {[winfo rootx $w]+[winfo vrootx $w]+
  343. ([winfo width $w]-$reqw)/2}]
  344. }
  345. # only readjust when we would appear right on the screen edge
  346. if {$x<0 && ($x+$reqw)>0} {
  347. set x 0
  348. } elseif {($x < $screenw) && ($x+$reqw) > $screenw} {
  349. set x [expr {$screenw-$reqw}]
  350. }
  351. if {[tk windowingsystem] eq "aqua"} {
  352. set focus [focus]
  353. }
  354. # avoid the blink issue with 1 to <1 alpha on Windows, watch half-fading
  355. catch {wm attributes $b -alpha 0.99}
  356. wm geometry $b +$x+$y
  357. wm deiconify $b
  358. raise $b
  359. if {[tk windowingsystem] eq "aqua" && $focus ne ""} {
  360. # Aqua's help window steals focus on display
  361. after idle [list focus -force $focus]
  362. }
  363. }
  364.  
  365. proc ::tooltip::menuMotion {w} {
  366. variable G
  367.  
  368. if {$G(enabled)} {
  369. variable tooltip
  370.  
  371. # Menu events come from a funny path, map to the real path.
  372. set m [string map {"#" "."} [winfo name $w]]
  373. set cur [$w index active]
  374.  
  375. # The next two lines (all uses of LAST) are necessary until the
  376. # <<MenuSelect>> event is properly coded for Unix/(Windows)?
  377. if {$cur == $G(LAST)} return
  378. set G(LAST) $cur
  379. # a little inlining - this is :hide
  380. after cancel $G(AFTERID)
  381. catch {wm withdraw $G(TOPLEVEL)}
  382. if {[info exists tooltip($m,$cur)] || \
  383. (![catch {$w entrycget $cur -label} cur] && \
  384. [info exists tooltip($m,$cur)])} {
  385. set G(AFTERID) [after $G(DELAY) \
  386. [namespace code [list show $w $tooltip($m,$cur) cursor]]]
  387. }
  388. }
  389. }
  390.  
  391. proc ::tooltip::hide {{fadeOk 0}} {
  392. variable G
  393.  
  394. after cancel $G(AFTERID)
  395. after cancel $G(FADEID)
  396. if {$fadeOk && $G(fade)} {
  397. fade $G(TOPLEVEL) $G(FADESTEP)
  398. } else {
  399. catch {wm withdraw $G(TOPLEVEL)}
  400. }
  401. }
  402.  
  403. proc ::tooltip::fade {w step} {
  404. if {[catch {wm attributes $w -alpha} alpha] || $alpha <= 0.0} {
  405. catch { wm withdraw $w }
  406. catch { wm attributes $w -alpha 0.99 }
  407. } else {
  408. variable G
  409. wm attributes $w -alpha [expr {$alpha-$step}]
  410. set G(FADEID) [after 50 [namespace code [list fade $w $step]]]
  411. }
  412. }
  413.  
  414. proc ::tooltip::wname {{w {}}} {
  415. variable G
  416. if {[llength [info level 0]] > 1} {
  417. # $w specified
  418. if {$w ne $G(TOPLEVEL)} {
  419. hide
  420. destroy $G(TOPLEVEL)
  421. set G(TOPLEVEL) $w
  422. }
  423. }
  424. return $G(TOPLEVEL)
  425. }
  426.  
  427. proc ::tooltip::listitemTip {w x y} {
  428. variable tooltip
  429. variable G
  430.  
  431. set G(LAST) -1
  432. set item [$w index @$x,$y]
  433. if {$G(enabled) && [info exists tooltip($w,$item)]} {
  434. set G(AFTERID) [after $G(DELAY) \
  435. [namespace code [list show $w $tooltip($w,$item) cursor]]]
  436. }
  437. }
  438.  
  439. # Handle the lack of <Enter>/<Leave> between listbox items using <Motion>
  440. proc ::tooltip::listitemMotion {w x y} {
  441. variable tooltip
  442. variable G
  443. if {$G(enabled)} {
  444. set item [$w index @$x,$y]
  445. if {$item ne $G(LAST)} {
  446. set G(LAST) $item
  447. after cancel $G(AFTERID)
  448. catch {wm withdraw $G(TOPLEVEL)}
  449. if {[info exists tooltip($w,$item)]} {
  450. set G(AFTERID) [after $G(DELAY) \
  451. [namespace code [list show $w $tooltip($w,$item) cursor]]]
  452. }
  453. }
  454. }
  455. }
  456.  
  457. # Initialize tooltip events for Listbox widgets
  458. proc ::tooltip::enableListbox {w args} {
  459. if {[string match *listitemTip* [bind $w <Enter>]]} { return }
  460. bind $w <Enter> +[namespace code [list listitemTip %W %x %y]]
  461. bind $w <Motion> +[namespace code [list listitemMotion %W %x %y]]
  462. bind $w <Leave> +[namespace code [list hide 1]] ; # fade ok
  463. bind $w <Any-KeyPress> +[namespace code hide]
  464. bind $w <Any-Button> +[namespace code hide]
  465. }
  466.  
  467. proc ::tooltip::itemTip {w args} {
  468. variable tooltip
  469. variable G
  470.  
  471. set G(LAST) -1
  472. set item [$w find withtag current]
  473. if {$G(enabled) && [info exists tooltip($w,$item)]} {
  474. set G(AFTERID) [after $G(DELAY) \
  475. [namespace code [list show $w $tooltip($w,$item) cursor]]]
  476. }
  477. }
  478.  
  479. proc ::tooltip::enableCanvas {w args} {
  480. if {[string match *itemTip* [$w bind all <Enter>]]} { return }
  481. $w bind all <Enter> +[namespace code [list itemTip $w]]
  482. $w bind all <Leave> +[namespace code [list hide 1]] ; # fade ok
  483. $w bind all <Any-KeyPress> +[namespace code hide]
  484. $w bind all <Any-Button> +[namespace code hide]
  485. }
  486.  
  487. proc ::tooltip::tagTip {w tag} {
  488. variable tooltip
  489. variable G
  490. set G(LAST) -1
  491. if {$G(enabled) && [info exists tooltip($w,t_$tag)]} {
  492. if {[info exists G(AFTERID)]} { after cancel $G(AFTERID) }
  493. set G(AFTERID) [after $G(DELAY) \
  494. [namespace code [list show $w $tooltip($w,t_$tag) cursor]]]
  495. }
  496. }
  497.  
  498. proc ::tooltip::enableTag {w tag} {
  499. if {[string match *tagTip* [$w tag bind $tag]]} { return }
  500. $w tag bind $tag <Enter> +[namespace code [list tagTip $w $tag]]
  501. $w tag bind $tag <Leave> +[namespace code [list hide 1]] ; # fade ok
  502. $w tag bind $tag <Any-KeyPress> +[namespace code hide]
  503. $w tag bind $tag <Any-Button> +[namespace code hide]
  504. }
  505.  
  506. package provide tooltip 1.4.4
  507.