proc ::tooltip4::cget {args} {

  # Gets the tooltip's option values.
  #   args - option names (if empty, returns all options)
  # Returns a list of "name value" pairs.

  if {![llength $args]} {
    lappend args -on -per10 -fade -pause -fg -bg -bd -padx -pady -padding  -font -alpha -text -index -tag
  }
  set res [list]
  foreach n $args {
    set n [string range $n 1 end]
    if {[info exists my::ttdata($n)]} {
      lappend res -$n $my::ttdata($n)
    }
  }
  return $res
}

proc ::tooltip4::configure {args} {

  # Configurates the tooltip for all widgets.
  #   args - options ("name value" pairs)
  # The following options are special:
  #    -force - if true, forces the display by 'tooltip' command
  #    -index - index of menu item to tip
  #    -tag - name of text tag to tip
  #    -geometry - geometry (+X+Y) of the balloon
  # Returns the list of -force, -geometry, -index, -tag option values.

  set force 0
  set index -1
  set geo [set tag ""]
  foreach {n v} $args {
    switch -glob -- $n {
      -per10 - -fade - -pause - -fg - -bg - -bd - -alpha - -text -  -on - -padx - -pady - -padding {
        set my::ttdata([string range $n 1 end]) $v
      }
      -font {foreach {k v} $v {dict set my::ttdata(font) $k $v}}
      -force {set force $v}
      -index {set index $v}
      -tag {set tag $v}
      -geometry {set geo $v}
      default {return -code error "invalid option \"$n\""}
    }
  }
  return [list $force $geo $index $tag]
}

proc ::tooltip4::hide {{w {}}} {

  # Destroys the tooltip's window.
  #   w - the tooltip's parent window
  # Returns 1, if the window was really hidden.

  return [expr {![catch {destroy $w.$my::ttdata(wttip)}]}]
}

proc ::tooltip4::repaint {w} {

  # Repaints a tooltip immediately.
  #   w - widget's path

  if {[winfo exists $w] && [info exists my::ttdata(optvals,$w)]} {
    ::tooltip4::my::Show $w [dict get $my::ttdata(optvals,$w) -text] yes  {} $my::ttdata(optvals,$w)
  }
}

proc ::tooltip4::tooltip {w text args} {

  # Creates a tooltip for a widget.
  #   w - the parent widget's path
  #   text - the tooltip text
  #   args - options ("name value" pairs)

  if {[winfo exists $w] || $w eq ""} {
    set arrsaved [array get my::ttdata]
    set optvals [::tooltip4::my::CGet {*}$args]
    lassign $optvals forced geo index ttag
    set optvals [lrange $optvals 4 end]
    set my::ttdata(optvals,$w) [dict set optvals -text $text]
    set my::ttdata(on,$w) [expr {[string length $text]}]
    set my::ttdata(global,$w) no
    if {$text ne ""} {
      if {$forced || $geo ne ""} {::tooltip4::my::Show $w $text yes $geo $optvals}
      if {$geo ne ""} {
        array set my::ttdata $arrsaved  ;# balloon popup
      } else {
        set tags [bindtags $w]
        if {[lsearch -exact $tags "Tooltip$w"] == -1} {
          bindtags $w [linsert $tags end "Tooltip$w"]
        }
        bind Tooltip$w <Any-Leave>    [list ::tooltip4::hide $w]
        bind Tooltip$w <Any-KeyPress> [list ::tooltip4::hide $w]
        bind Tooltip$w <Any-Button>   [list ::tooltip4::hide $w]
        if {$index>-1} {
          set my::ttdata($w,$index) $text
          set my::ttdata(LASTMITEM) ""
          bind Menu <<MenuSelect>> [list + ::tooltip4::my::MenuTip $w %W $optvals]
        } elseif {$ttag ne ""} {
          set ::tooltip4::my::ttdata($w,$ttag) "$text"
          $w tag bind $ttag <Enter> [list + ::tooltip4::my::TagTip $w $ttag $optvals]
          foreach event {Leave KeyPress Button} {
            $w tag bind $ttag <Any-$event> [list + ::tooltip4::my::TagTip $w]
          }
        } else {
          bind Tooltip$w <Enter> [list ::tooltip4::my::Show %W $text no $geo $optvals]
        }
      }
    }
  }
}

