home *** CD-ROM | disk | FTP | other *** search
/ PC World 2002 May / PCWorld_2002-05_cd.bin / Software / TemaCD / activetcltk / ActiveTcl8.3.4.1-8.win32-ix86.exe / ActiveTcl8.3.4.1-win32-ix86 / lib / bwidget1.3.0 / dynhelp.tcl < prev    next >
Encoding:
Text File  |  2001-10-22  |  11.6 KB  |  349 lines
  1. # ------------------------------------------------------------------------------
  2. #  dynhelp.tcl
  3. #  This file is part of Unifix BWidget Toolkit
  4. #  $Id: dynhelp.tcl,v 1.7 2001/06/11 23:58:40 hobbs Exp $
  5. # ------------------------------------------------------------------------------
  6. #  Index of commands:
  7. #     - DynamicHelp::configure
  8. #     - DynamicHelp::include
  9. #     - DynamicHelp::sethelp
  10. #     - DynamicHelp::register
  11. #     - DynamicHelp::_motion_balloon
  12. #     - DynamicHelp::_motion_info
  13. #     - DynamicHelp::_leave_info
  14. #     - DynamicHelp::_menu_info
  15. #     - DynamicHelp::_show_help
  16. #     - DynamicHelp::_init
  17. # ------------------------------------------------------------------------------
  18.  
  19. namespace eval DynamicHelp {
  20.     Widget::declare DynamicHelp {
  21.         {-foreground  TkResource black         0 label}
  22.         {-background  TkResource "#FFFFC0"     0 label}
  23.         {-borderwidth TkResource 1             0 label}
  24.         {-justify     TkResource left          0 label}
  25.         {-font        TkResource "helvetica 8" 0 label}
  26.         {-delay       Int        600           0 "%d >= 100 & %d <= 2000"}
  27.         {-bd          Synonym    -borderwidth}
  28.         {-bg          Synonym    -background}
  29.         {-fg          Synonym    -foreground}
  30.     }
  31.  
  32.     proc use {} {}
  33.  
  34.     variable _registered
  35.  
  36.     variable _top     ".help_shell"
  37.     variable _id      "" 
  38.     variable _delay   600
  39.     variable _current ""
  40.     variable _saved
  41.  
  42.     Widget::init DynamicHelp $_top {}
  43.  
  44.     bind BwHelpBalloon <Enter>   {DynamicHelp::_motion_balloon enter  %W %X %Y}
  45.     bind BwHelpBalloon <Motion>  {DynamicHelp::_motion_balloon motion %W %X %Y}
  46.     bind BwHelpBalloon <Leave>   {DynamicHelp::_motion_balloon leave  %W %X %Y}
  47.     bind BwHelpBalloon <Button>  {DynamicHelp::_motion_balloon button %W %X %Y}
  48.     bind BwHelpBalloon <Destroy> {if {[info exists DynamicHelp::_registered(%W)]} {unset DynamicHelp::_registered(%W)}}
  49.  
  50.     bind BwHelpVariable <Enter>   {DynamicHelp::_motion_info %W}
  51.     bind BwHelpVariable <Motion>  {DynamicHelp::_motion_info %W}
  52.     bind BwHelpVariable <Leave>   {DynamicHelp::_leave_info  %W}
  53.     bind BwHelpVariable <Destroy> {if {[info exists DynamicHelp::_registered(%W)]} {unset DynamicHelp::_registered(%W)}}
  54.  
  55.     bind BwHelpMenu <<MenuSelect>> {DynamicHelp::_menu_info select %W}
  56.     bind BwHelpMenu <Unmap>        {DynamicHelp::_menu_info unmap  %W}
  57.     bind BwHelpMenu <Destroy>      {if {[info exists DynamicHelp::_registered(%W)]} {unset DynamicHelp::_registered(%W)}}
  58. }
  59.  
  60.  
  61. # ------------------------------------------------------------------------------
  62. #  Command DynamicHelp::configure
  63. # ------------------------------------------------------------------------------
  64. proc DynamicHelp::configure { args } {
  65.     variable _top
  66.     variable _delay
  67.  
  68.     set res [Widget::configure $_top $args]
  69.     if { [Widget::hasChanged $_top -delay val] } {
  70.         set _delay $val
  71.     }
  72.  
  73.     return $res
  74. }
  75.  
  76.  
  77. # ------------------------------------------------------------------------------
  78. #  Command DynamicHelp::include
  79. # ------------------------------------------------------------------------------
  80. proc DynamicHelp::include { class type } {
  81.     set helpoptions [list \
  82.         [list -helptext String "" 0] \
  83.         [list -helpvar  String "" 0] \
  84.         [list -helptype Enum $type 0 [list balloon variable]] \
  85.         ]
  86.     Widget::declare $class $helpoptions
  87. }
  88.  
  89.  
  90. # ------------------------------------------------------------------------------
  91. #  Command DynamicHelp::sethelp
  92. # ------------------------------------------------------------------------------
  93. proc DynamicHelp::sethelp { path subpath {force 0}} {
  94.     foreach {ctype ctext cvar} [Widget::hasChangedX $path \
  95.         -helptype -helptext -helpvar] break
  96.     if { $force || $ctype || $ctext || $cvar } {
  97.     set htype [Widget::cget $path -helptype]
  98.         switch $htype {
  99.             balloon {
  100.                 return [register $subpath balloon \
  101.             [Widget::cget $path -helptext]]
  102.             }
  103.             variable {
  104.                 return [register $subpath variable \
  105.             [Widget::cget $path -helpvar] \
  106.             [Widget::cget $path -helptext]]
  107.             }
  108.         }
  109.         return [register $subpath $htype]
  110.     }
  111. }
  112.  
  113.  
  114. # ------------------------------------------------------------------------------
  115. #  Command DynamicHelp::register
  116. # ------------------------------------------------------------------------------
  117. proc DynamicHelp::register { path type args } {
  118.     variable _registered
  119.  
  120.     if { [winfo exists $path] } {
  121.         set evt  [bindtags $path]
  122.         set idx  [lsearch $evt "BwHelp*"]
  123.         set evt  [lreplace $evt $idx $idx]
  124.         switch $type {
  125.             balloon {
  126.                 set text [lindex $args 0]
  127.                 if { $text != "" } {
  128.                     set _registered($path) $text
  129.                     lappend evt BwHelpBalloon
  130.                 } else {
  131.                     if {[info exists _registered($path)]} {
  132.                         unset _registered($path)
  133.                     }
  134.                 }
  135.                 bindtags $path $evt
  136.                 return 1
  137.             }
  138.  
  139.             variable {
  140.                 set var  [lindex $args 0]
  141.                 set text [lindex $args 1]
  142.                 if { $text != "" && $var != "" } {
  143.                     set _registered($path) [list $var $text]
  144.                     lappend evt BwHelpVariable
  145.                 } else {
  146.                     if {[info exists _registered($path)]} { 
  147.                         unset _registered($path)
  148.                     }
  149.                 }
  150.                 bindtags $path $evt
  151.                 return 1
  152.             }
  153.  
  154.             menu {
  155.                 set cpath [BWidget::clonename $path]
  156.                 if { [winfo exists $cpath] } {
  157.                     set path $cpath
  158.                 }
  159.                 set var [lindex $args 0]
  160.                 if { $var != "" } {
  161.                     set _registered($path) [list $var]
  162.                     lappend evt BwHelpMenu
  163.                 } else {
  164.                     if {[info exists _registered($path)]} {
  165.                         unset _registered($path)
  166.                     }
  167.                 }
  168.                 bindtags $path $evt
  169.                 return 1
  170.             }
  171.  
  172.             menuentry {
  173.                 set cpath [BWidget::clonename $path]
  174.                 if { [winfo exists $cpath] } {
  175.                     set path $cpath
  176.                 }
  177.                 if { [info exists _registered($path)] } {
  178.                     if { [set index [lindex $args 0]] != "" } {
  179.                         set text  [lindex $args 1]
  180.                         set idx   [lsearch $_registered($path) [list $index *]]
  181.                         if { $text != "" } {
  182.                             if { $idx == -1 } {
  183.                                 lappend _registered($path) [list $index $text]
  184.                             } else {
  185.                                 set _registered($path) [lreplace $_registered($path) $idx $idx [list $index $text]]
  186.                             }
  187.                         } else {
  188.                             set _registered($path) [lreplace $_registered($path) $idx $idx]
  189.                         }
  190.                     }
  191.                     return 1
  192.                 }
  193.                 return 0
  194.             }
  195.         }
  196.         if {[info exists _registered($path)]} {
  197.             unset _registered($path)
  198.         }
  199.         bindtags $path $evt
  200.         return 1
  201.     } else {
  202.         if {[info exists _registered($path)]} {
  203.             unset _registered($path)
  204.         }
  205.         return 0
  206.     }
  207. }
  208.  
  209.  
  210. # ------------------------------------------------------------------------------
  211. #  Command DynamicHelp::_motion_balloon
  212. # ------------------------------------------------------------------------------
  213. proc DynamicHelp::_motion_balloon { type path x y } {
  214.     variable _top
  215.     variable _id
  216.     variable _delay
  217.     variable _current
  218.  
  219.     if { $_current != $path && $type == "enter" } {
  220.         set _current $path
  221.         set type "motion"
  222.         destroy $_top
  223.     }
  224.     if { $_current == $path } {
  225.         if { $_id != "" } {
  226.             after cancel $_id
  227.             set _id ""
  228.         }
  229.         if { $type == "motion" } {
  230.             if { ![winfo exists $_top] } {
  231.                 set _id [after $_delay "DynamicHelp::_show_help $path $x $y"]
  232.             }
  233.         } else {
  234.             destroy $_top
  235.             set _current ""
  236.         }
  237.     }
  238. }
  239.  
  240.  
  241. # ------------------------------------------------------------------------------
  242. #  Command DynamicHelp::_motion_info
  243. # ------------------------------------------------------------------------------
  244. proc DynamicHelp::_motion_info { path } {
  245.     variable _registered
  246.     variable _current
  247.     variable _saved
  248.  
  249.     if { $_current != $path && [info exists _registered($path)] } {
  250.         if { ![info exists _saved] } {
  251.             set _saved [GlobalVar::getvar [lindex $_registered($path) 0]]
  252.         }
  253.         GlobalVar::setvar [lindex $_registered($path) 0] [lindex $_registered($path) 1]
  254.         set _current $path
  255.     }
  256. }
  257.  
  258.  
  259. # ------------------------------------------------------------------------------
  260. #  Command DynamicHelp::_leave_info
  261. # ------------------------------------------------------------------------------
  262. proc DynamicHelp::_leave_info { path } {
  263.     variable _registered
  264.     variable _current
  265.     variable _saved
  266.  
  267.     if { [info exists _registered($path)] } {
  268.         GlobalVar::setvar [lindex $_registered($path) 0] $_saved
  269.     }
  270.     unset _saved
  271.     set _current ""
  272.     
  273. }
  274.  
  275.  
  276. # ------------------------------------------------------------------------------
  277. #  Command DynamicHelp::_menu_info
  278. #    Version of R1v1 restored, due to lack of [winfo ismapped] and <Unmap>
  279. #    under windows for menu.
  280. # ------------------------------------------------------------------------------
  281. proc DynamicHelp::_menu_info { event path } {
  282.     variable _registered
  283.  
  284.     if { [info exists _registered($path)] } {
  285.         set index [$path index active]
  286.         if { [string compare $index "none"] &&
  287.              [set idx [lsearch $_registered($path) [list $index *]]] != -1 } {
  288.             GlobalVar::setvar [lindex $_registered($path) 0] \
  289.                 [lindex [lindex $_registered($path) $idx] 1]
  290.         } else {
  291.             GlobalVar::setvar [lindex $_registered($path) 0] ""
  292.         }
  293.     }
  294. }
  295.  
  296.  
  297. # ------------------------------------------------------------------------------
  298. #  Command DynamicHelp::_show_help
  299. # ------------------------------------------------------------------------------
  300. proc DynamicHelp::_show_help { path x y } {
  301.     variable _top
  302.     variable _registered
  303.     variable _id
  304.     variable _delay
  305.  
  306.     if { [info exists _registered($path)] } {
  307.         destroy  $_top
  308.         toplevel $_top -relief flat \
  309.             -bg [Widget::getoption $_top -foreground] \
  310.             -bd [Widget::getoption $_top -borderwidth] \
  311.             -screen [winfo screen $path]
  312.  
  313.         wm overrideredirect $_top 1
  314.         wm transient $_top
  315.         wm withdraw $_top
  316.  
  317.         label $_top.label -text $_registered($path) \
  318.             -relief flat -bd 0 -highlightthickness 0 \
  319.             -foreground [Widget::getoption $_top -foreground] \
  320.             -background [Widget::getoption $_top -background] \
  321.             -font       [Widget::getoption $_top -font] \
  322.             -justify    [Widget::getoption $_top -justify]
  323.  
  324.  
  325.         pack $_top.label -side left
  326.         update idletasks
  327.  
  328.         set  scrwidth  [winfo vrootwidth  .]
  329.         set  scrheight [winfo vrootheight .]
  330.         set  width     [winfo reqwidth  $_top]
  331.         set  height    [winfo reqheight $_top]
  332.         incr y 12
  333.         incr x 8
  334.  
  335.         if { $x+$width > $scrwidth } {
  336.             set x [expr {$scrwidth - $width}]
  337.         }
  338.         if { $y+$height > $scrheight } {
  339.             set y [expr {$y - 12 - $height}]
  340.         }
  341.  
  342.         wm geometry  $_top "+$x+$y"
  343.         update idletasks
  344.         wm deiconify $_top
  345.     }
  346. }
  347.  
  348.  
  349.