home *** CD-ROM | disk | FTP | other *** search
/ Freelog Special Freeware 31 / FreelogHS31.iso / Texte / scribus / scribus-1.3.3.9-win32-install.exe / tcl / tix8.1 / Balloon.tcl next >
Text File  |  2001-11-03  |  14KB  |  591 lines
  1. # -*- mode: TCL; fill-column: 75; tab-width: 8; coding: iso-latin-1-unix -*-
  2. #
  3. #    $Id: Balloon.tcl,v 1.4.2.1 2001/11/03 07:27:12 idiscovery Exp $
  4. #
  5. # Balloon.tcl --
  6. #
  7. #    The help widget. It provides both "balloon" type of help
  8. #    message and "status bar" type of help message. You can use
  9. #    this widget to indicate the function of the widgets inside
  10. #    your application.
  11. #
  12. # Copyright (c) 1993-1999 Ioi Kim Lam.
  13. # Copyright (c) 2000-2001 Tix Project Group.
  14. #
  15. # See the file "license.terms" for information on usage and redistribution
  16. # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  17. #
  18.  
  19.  
  20. tixWidgetClass tixBalloon {
  21.     -classname TixBalloon
  22.     -superclass tixShell
  23.     -method {
  24.     bind post unbind
  25.     }
  26.     -flag {
  27.     -installcolormap -initwait -state -statusbar
  28.     }
  29.     -configspec {
  30.     {-installcolormap installColormap InstallColormap false}
  31.     {-initwait initWait InitWait 1000}
  32.     {-state state State both}
  33.     {-statusbar statusBar StatusBar ""}
  34.      {-cursor cursor Cursor left_ptr}
  35.     }
  36.     -default {
  37.     {*background             #ffff60}
  38.     {*foreground             black}
  39.     {*borderWidth             0}
  40.     {.borderWidth             1}
  41.     {.background             black}
  42.     {*Label.anchor            w}
  43.     {*Label.justify            left}
  44.     }
  45. }
  46.  
  47. # Class Record
  48. #
  49. global tixBalloon
  50. set tixBalloon(bals) ""
  51.  
  52. proc tixBalloon:InitWidgetRec {w} {
  53.     upvar #0 $w data
  54.     global tixBalloon
  55.  
  56.     tixChainMethod $w InitWidgetRec
  57.  
  58.     set data(isActive)    0
  59.     set data(client)    ""
  60.  
  61.     lappend tixBalloon(bals) $w
  62. }
  63.  
  64. proc tixBalloon:ConstructWidget {w} {
  65.     upvar #0 $w data
  66.  
  67.     tixChainMethod $w ConstructWidget
  68.  
  69.     wm overrideredirect $w 1
  70.     wm withdraw $w
  71.  
  72.     # Frame 1 : arrow
  73.     frame $w.f1 -bd 0
  74.     set data(w:label) [label $w.f1.lab -bd 0 -relief flat \
  75.                -bitmap [tix getbitmap balarrow]]
  76.     pack $data(w:label) -side left -padx 1 -pady 1
  77.     
  78.     # Frame 2 : Message
  79.     frame $w.f2 -bd 0
  80.     set data(w:message) [label $w.f2.message -padx 0 -pady 0 -bd 0]
  81.     pack $data(w:message) -side left -expand yes -fill both -padx 10 -pady 1
  82.  
  83.     # Pack all
  84.     pack $w.f1 -fill both
  85.     pack $w.f2 -fill both    
  86.  
  87.     # This is an event tag used by the clients
  88.     #
  89.     bind TixBal$w <Destroy> "tixBalloon:ClientDestroy $w %W"
  90. }
  91.  
  92. proc tixBalloon:Destructor {w} {
  93.     global tixBalloon
  94.  
  95.     set bals ""
  96.     foreach b $tixBalloon(bals) {
  97.     if {$w != $b} {
  98.         lappend bals $b
  99.     }
  100.     }
  101.     set tixBalloon(bals) $bals
  102.  
  103.     tixChainMethod $w Destructor
  104. }
  105.  
  106. #----------------------------------------------------------------------
  107. # Config:
  108. #----------------------------------------------------------------------
  109. proc tixBalloon:config-state {w value} {
  110.     upvar #0 $w data
  111.  
  112.     case $value {
  113.     {none balloon status both} ""
  114.     default {
  115.        error "invalid value $value, must be none, balloon, status, or both"
  116.     }
  117.     }
  118. }
  119.  
  120. #----------------------------------------------------------------------
  121. # "RAW" event bindings:
  122. #----------------------------------------------------------------------
  123.  
  124. bind all <B1-Motion>         "+tixBalloon_XXMotion %X %Y 1"
  125. bind all <B2-Motion>         "+tixBalloon_XXMotion %X %Y 2"
  126. bind all <B3-Motion>         "+tixBalloon_XXMotion %X %Y 3"
  127. bind all <B4-Motion>         "+tixBalloon_XXMotion %X %Y 4"
  128. bind all <B5-Motion>         "+tixBalloon_XXMotion %X %Y 5"
  129. bind all <Any-Motion>         "+tixBalloon_XXMotion %X %Y 0"
  130. # Should %b be 0? %b is illegal
  131. bind all <Leave>              "+tixBalloon_XXMotion %X %Y 0"
  132. bind all <Button>              "+tixBalloon_XXButton   %X %Y %b"
  133. bind all <ButtonRelease>    "+tixBalloon_XXButtonUp %X %Y %b"
  134.  
  135. proc tixBalloon_XXMotion {rootX rootY b} {
  136.     global tixBalloon
  137.  
  138.     foreach w $tixBalloon(bals) {
  139.     tixBalloon:XXMotion $w $rootX $rootY $b
  140.     }
  141. }
  142.  
  143. proc tixBalloon_XXButton {rootX rootY b} {
  144.     global tixBalloon
  145.  
  146.     foreach w $tixBalloon(bals) {
  147.     tixBalloon:XXButton $w $rootX $rootY $b
  148.     }
  149. }
  150.  
  151. proc tixBalloon_XXButtonUp {rootX rootY b} {
  152.     global tixBalloon
  153.  
  154.     foreach w $tixBalloon(bals) {
  155.     tixBalloon:XXButtonUp $w $rootX $rootY $b
  156.     }
  157. }
  158.  
  159.  
  160. # return true if d is a descendant of w
  161. #
  162. proc tixIsDescendant {w d} {
  163.     if {[string match $w .]} {
  164.     return 1
  165.     }
  166.     return [string match $w.* $d]
  167. }
  168.  
  169. # All the button events are fine if the ballooned widget is
  170. # a descendant of the grabbing widget
  171. #
  172. proc tixBalloon:GrabBad {w cw} {
  173.     global tixBalloon
  174.  
  175.     set g [grab current $w]
  176.     if {$g == ""} {
  177.     return 0
  178.     }
  179.     if {[info exists tixBalloon(g_ignore,$g)]} {
  180.     return 1
  181.     }
  182.     if {[info exists tixBalloon(g_ignore,[winfo class $g])]} {
  183.     return 1
  184.     }
  185.     if {$g == $cw || [tixIsDescendant $g $cw]} {
  186.     return 0
  187.     }
  188.     return 1
  189. }
  190.  
  191. proc tixBalloon:XXMotion {w rootX rootY b} {
  192.     upvar #0 $w data
  193.  
  194.     if {![info exists data(-state)]} {
  195.     # puts "tixBalloon:XXMotion called without a state\n$w"
  196.     set data(state) none
  197.     return
  198.     }
  199.     if {$data(-state) == "none"} {
  200.     return
  201.     }
  202.  
  203.     if {$b == 0} {
  204.     if {[info exists data(b:1)]} {unset data(b:1)}
  205.     if {[info exists data(b:2)]} {unset data(b:2)}
  206.     if {[info exists data(b:3)]} {unset data(b:3)}
  207.     if {[info exists data(b:4)]} {unset data(b:4)}
  208.     if {[info exists data(b:5)]} {unset data(b:5)}
  209.     }
  210.  
  211.  
  212.     if {[array names data b:*] != ""} {
  213.     # Some buttons are down. Do nothing
  214.     #
  215.     return
  216.     }
  217.  
  218.     set cw [winfo containing -displayof $w $rootX $rootY]
  219.     if {[tixBalloon:GrabBad $w $cw]} {
  220.     return
  221.     }
  222.  
  223.     # Find the a client window that matches
  224.     #
  225.     if {$w == $cw || [string match $w.* $cw]} {
  226.     # Cursor moved over the balloon -- Ignore
  227.     return
  228.     }
  229.  
  230.     while {$cw != ""} {
  231.     if {[info exists data(m:$cw)]} {
  232.         set client $cw
  233.         break
  234.     } else {
  235.         set cw [winfo parent $cw]
  236.     }
  237.     }
  238.     if {![info exists client]} {
  239.     # The cursor is at a position covered by a non-client
  240.     # Popdown the balloon if it is up
  241.     if {$data(isActive)} {
  242.         tixBalloon:Deactivate $w
  243.     }
  244.     set data(client) ""
  245.     if {[info exists data(cancel)]} {
  246.         unset data(cancel) 
  247.     }
  248.     return
  249.     }
  250.  
  251.     if {$data(client) != $client} {
  252.     if {$data(isActive)} {
  253.         tixBalloon:Deactivate $w
  254.     }
  255.     set data(client) $client
  256.     after $data(-initwait) tixBalloon:SwitchToClient $w $client
  257.     }
  258. }
  259.  
  260. proc tixBalloon:XXButton {w rootX rootY b} {
  261.     upvar #0 $w data
  262.  
  263.     tixBalloon:XXMotion $w $rootX $rootY $b
  264.  
  265.     set data(b:$b) 1
  266.  
  267.     if {$data(isActive)} {
  268.     tixBalloon:Deactivate $w
  269.     } else {
  270.     set data(cancel) 1
  271.     }
  272. }
  273.  
  274. proc tixBalloon:XXButtonUp {w rootX rootY b} {
  275.     upvar #0 $w data
  276.  
  277.     tixBalloon:XXMotion $w $rootX $rootY $b
  278.     if {[info exists data(b:$b)]} {
  279.     unset data(b:$b)
  280.     }
  281. }
  282.  
  283. #----------------------------------------------------------------------
  284. # "COOKED" event bindings:
  285. #----------------------------------------------------------------------
  286.  
  287. # switch the balloon to a new client
  288. #
  289. proc tixBalloon:SwitchToClient {w client} {
  290.     upvar #0 $w data
  291.  
  292.     if {![winfo exists $w]} {
  293.     return
  294.     }
  295.     if {![winfo exists $client]} {
  296.     return
  297.     }
  298.     if {$client != $data(client)} {
  299.     return
  300.     }
  301.     if {[info exists data(cancel)]} {
  302.     unset data(cancel)
  303.     return
  304.     }
  305.  
  306.     if {[tixBalloon:GrabBad $w $w]} {
  307.     return
  308.     }
  309.  
  310.     tixBalloon:Activate $w
  311. }
  312.  
  313. proc tixBalloon:ClientDestroy {w client} {
  314.     if {![winfo exists $w]} {
  315.     return
  316.     }
  317.  
  318.     upvar #0 $w data
  319.  
  320.     if {$data(client) == $client} {
  321.     tixBalloon:Deactivate $w
  322.     set data(client) ""
  323.     }
  324.  
  325.     # Maybe thses have already been unset by the Destroy method
  326.     #
  327.     if {[info exists data(m:$client)]} {unset data(m:$client)}
  328.     if {[info exists data(s:$client)]} {unset data(s:$client)}
  329. }
  330.  
  331. #----------------------------------------------------------------------
  332. # Popping up balloon:
  333. #----------------------------------------------------------------------
  334. proc tixBalloon:Activate {w} {
  335.     upvar #0 $w data
  336.  
  337.     if {[tixBalloon:GrabBad $w $w]} {
  338.     return
  339.     }
  340.     if {[winfo containing -displayof $w \
  341.         [winfo pointerx $w] [winfo pointery $w]] == ""} {
  342.     return
  343.     }
  344.  
  345.     if {![info exists data(-state)]} {
  346.     # puts "tixBalloon:Activate called without a state\n$w"
  347.     set data(state) none
  348.     return
  349.     }
  350.     if {$data(-state) == "none"} {
  351.     return
  352.     }
  353.  
  354.     switch $data(-state) {
  355.     "both" {
  356.         tixBalloon:PopUp $w
  357.         tixBalloon:SetStatus $w
  358.     }
  359.     "balloon" {
  360.         tixBalloon:PopUp $w
  361.     }
  362.     "status" {
  363.         tixBalloon:SetStatus $w
  364.     }
  365.     }
  366.  
  367.     set data(isActive) 1
  368.  
  369.     after 200 tixBalloon:Verify $w
  370. }
  371.  
  372.  
  373. # %% Perhaps this is no more needed
  374. #
  375. proc tixBalloon:Verify {w} {
  376.     upvar #0 $w data
  377.  
  378.     if {![winfo exists $w]} {
  379.     return
  380.     }
  381.     if {!$data(isActive)} {
  382.     return
  383.     }
  384.  
  385.     if {[tixBalloon:GrabBad $w $w]} {
  386.     tixBalloon:Deactivate $w
  387.     return
  388.     }
  389.     if {[winfo containing -displayof $w \
  390.         [winfo pointerx $w] [winfo pointery $w]] == ""} {
  391.     tixBalloon:Deactivate $w
  392.     return
  393.     }
  394.     after 200 tixBalloon:Verify $w
  395. }
  396.  
  397. proc tixBalloon:Deactivate {w} {
  398.     upvar #0 $w data
  399.  
  400.     tixBalloon:PopDown $w
  401.     tixBalloon:ClearStatus $w
  402.     set data(isActive) 0
  403.     if {[info exists data(cancel)]} {
  404.     unset data(cancel)
  405.     }
  406. }
  407.  
  408. proc tixBalloon:PopUp {w} {
  409.     upvar #0 $w data
  410.  
  411.     if {[tixGetBoolean -nocomplain $data(-installcolormap)]} {
  412.     wm colormapwindows [winfo toplevel $data(client)] $w
  413.     }
  414.  
  415.     # trick: the following lines allow the balloon window to
  416.     # acquire a stable width and height when it is finally
  417.     # put on the visible screen
  418.     #
  419.     set client $data(client)
  420.     if {$data(m:$client) == ""} {return ""}
  421.  
  422.     $data(w:message) config -text $data(m:$client)
  423.     wm geometry $w +10000+10000
  424.     wm deiconify $w
  425.     raise $w
  426.     update
  427.  
  428.     # The windows may become destroyed as a result of the "update" command
  429.     #
  430.     if {![winfo exists $w]} {
  431.     return
  432.     }
  433.     if {![winfo exists $client]} {
  434.     return
  435.     }
  436.     # Put it on the visible screen
  437.     #
  438.     set x [expr [winfo rootx $client]+[winfo width  $client]/2]
  439.     set y [expr int([winfo rooty $client]+[winfo height $client]/1.3)]
  440.  
  441.     set width  [winfo reqwidth $w]
  442.     set height [winfo reqheight $w]
  443.     set scrwidth  [winfo vrootwidth  $w]
  444.     set scrheight [winfo vrootheight $w]
  445.  
  446.     # If the balloon is too far right, pull it back to the left
  447.     #
  448.     if {[expr {$x + $width}] > $scrwidth} {
  449.     set x [expr {$scrwidth - $width}]
  450.     }
  451.  
  452.     # If the balloon is too far left, pull it back to the right
  453.     #
  454.     if {$x < 0} {
  455.     set x 0
  456.     }
  457.  
  458.     # If the listbox is below bottom of screen, put it upwards
  459.     #
  460.     if {[expr {$y + $height}] > $scrheight} {
  461.     set y [expr {$scrheight-$height}]
  462.     }
  463.     if {$y < 0} {
  464.     set y 0
  465.     }
  466.  
  467.     wm geometry $w +$x+$y
  468.     after idle raise $w
  469. }
  470.  
  471. proc tixBalloon:PopDown {w} {
  472.     upvar #0 $w data
  473.  
  474.     # Close the balloon
  475.     #
  476.     wm withdraw $w
  477.  
  478.     # We don't set the data(client) to be zero, so that the balloon
  479.     # will re-appear only if you move out then in the client window
  480.     # set data(client) ""
  481. }
  482.  
  483. proc tixBalloon:SetStatus {w} {
  484.     upvar #0 $w data
  485.  
  486.     if {![winfo exists $data(-statusbar)]} {
  487.     return
  488.     }
  489.     if {![info exists data(s:$data(client))]} {
  490.     return
  491.     }
  492.  
  493.     set vv [$data(-statusbar) cget -textvariable]
  494.     if {$vv == ""} {
  495.     $data(-statusbar) config -text $data(s:$data(client))
  496.     } else {
  497.     uplevel #0 set $vv [list $data(s:$data(client))]
  498.     }
  499. }
  500.  
  501. proc tixBalloon:ClearStatus {w} {
  502.     upvar #0 $w data
  503.  
  504.     if {![winfo exists $data(-statusbar)]} {
  505.     return
  506.     }
  507.  
  508.     # Clear the StatusBar widget
  509.     #
  510.     set vv [$data(-statusbar) cget -textvariable]
  511.     if {$vv == ""} {
  512.     $data(-statusbar) config -text ""
  513.     } else {
  514.     uplevel #0 set $vv [list ""]
  515.     }
  516. }
  517.  
  518. #----------------------------------------------------------------------
  519. # PublicMethods:
  520. #----------------------------------------------------------------------
  521.  
  522. # %% if balloon is already popped-up for this client, change mesage
  523. #
  524. proc tixBalloon:bind {w client args} {
  525.     upvar #0 $w data
  526.  
  527.     if {[info exists data(m:$client)]} {
  528.     set alreadyBound 1
  529.     } else {
  530.     set alreadyBound 0
  531.     }
  532.  
  533.     set opt(-balloonmsg) ""
  534.     set opt(-statusmsg)  ""
  535.     set opt(-msg)        ""
  536.  
  537.     tixHandleOptions opt {-balloonmsg -msg -statusmsg} $args
  538.  
  539.     if {$opt(-balloonmsg) != ""} {
  540.     set data(m:$client) $opt(-balloonmsg)
  541.     } else {
  542.     set data(m:$client) $opt(-msg)
  543.     }
  544.     if {$opt(-statusmsg) != ""} {
  545.     set data(s:$client) $opt(-statusmsg)
  546.     } else {
  547.     set data(s:$client) $opt(-msg)
  548.     }
  549.  
  550.     tixAppendBindTag $client TixBal$w
  551. }
  552.  
  553. proc tixBalloon:post {w client} {
  554.     upvar #0 $w data
  555.  
  556.     if {![info exists data(m:$client)] || $data(m:$client) == ""} {
  557.     return
  558.     }
  559.     tixBalloon:Enter $w $client
  560.     incr data(fakeEnter)
  561. }
  562.  
  563. proc tixBalloon:unbind {w client} {
  564.     upvar #0 $w data
  565.  
  566.     if {[info exists data(m:$client)]} {
  567.     if {[info exists data(m:$client)]} {unset data(m:$client)}
  568.     if {[info exists data(s:$client)]} {unset data(s:$client)}
  569.  
  570.     if {[winfo exists $client]} {
  571.         catch {tixDeleteBindTag $client TixBal$w}
  572.     }
  573.     }
  574. }
  575.  
  576. #----------------------------------------------------------------------
  577. #
  578. # Utility function
  579. #
  580. #----------------------------------------------------------------------
  581. #
  582. # $w can be a widget name or a classs name
  583. proc tixBalIgnoreWhenGrabbed {wc} {
  584.     global tixBalloon
  585.     set tixBalloon(g_ignore,$wc) ""
  586. }
  587.  
  588. tixBalIgnoreWhenGrabbed TixComboBox
  589. tixBalIgnoreWhenGrabbed Menu
  590. tixBalIgnoreWhenGrabbed Menubutton
  591.