proc ::tooltip4::update {{w {}}} {

  # Updates tooltips' settings according to the global settings.
  #   w - widget's path (if omitted, updates all widgets' tooltips)

  if {$w eq ""} {
    foreach k [array names my::ttdata -glob on,*] {
      set w [lindex [split $k ,] 1]
      set my::ttdata(global,$w) yes
    }
  } else {
    set my::ttdata(global,$w) yes
  }
}

proc ::tooltip4::my::CGet {args} {

  # Gets options' values, using local (args) and global (ttdata) settings.
  #   args - local settings ("name value" pairs)
  # Returns the full list of settings ("name value" pairs, "name" without "-")  in which -force and -geometry option values go first.

  variable ttdata
  set saved [array get ttdata]
  set res [::tooltip4::configure {*}$args]
  lappend res {*}[::tooltip4::cget]
  array set ttdata $saved
  return $res
}

proc ::tooltip4::my::Fade {w aint fint icount Un alpha geo show} {

  # Fades/unfades the tooltip's window.
  #   w - the tooltip's window
  #   aint - interval for 'after'
  #   fint - interval for fading
  #   icount - counter of intervals
  #   Un - if equal to "Un", unfades the tooltip
  #   alpha - value of -alpha option
  #   geo - coordinates (+X+Y) of tooltip
  #   show - flag "show the window"
  # See also: FadeNext, UnFadeNext

  update
  if {[winfo exists $w]} {
    after idle [list after $aint  [list ::tooltip4::my::${Un}FadeNext $w $aint $fint $icount $alpha $geo $show]]
  }
}

proc ::tooltip4::my::FadeNext {w aint fint icount alpha geo show} {

  # A step to fade the tooltip's window.
  #   w - the tooltip's window
  #   aint - interval for 'after'
  #   fint - interval for fading
  #   icount - counter of intervals
  #   alpha - value of -alpha option
  #   geo - coordinates (+X+Y) of tooltip
  #   show - flag "show the window"
  # See also: Fade

  incr icount -1
  if {$show} {
    ShowWindow $w $geo
    set show 0
  }
  if {$icount<0} {
    set al [expr {min($alpha,($fint+$icount*1.5)/$fint)}]
    if {$al>0} {
      if {[catch {wm attributes $w -alpha $al}]} {set al 0}
    }
    if {$al<=0 || ![winfo exists $w]} {
      catch {destroy $w}
      return
    }
  }
  Fade $w $aint $fint $icount {} $alpha $geo $show
}

proc ::tooltip4::my::MenuTip {w wt optvals} {

    # Shows a menu's tooltip.
    #   w - the menu's path
    #   wt - the menu's path (incl. tearoff menu)
    #   optvals - settings of tooltip

    variable ttdata
    set index [$wt index active]
    set mit "$w/$index"
  	if {[info exists ttdata($w,$index)] && ([::tooltip4::hide $w] ||  ![info exists ttdata(LASTMITEM)] || $ttdata(LASTMITEM) ne $mit)} {
      set text $ttdata($w,$index)
      after $ttdata(fade) [list ::tooltip4::my::Show $w $text yes {} $optvals]
    }
  	set ttdata(LASTMITEM) $mit
}

