File: balloon.tcl

package info (click to toggle)
covered 0.7.10-3
  • links: PTS, VCS
  • area: main
  • in suites: bullseye, buster, sid, stretch
  • size: 8,916 kB
  • sloc: ansic: 48,807; yacc: 11,650; xml: 8,838; tcl: 7,698; sh: 3,925; lex: 2,240; makefile: 360; perl: 329
file content (79 lines) | stat: -rw-r--r-- 1,887 bytes parent folder | download | duplicates (4)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
namespace eval balloon {
  variable long_delay 750
  variable short_delay 50
  variable off_delay 5000
  variable delay $long_delay
  variable family {}
  variable after_id {}
}

bind . <Enter> {
  if {$show_tooltips == true} {
    if {$balloon::family != ""} {
      if {[lsearch -exact $balloon::family %W] == -1} {
        set balloon::family {}
        set balloon::delay $balloon::long_delay
      }
    }
  }
}

proc balloon_show {w help} {

  global show_tooltips

  if {$show_tooltips == true} {
    set balloon::after_id [after $balloon::delay [list balloon::show $w $help]]
    set balloon::delay $balloon::short_delay
    set balloon::family [balloon::getwfamily $w]
    set balloon::after_id [after $balloon::off_delay destroy $w.balloon]
  }

}

proc balloon_destroy {w} {

  global show_tooltips

  if {$show_tooltips == true} {
    balloon::hide $w
  }

}

proc set_balloon {w help} {

  bind $w <Enter> "+balloon_show %W [list $help]"
  bind $w <Leave> "+balloon_destroy %W"
  bind $w <Button> "+balloon_destroy %W"

}

# Add these to the namespace
proc balloon::getwfamily {w} {
  return [winfo children [winfo parent $w]]
}

proc balloon::show {w arg {bgcolor lightyellow} {fgcolor black}} {

  if {[string compare -length [string length $w] [eval winfo containing  [winfo pointerxy .]] $w] != 0} {return}

  after cancel $balloon::after_id
  set top $w.balloon
  catch {destroy $top}
  toplevel $top -bd 1 -bg black
  wm overrideredirect $top 1
  if {[string equal [tk windowingsystem] aqua]}  {
    ::tk::unsupported::MacWindowStyle style $top help none
  }
  pack [message $top.txt -aspect 1500 -bg $bgcolor -fg $fgcolor -padx 1 -pady 0 -text $arg]
  set wmx [winfo pointerx $w]
  set wmy [expr [winfo pointery $w]+20]
  wm geometry $top [winfo reqwidth $top.txt]x[winfo reqheight $top.txt]+$wmx+$wmy
  raise $top

}

proc balloon::hide {w} {
  destroy $w.balloon
}