#10
global tixOption
set gPB_help_tips(font)    $tixOption(font_sm)
set gPB_help_tips(screen)  1280 ;# Initialized, actual value found & set in pb.c.
set gPB_help_tips(width)   300 ;#<01-11-02 gsl> was 250.
set gPB_help_tips(color)   #ffff60
set gPB_help_tips(delay)   500
set gPB_help_tips(state)   1
set gPB_help_tips(life)    30000

#=======================================================================
proc PB_init_balloons {args} {
  global gPB_help_tips gPB_use_balloons
  getopt gPB_help_tips $args
  set gPB_use_balloons $gPB_help_tips(state)
  PB_enable_balloon Canvas
 }

#=======================================================================
proc PB_set_balloons {} {
  PB_enable_balloon Button
  PB_enable_balloon Menubutton
  PB_enable_balloon Menu "%W index active"
  PB_enable_balloon tixNoteBookFrame
  PB_enable_balloon Canvas
  PB_enable_balloon Listbox "%W index @%x,%y"
 }

#=======================================================================
proc PB_enable_balloon {name_to_bind {script {}}} {
    global gPB_help_tips
    if ![llength $script] {
     bind $name_to_bind <Any-Enter>  "+schedule_balloon %W %X %Y"
     bind $name_to_bind <Any-Motion> "+PB_reset_balloon %W %X %Y"
     } else {
     bind $name_to_bind <Any-Enter>  "+schedule_balloon %W %X %Y \[$script\]"
     bind $name_to_bind <Any-Motion> "+PB_reset_balloon %W %X %Y \[$script\]"
    }
    bind $name_to_bind <1>               "+PB_cancel_balloon"
    bind $name_to_bind <ButtonRelease-1> "+PB_cancel_balloon"
    bind $name_to_bind <Any-Enter>       "+PB_wait_balloon"
    bind $name_to_bind <Any-Leave>       "+PB_cancel_balloon"
    bind $name_to_bind <Any-Leave>       "+PB_wait_balloon"
   }

#=======================================================================
proc PB_disable_balloon { name_to_bind } {
  bind $name_to_bind <Any-Enter>       ""
  bind $name_to_bind <Any-Leave>       ""
  bind $name_to_bind <Any-Motion>      ""
  bind $name_to_bind <1>               ""
  bind $name_to_bind <ButtonRelease-1> ""
 }

#=======================================================================
proc PB_wait_balloon {} {
  if [winfo exists .balloon_help] {
   tkwait variable .balloon_help
  }
 }

#=======================================================================
proc PB_reset_balloon {window x y {item {}}} {
    PB_cancel_balloon
    schedule_balloon $window $x $y $item
   }

#=======================================================================
proc PB_cancel_balloon {} {
  global balloon_after_ID
  global balloon_exists
  if [info exists balloon_after_ID] {
   after cancel $balloon_after_ID
   unset balloon_after_ID
  }
  if [winfo exists .balloon_help] {
   destroy .balloon_help
  }
 }

#=======================================================================
proc schedule_balloon {window x y {item {}}} {
    global gPB_use_balloons gPB_help_tips balloon_after_ID
    if { !$gPB_use_balloons } { return }
    if [string length $item] {
     set index "$window,$item"
     } else { set index $window }
    if [info exists gPB_help_tips($index)] {
     if { $gPB_help_tips($index) == "" } { return }
     set bal_text [PB_output_EscapeSpecialControlChar_no_dollar $gPB_help_tips($index)]
     if 0 {
      set balloon_after_ID [after $gPB_help_tips(delay) \
      "catch { create_balloon \"$gPB_help_tips($index)\" $x $y; \
      after $gPB_help_tips(life) \"PB_cancel_balloon\"}"]
     }
     set balloon_after_ID [after $gPB_help_tips(delay) \
     "catch { create_balloon \"$bal_text\" $x $y; \
     after $gPB_help_tips(life) \"PB_cancel_balloon\"}"]
    }
   }

#=======================================================================
proc create_balloon {text x y} {
  global balloon_after_ID gPB_help_tips
  if {![winfo exists .balloon_help]} \
  {
   toplevel .balloon_help -relief flat -bg black -bd 1
   wm overrideredirect .balloon_help true
   wm positionfrom .balloon_help program
   set width [expr $gPB_help_tips(width) - 6] ;# To allow -padx 3 in balloon
   if 0 {
    global tcl_platform
    if {$tcl_platform(platform) == "windows"} {
     if { [font measure $gPB_help_tips(font) "$text"] > $width } {
      set cc [string length $text]
      set text_1 ""
      set jj 0
      for {set ii 0} {$ii < $cc} {incr ii} {
       if {[string index $text $ii] == " "} {
        set text_1 "$text_1[string range $text $jj [expr $ii - 1]]"
        set jj $ii
        continue
       }
       set wx  [string range $text $jj $ii]
       set wxl [font measure $gPB_help_tips(font) $wx]
       if { $wxl > $width } {
        set text_1 "$text_1[string range $text $jj [expr $ii - 1]] "
        set jj $ii
       }
      }
      set text_1 "$text_1[string range $text $jj $cc]"
      set text $text_1
     }
    }
    set wlist [split "$text" "\n"]
    set bw 0
    foreach w $wlist {
     set ww [font measure $gPB_help_tips(font) "$w"]
     if { $bw < $ww } {
      set bw $ww
     }
    }
    if {$bw > $width} {
     set bw $gPB_help_tips(width)
    }
    set dx 10
    set dy 10
    set bx [expr $x + $dx + $bw]
    if {$bx > $gPB_help_tips(screen)} {
     set bx [expr $x - $dx / 2 - $bw]
     } else {
     set bx [expr $x + $dx]
    }
   }
   label .balloon_help.lead -text " " -bg orange -pady 2
   label .balloon_help.tip  -text "$text" -wraplength $gPB_help_tips(width) \
   -bg $gPB_help_tips(color) -font $gPB_help_tips(font) \
   -bd 1 -justify left -padx 3 -pady 2
   pack .balloon_help.lead -side left -fill y
   pack .balloon_help.tip  -side left -fill both -expand yes
   set dx 10
   set dy 10
   wm geometry .balloon_help "+[expr $x + $dx]+[expr $y + $dy]"
   UI_PB_com_PositionWindow .balloon_help "non_deco"
   update idletasks
   tkwait visibility .balloon_help
  }
 }

#=======================================================================
proc getopt {arrname args} {
  global gPB
  if {[llength $args]==1} {eval set args $args}
  if {![llength $args]} return
  if {[llength $args]%2!=0} {error "$gPB(msg,odd)"}
  array set tmp $args
  foreach i [uplevel array names $arrname] {
   if [info exists tmp(-$i)] {
    uplevel set "$arrname\($i\)" $tmp(-$i)
    unset tmp(-$i)
   }
  }
  set wrong_list [array names tmp]
  if [llength $wrong_list] {
   set msg "$gPB(msg,wrong_list_1) $wrong_list. $gPB(msg,wrong_list_2)"
   foreach i [uplevel array names $arrname] {
    append msg " -$i"
   }
   error $msg
  }
 }