proc ::tooltip4::my::Show {w text force geo optvals} {

  # Creates and shows the tooltip's window.
  #   w - the parent widget's path
  #   text - the tooltip text
  #   force - if true, re-displays the existing tooltip
  #   geo - being +X+Y, sets the tooltip coordinates
  #   optvals - settings ("option value" pairs)

  variable ttdata
  if {$w ne "" && ![winfo exists $w]} return
  set win $w.$ttdata(wttip)
  set px [winfo pointerx .]
  set py [winfo pointery .]
  if {$ttdata(global,$w)} {
    array set data [::tooltip4::cget]
  } else {
    array set data $optvals
  }
  if {!$force && $geo eq "" && [winfo class $w] ne "Menu" &&  ([winfo exists $win] || ![info exists ttdata(on,$w)] || !$ttdata(on,$w) ||  ![string match $w [winfo containing $px $py]])} {
    return
  }
  ::tooltip4::hide $w
  if {![string length [string trim $text]] || !$ttdata(on) || !$data(-on)} return
  lappend ttdata(REGISTERED) $w
  foreach wold [lrange $ttdata(REGISTERED) 0 end-1] {::tooltip4::hide $wold}
  toplevel $win -bg $data(-bg) -class Tooltip$w
  catch {wm withdraw $win}
  wm overrideredirect $win 1
  wm attributes $win -topmost 1
  pack [label $win.label -text $text -justify left -relief solid  -bd $data(-bd) -bg $data(-bg) -fg $data(-fg) -font $data(-font)  -padx $data(-padx) -pady $data(-pady)] -padx $data(-padding) -pady $data(-padding)
  # defeat rare artifact by passing mouse over a tooltip to destroy it
  bindtags $win "Tooltip$win"
  bind $win <Any-Enter>  [list ::tooltip4::hide $w]
  bind Tooltip$win <Any-Enter>  [list ::tooltip4::hide $w]
  bind Tooltip$win <Any-Button> [list ::tooltip4::hide $w]
  set aint 20
  set fint [expr {int($data(-fade)/$aint)}]
  set icount [expr {int($data(-per10)/$aint*[string length $text]/10.0)}]
  if {$icount} {
    if {$geo eq ""} {
      catch {wm attributes $win -alpha $data(-alpha)}
    } else {
      ::tooltip4::my::Fade $win $aint [expr {round(1.0*$data(-pause)/$aint)}]  0 Un $data(-alpha) $geo 1
    }
    after $data(-pause) [list  ::tooltip4::my::Fade $win $aint $fint $icount {} $data(-alpha) $geo 1]
  } else {
    # just showing, no fading
    after $data(-pause) [list ::tooltip4::my::ShowWindow $win $geo]
  }
  array unset data
}

proc ::tooltip4::my::ShowWindow {win geo} {

  # Shows a window of tooltip.
  #   win - the tooltip's window
  #   geo - being +X+Y, sets the tooltip coordinates

  if {![winfo exists $win]} return
  set w [winfo parent $win]
  set px [winfo pointerx .]
  set py [winfo pointery .]
  set width [winfo reqwidth $win.label]
  set height [winfo reqheight $win.label]
  set ady 0
  if {[catch {set wheight [winfo height $w]}]} {
    set wheight 0
  } else {
    for {set i 0} {$i<$wheight} {incr i} {  ;# find the widget's bottom
      incr py
      incr ady
      if {![string match $w [winfo containing $px $py]]} break
    }
  }
  if {$geo eq ""} {
    set x [expr {max(1,$px - round($width / 2.0))}]
    set y [expr {$py + 16 - $ady}]
  } else {
    lassign [split $geo +] -> x y
    set x [expr [string map "W $width" $x]]  ;# W to shift horizontally
    set y [expr [string map "H $height" $y]] ;# H to shift vertically
    set py [expr {$y-16}]
  }
  # check for edges of screen incl. decors
  set scrw [winfo screenwidth .]
  set scrh [winfo screenheight .]
  if {($x + $width) > $scrw}  {set x [expr {$scrw - $width - 1}]}
  if {($y + $height) > ($scrh-36)} {set y [expr {$py - $wheight - $height}]}
  wm geometry $win [join  "$width x $height + $x + $y" {}]
  catch {wm deiconify $win ; raise $win}
}

proc ::tooltip4::my::TagTip {w {tag {}} {optvals {}}} {

  # Shows a text tag's tooltip.
  #   w - the text's path
  #   tag - the tag's name
  #   optvals - settings of tooltip

  variable ttdata
  if {$tag eq ""} {set text ""} {set text $ttdata($w,$tag)}
  ::tooltip4::my::Show $w $text yes {} $optvals
}

proc ::tooltip4::my::UnFadeNext {w aint fint icount alpha geo show} {

  # A step to unfade the tooltip's window.
  #   w - the tooltip's window
  #   aint - interval for 'after'
  #   fint - interval for fading
  #   icount - counter of intervals
  #   alpha - value of -alpha option
  #   geo - coordinates (+X+Y) of tooltip
  #   show - not used (here just for compliance with Fade)
  # See also: Fade

  incr icount
  set al [expr {min($alpha,$icount*1.5/$fint)}]
  if {$al<$alpha && [catch {wm attributes $w -alpha $al}]} {set al 1}
  if {$show} {
    ShowWindow $w $geo
    set show 0
  }
  if {[winfo exists $w] && $al<$alpha} {
    Fade $w $aint $fint $icount Un $alpha $geo 0
  }
}