home *** CD-ROM | disk | FTP | other *** search
/ PC World 2000 December / PCWorld_2000-12_cd.bin / Komunikace / Comanche / BWidget-1.2 / dynhelp.tcl < prev    next >
Text File  |  2000-11-02  |  12KB  |  345 lines
  1. # ------------------------------------------------------------------------------
  2. #  dynhelp.tcl
  3. #  This file is part of Unifix BWidget Toolkit
  4. # ------------------------------------------------------------------------------
  5. #  Index of commands:
  6. #     - DynamicHelp::configure
  7. #     - DynamicHelp::include
  8. #     - DynamicHelp::sethelp
  9. #     - DynamicHelp::register
  10. #     - DynamicHelp::_motion_balloon
  11. #     - DynamicHelp::_motion_info
  12. #     - DynamicHelp::_leave_info
  13. #     - DynamicHelp::_motion_menu
  14. #     - DynamicHelp::_leave_menu
  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 {=100 =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> {catch {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> {catch {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>      {catch {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 {
  82.         {-helptext String "" 0}
  83.         {-helpvar  String "" 0}}
  84.     lappend helpoptions [list -helptype Enum $type 0 {balloon variable}]
  85.     Widget::declare $class $helpoptions
  86. }
  87.  
  88.  
  89. # ------------------------------------------------------------------------------
  90. #  Command DynamicHelp::sethelp
  91. # ------------------------------------------------------------------------------
  92. proc DynamicHelp::sethelp { path subpath {force 0}} {
  93.     set ctype [Widget::hasChanged $path -helptype htype]
  94.     set ctext [Widget::hasChanged $path -helptext htext]
  95.     set cvar  [Widget::hasChanged $path -helpvar  hvar]
  96.     if { $force || $ctype || $ctext || $cvar } {
  97.         switch $htype {
  98.             balloon {
  99.                 return [register $subpath balloon $htext]
  100.             }
  101.             variable {
  102.                 return [register $subpath variable $hvar $htext]
  103.             }
  104.         }
  105.         return [register $subpath $htype]
  106.     }
  107. }
  108.  
  109.  
  110. # ------------------------------------------------------------------------------
  111. #  Command DynamicHelp::register
  112. # ------------------------------------------------------------------------------
  113. proc DynamicHelp::register { path type args } {
  114.     variable _registered
  115.  
  116.     if { [winfo exists $path] } {
  117.         set evt  [bindtags $path]
  118.         set idx  [lsearch $evt "BwHelp*"]
  119.         set evt  [lreplace $evt $idx $idx]
  120.         switch $type {
  121.             balloon {
  122.                 set text [lindex $args 0]
  123.                 if { $text != "" } {
  124.                     set _registered($path) $text
  125.                     lappend evt BwHelpBalloon
  126.                 } else {
  127.                     catch {unset _registered($path)}
  128.                 }
  129.                 bindtags $path $evt
  130.                 return 1
  131.             }
  132.  
  133.             variable {
  134.                 set var  [lindex $args 0]
  135.                 set text [lindex $args 1]
  136.                 if { $text != "" && $var != "" } {
  137.                     set _registered($path) [list $var $text]
  138.                     lappend evt BwHelpVariable
  139.                 } else {
  140.                     catch {unset _registered($path)}
  141.                 }
  142.                 bindtags $path $evt
  143.                 return 1
  144.             }
  145.  
  146.             menu {
  147.                 set cpath [BWidget::clonename $path]
  148.                 if { [winfo exists $cpath] } {
  149.                     set path $cpath
  150.                 }
  151.                 set var [lindex $args 0]
  152.                 if { $var != "" } {
  153.                     set _registered($path) [list $var]
  154.                     lappend evt BwHelpMenu
  155.                 } else {
  156.                     catch {unset _registered($path)}
  157.                 }
  158.                 bindtags $path $evt
  159.                 return 1
  160.             }
  161.  
  162.             menuentry {
  163.                 set cpath [BWidget::clonename $path]
  164.                 if { [winfo exists $cpath] } {
  165.                     set path $cpath
  166.                 }
  167.                 if { [info exists _registered($path)] } {
  168.                     if { [set index [lindex $args 0]] != "" } {
  169.                         set text  [lindex $args 1]
  170.                         set idx   [lsearch $_registered($path) [list $index *]]
  171.                         if { $text != "" } {
  172.                             if { $idx == -1 } {
  173.                                 lappend _registered($path) [list $index $text]
  174.                             } else {
  175.                                 set _registered($path) [lreplace $_registered($path) $idx $idx [list $index $text]]
  176.                             }
  177.                         } else {
  178.                             set _registered($path) [lreplace $_registered($path) $idx $idx]
  179.                         }
  180.                     }
  181.                     return 1
  182.                 }
  183.                 return 0
  184.             }
  185.         }
  186.         catch {unset _registered($path)}
  187.         bindtags $path $evt
  188.         return 1
  189.     } else {
  190.         catch {unset _registered($path)}
  191.         return 0
  192.     }
  193. }
  194.  
  195.  
  196. # ------------------------------------------------------------------------------
  197. #  Command DynamicHelp::_motion_balloon
  198. # ------------------------------------------------------------------------------
  199. proc DynamicHelp::_motion_balloon { type path x y } {
  200.     variable _top
  201.     variable _id
  202.     variable _delay
  203.     variable _current
  204.  
  205.     if { $_current != $path && $type == "enter" } {
  206.         set _current $path
  207.         set type "motion"
  208.         destroy $_top
  209.     }
  210.     if { $_current == $path } {
  211.         if { $_id != "" } {
  212.             after cancel $_id
  213.             set _id ""
  214.         }
  215.         if { $type == "motion" } {
  216.             if { ![winfo exists $_top] } {
  217.                 set _id [after $_delay "DynamicHelp::_show_help $path $x $y"]
  218.             }
  219.         } else {
  220.             destroy $_top
  221.             set _current ""
  222.         }
  223.     }
  224. }
  225.  
  226.  
  227. # ------------------------------------------------------------------------------
  228. #  Command DynamicHelp::_motion_info
  229. # ------------------------------------------------------------------------------
  230. proc DynamicHelp::_motion_info { path } {
  231.     variable _registered
  232.     variable _current
  233.     variable _saved
  234.  
  235.     if { $_current != $path && [info exists _registered($path)] } {
  236.         if { ![info exists _saved] } {
  237.             set _saved [GlobalVar::getvar [lindex $_registered($path) 0]]
  238.         }
  239.         GlobalVar::setvar [lindex $_registered($path) 0] [lindex $_registered($path) 1]
  240.         set _current $path
  241.     }
  242. }
  243.  
  244.  
  245. # ------------------------------------------------------------------------------
  246. #  Command DynamicHelp::_leave_info
  247. # ------------------------------------------------------------------------------
  248. proc DynamicHelp::_leave_info { path } {
  249.     variable _registered
  250.     variable _current
  251.     variable _saved
  252.  
  253.     if { [info exists _registered($path)] } {
  254.         GlobalVar::setvar [lindex $_registered($path) 0] $_saved
  255.     }
  256.     unset _saved
  257.     set _current ""
  258.     
  259. }
  260.  
  261.  
  262. # ------------------------------------------------------------------------------
  263. #  Command DynamicHelp::_menu_info
  264. # ------------------------------------------------------------------------------
  265. proc DynamicHelp::_menu_info { event path } {
  266.     variable _registered
  267.     variable _saved
  268.  
  269.     if { [info exists _registered($path)] } {
  270.         switch -- $event {
  271.             select {
  272.                 if { [winfo ismapped $path] } {
  273.                     set index [$path index active]
  274.                     if { [set idx [lsearch $_registered($path) [list $index *]]] != -1 } {
  275.                         if { ![info exists _saved] } {
  276.                             set _saved [GlobalVar::getvar [lindex $_registered($path) 0]]
  277.                         }
  278.                         GlobalVar::setvar [lindex $_registered($path) 0] [lindex [lindex $_registered($path) $idx] 1]
  279.                     } else {
  280.                         GlobalVar::setvar [lindex $_registered($path) 0] ""
  281.                     }
  282.                 }
  283.             }
  284.             unmap {
  285.                 if { [info exists _saved] } {
  286.                     GlobalVar::setvar [lindex $_registered($path) 0] $_saved
  287.                     unset _saved
  288.                 }
  289.             }
  290.         }
  291.     }
  292. }
  293.  
  294.  
  295. # ------------------------------------------------------------------------------
  296. #  Command DynamicHelp::_show_help
  297. # ------------------------------------------------------------------------------
  298. proc DynamicHelp::_show_help { path x y } {
  299.     variable _top
  300.     variable _registered
  301.     variable _id
  302.     variable _delay
  303.  
  304.     if { [info exists _registered($path)] } {
  305.         destroy  $_top
  306.         toplevel $_top -relief flat \
  307.             -bg [Widget::getoption $_top -foreground] \
  308.             -bd [Widget::getoption $_top -borderwidth]
  309.         wm overrideredirect $_top 1
  310.         wm transient $_top
  311.         wm withdraw $_top
  312.  
  313.         label $_top.label -text $_registered($path) \
  314.             -relief flat -bd 0 -highlightthickness 0 \
  315.             -foreground [Widget::getoption $_top -foreground] \
  316.             -background [Widget::getoption $_top -background] \
  317.             -font       [Widget::getoption $_top -font] \
  318.             -justify    [Widget::getoption $_top -justify]
  319.  
  320.  
  321.         pack $_top.label -side left
  322.         update idletasks
  323.  
  324.         set  scrwidth  [winfo vrootwidth  .]
  325.         set  scrheight [winfo vrootheight .]
  326.         set  width     [winfo reqwidth  $_top]
  327.         set  height    [winfo reqheight $_top]
  328.         incr y 12
  329.         incr x 8
  330.  
  331.         if { $x+$width > $scrwidth } {
  332.             set x [expr $scrwidth - $width]
  333.         }
  334.         if { $y+$height > $scrheight } {
  335.             set y [expr $y - 12 - $height]
  336.         }
  337.  
  338.         wm geometry  $_top "+$x+$y"
  339.         update idletasks
  340.         wm deiconify $_top
  341.     }
  342. }
  343.  
  344.  
  345.