home *** CD-ROM | disk | FTP | other *** search
/ PC World 2000 December / PCWorld_2000-12_cd.bin / Komunikace / Comanche / BWidget-1.2 / utils.tcl < prev    next >
Text File  |  2000-11-02  |  14KB  |  409 lines
  1. # ------------------------------------------------------------------------------
  2. #  utils.tcl
  3. #  This file is part of Unifix BWidget Toolkit
  4. #  $Id: utils.tcl,v 1.1.1.1 1996/02/22 06:05:56 daniel Exp $
  5. # ------------------------------------------------------------------------------
  6. #  Index of commands:
  7. #     - GlobalVar::exists
  8. #     - GlobalVar::setvarvar
  9. #     - GlobalVar::getvarvar
  10. #     - BWidget::assert
  11. #     - BWidget::clonename
  12. #     - BWidget::get3dcolor
  13. #     - BWidget::XLFDfont
  14. #     - BWidget::place
  15. #     - BWidget::grab
  16. #     - BWidget::focus
  17. # ------------------------------------------------------------------------------
  18.  
  19. namespace eval GlobalVar {
  20.     proc use {} {}
  21. }
  22.  
  23.  
  24. namespace eval BWidget {
  25.     variable _top
  26.     variable _gstack {}
  27.     variable _fstack {}
  28.     proc use {} {}
  29. }
  30.  
  31.  
  32. # ------------------------------------------------------------------------------
  33. #  Command GlobalVar::exists
  34. # ------------------------------------------------------------------------------
  35. proc GlobalVar::exists { varName } {
  36.     return [uplevel \#0 [list info exists $varName]]
  37. }
  38.  
  39.  
  40. # ------------------------------------------------------------------------------
  41. #  Command GlobalVar::setvar
  42. # ------------------------------------------------------------------------------
  43. proc GlobalVar::setvar { varName value } {
  44.     return [uplevel \#0 [list set $varName $value]]
  45. }
  46.  
  47.  
  48. # ------------------------------------------------------------------------------
  49. #  Command GlobalVar::getvar
  50. # ------------------------------------------------------------------------------
  51. proc GlobalVar::getvar { varName } {
  52.     return [uplevel \#0 [list set $varName]]
  53. }
  54.  
  55.  
  56. # ------------------------------------------------------------------------------
  57. #  Command GlobalVar::tracevar
  58. # ------------------------------------------------------------------------------
  59. proc GlobalVar::tracevar { cmd varName args } {
  60.     return [uplevel \#0 trace $cmd [list $varName] $args]
  61. }
  62.  
  63.  
  64.  
  65. # ------------------------------------------------------------------------------
  66. #  Command BWidget::lreorder
  67. # ------------------------------------------------------------------------------
  68. proc BWidget::lreorder { list neworder } {
  69.     set pos     0
  70.     set newlist {}
  71.     foreach e $neworder {
  72.         if { [lsearch -exact $list $e] != -1 } {
  73.             lappend newlist $e
  74.             set tabelt($e)  1
  75.         }
  76.     }
  77.     set len [llength $newlist]
  78.     if { !$len } {
  79.         return $list
  80.     }
  81.     if { $len == [llength $list] } {
  82.         return $newlist
  83.     }
  84.     set pos 0
  85.     foreach e $list {
  86.         if { ![info exists tabelt($e)] } {
  87.             set newlist [linsert $newlist $pos $e]
  88.         }
  89.         incr pos
  90.     }
  91.     return $newlist
  92. }
  93.  
  94.  
  95. # ------------------------------------------------------------------------------
  96. #  Command BWidget::assert
  97. # ------------------------------------------------------------------------------
  98. proc BWidget::assert { exp {msg ""}} {
  99.     set res [uplevel expr $exp]
  100.     if { !$res} {
  101.         if { $msg == "" } {
  102.             return -code error "Assertion failed: {$exp}"
  103.         } else {
  104.             return -code error $msg
  105.         }
  106.     }
  107. }
  108.  
  109.  
  110. # ------------------------------------------------------------------------------
  111. #  Command BWidget::clonename
  112. # ------------------------------------------------------------------------------
  113. proc BWidget::clonename { menu } {
  114.     set path     ""
  115.     set menupath ""
  116.     set found    0
  117.     foreach widget [lrange [split $menu "."] 1 end] {
  118.         if { $found || [winfo class "$path.$widget"] == "Menu" } {
  119.             set found 1
  120.             append menupath "#" $widget
  121.             append path "." $menupath
  122.         } else {
  123.             append menupath "#" $widget
  124.             append path "." $widget
  125.         }    
  126.     }
  127.     return $path
  128. }
  129.  
  130.  
  131. # ------------------------------------------------------------------------------
  132. #  Command BWidget::getname
  133. # ------------------------------------------------------------------------------
  134. proc BWidget::getname { name } {
  135.     if { [string length $name] } {
  136.         set text [option get . "${name}Name" ""]
  137.         if { [string length $text] } {
  138.             return [parsetext $text]
  139.         }
  140.     }
  141.     return {}
  142.  }
  143.  
  144.  
  145. # ------------------------------------------------------------------------------
  146. #  Command BWidget::parsetext
  147. # ------------------------------------------------------------------------------
  148. proc BWidget::parsetext { text } {
  149.     set result ""
  150.     set index  -1
  151.     set start  0
  152.     while { [string length $text] } {
  153.         set idx [string first "&" $text]
  154.         if { $idx == -1 } {
  155.             append result $text
  156.             set text ""
  157.         } else {
  158.             set char [string index $text [expr {$idx+1}]]
  159.             if { $char == "&" } {
  160.                 append result [string range $text 0 $idx]
  161.                 set    text   [string range $text [expr {$idx+2}] end]
  162.                 set    start  [expr {$start+$idx+1}]
  163.             } else {
  164.                 append result [string range $text 0 [expr {$idx-1}]]
  165.                 set    text   [string range $text [expr {$idx+1}] end]
  166.                 incr   start  $idx
  167.                 set    index  $start
  168.             }
  169.         }
  170.     }
  171.     return [list $result $index]
  172. }
  173.  
  174.  
  175. # ------------------------------------------------------------------------------
  176. #  Command BWidget::get3dcolor
  177. # ------------------------------------------------------------------------------
  178. proc BWidget::get3dcolor { path bgcolor } {
  179.     foreach val [winfo rgb $path $bgcolor] {
  180.         lappend dark [expr 60*$val/100]
  181.         set tmp1 [expr 14*$val/10]
  182.         if { $tmp1 > 65535 } {
  183.             set tmp1 65535
  184.         }
  185.         set tmp2 [expr (65535+$val)/2]
  186.         lappend light [expr ($tmp1 > $tmp2) ? $tmp1:$tmp2]
  187.     }
  188.     return [list [eval format "#%04x%04x%04x" $dark] [eval format "#%04x%04x%04x" $light]]
  189. }
  190.  
  191.  
  192. # ------------------------------------------------------------------------------
  193. #  Command BWidget::XLFDfont
  194. # ------------------------------------------------------------------------------
  195. proc BWidget::XLFDfont { cmd args } {
  196.     switch -- $cmd {
  197.         create {
  198.             set font "-*-*-*-*-*-*-*-*-*-*-*-*-*-*"
  199.         }
  200.         configure {
  201.             set font [lindex $args 0]
  202.             set args [lrange $args 1 end]
  203.         }
  204.         default {
  205.             return -code error "XLFDfont: commande incorrecte: $cmd"
  206.         }
  207.     }
  208.     set lfont [split $font "-"]
  209.     if { [llength $lfont] != 15 } {
  210.         return -code error "XLFDfont: description XLFD incorrecte: $font"
  211.     }
  212.  
  213.     foreach {option value} $args {
  214.         switch -- $option {
  215.             -foundry { set index 1 }
  216.             -family  { set index 2 }
  217.             -weight  { set index 3 }
  218.             -slant   { set index 4 }
  219.             -size    { set index 7 }
  220.             default  { return -code error "XLFDfont: option incorrecte: $option" }
  221.         }
  222.         set lfont [lreplace $lfont $index $index $value]
  223.     }
  224.     return [join $lfont "-"]
  225. }
  226.  
  227.  
  228.  
  229. # ------------------------------------------------------------------------------
  230. #  Command BWidget::place
  231. # ------------------------------------------------------------------------------
  232. proc BWidget::place { path w h args } {
  233.     variable _top
  234.  
  235.     update idletasks
  236.     set reqw [winfo reqwidth  $path]
  237.     set reqh [winfo reqheight $path]
  238.     if { $w == 0 } {set w $reqw}
  239.     if { $h == 0 } {set h $reqh}
  240.  
  241.     set arglen [llength $args]
  242.     if { $arglen > 3 } {
  243.         return -code error "BWidget::place: bad number of argument"
  244.     }
  245.  
  246.     if { $arglen > 0 } {
  247.         set where [lindex $args 0]
  248.         set idx   [lsearch {"at" "center" "left" "right" "above" "below"} $where]
  249.         if { $idx == -1 } {
  250.             return -code error "BWidget::place: incorrect position \"$where\""
  251.         }
  252.         if { $idx == 0 } {
  253.             set err [catch {
  254.                 set x [expr {int([lindex $args 1])}]
  255.                 set y [expr {int([lindex $args 2])}]
  256.             }]
  257.             if { $err } {
  258.                 return -code error "BWidget::place: incorrect position"
  259.             }
  260.             if { $x > 0 } {
  261.                 set x "+$x"
  262.             }
  263.             if { $y > 0 } {
  264.                 set y "+$y"
  265.             }
  266.         } else {
  267.             if { $arglen == 2 } {
  268.                 set widget [lindex $args 1]
  269.                 if { ![winfo exists $widget] } {
  270.                     return -code error "BWidget::place: \"$widget\" does not exist"
  271.                 }
  272.             }
  273.             set sw [winfo screenwidth  $path]
  274.             set sh [winfo screenheight $path]
  275.             if { $idx == 1 } {
  276.                 if { $arglen == 2 } {
  277.                     # center to widget
  278.                     set x0 [expr [winfo rootx $widget] + ([winfo width  $widget] - $w)/2]
  279.                     set y0 [expr [winfo rooty $widget] + ([winfo height $widget] - $h)/2]
  280.                 } else {
  281.                     # center to screen
  282.                     set x0 [expr ([winfo screenwidth  $path] - $w)/2 - [winfo vrootx $path]]
  283.                     set y0 [expr ([winfo screenheight $path] - $h)/2 - [winfo vrooty $path]]
  284.                 }
  285.                 set x "+$x0"
  286.                 set y "+$y0"
  287.                 if { $x0+$w > $sw } {set x "-0"; set x0 [expr {$sw-$w}]}
  288.                 if { $x0 < 0 }      {set x "+0"}
  289.                 if { $y0+$h > $sh } {set y "-0"; set y0 [expr {$sh-$h}]}
  290.                 if { $y0 < 0 }      {set y "+0"}
  291.             } else {
  292.                 set x0 [winfo rootx $widget]
  293.                 set y0 [winfo rooty $widget]
  294.                 set x1 [expr {$x0 + [winfo width  $widget]}]
  295.                 set y1 [expr {$y0 + [winfo height $widget]}]
  296.                 if { $idx == 2 || $idx == 3 } {
  297.                     set y "+$y0"
  298.                     if { $y0+$h > $sh } {set y "-0"; set y0 [expr {$sh-$h}]}
  299.                     if { $y0 < 0 }      {set y "+0"}
  300.                     if { $idx == 2 } {
  301.                         # try left, then right if out, then 0 if out
  302.                         if { $x0 >= $w } {
  303.                             set x [expr {$x0-$sw}]
  304.                         } elseif { $x1+$w <= $sw } {
  305.                             set x "+$x1"
  306.                         } else {
  307.                             set x "+0"
  308.                         }
  309.                     } else {
  310.                         # try right, then left if out, then 0 if out
  311.                         if { $x1+$w <= $sw } {
  312.                             set x "+$x1"
  313.                         } elseif { $x0 >= $w } {
  314.                             set x [expr {$x0-$sw}]
  315.                         } else {
  316.                             set x "-0"
  317.                         }
  318.                     }
  319.                 } else {
  320.                     set x "+$x0"
  321.                     if { $x0+$w > $sw } {set x "-0"; set x0 [expr {$sw-$w}]}
  322.                     if { $x0 < 0 }      {set x "+0"}
  323.                     if { $idx == 4 } {
  324.                         # try top, then bottom, then 0
  325.                         if { $h <= $y0 } {
  326.                             set y [expr {$y0-$sh}]
  327.                         } elseif { $y1+$h <= $sh } {
  328.                             set y "+$y1"
  329.                         } else {
  330.                             set y "+0"
  331.                         }
  332.                     } else {
  333.                         # try bottom, then top, then 0
  334.                         if { $y1+$h <= $sh } {
  335.                             set y "+$y1"
  336.                         } elseif { $h <= $y0 } {
  337.                             set y [expr {$y0-$sh}]
  338.                         } else {
  339.                             set y "-0"
  340.                         }
  341.                     }
  342.                 }
  343.             }
  344.         }
  345.         wm geometry $path "${w}x${h}${x}${y}"
  346.     } else {
  347.         wm geometry $path "${w}x${h}"
  348.     }
  349.     update idletasks
  350. }
  351.  
  352.  
  353. # ------------------------------------------------------------------------------
  354. #  Command BWidget::grab
  355. # ------------------------------------------------------------------------------
  356. proc BWidget::grab { option path } {
  357.     variable _gstack
  358.  
  359.     if { $option == "release" } {
  360.         catch {::grab release $path}
  361.         while { [llength $_gstack] } {
  362.             set grinfo  [lindex $_gstack end]
  363.             set _gstack [lreplace $_gstack end end]
  364.             foreach {oldg mode} $grinfo {
  365.                 if { [string compare $oldg $path] && [winfo exists $oldg] } {
  366.                     if { $mode == "global" } {
  367.                         catch {::grab -global $oldg}
  368.                     } else {
  369.                         catch {::grab $oldg}
  370.                     }
  371.                     return
  372.                 }
  373.             }
  374.         }
  375.     } else {
  376.         set oldg [::grab current]
  377.         if { $oldg != "" } {
  378.             lappend _gstack [list $oldg [::grab status $oldg]]
  379.         }
  380.         if { $option == "global" } {
  381.             ::grab -global $path
  382.         } else {
  383.             ::grab $path
  384.         }
  385.     }
  386. }
  387.  
  388.  
  389. # ------------------------------------------------------------------------------
  390. #  Command BWidget::focus
  391. # ------------------------------------------------------------------------------
  392. proc BWidget::focus { option path } {
  393.     variable _fstack
  394.  
  395.     if { $option == "release" } {
  396.         while { [llength $_fstack] } {
  397.             set oldf [lindex $_fstack end]
  398.             set _fstack [lreplace $_fstack end end]
  399.             if { [string compare $oldf $path] && [winfo exists $oldf] } {
  400.                 catch {::focus -force $oldf}
  401.                 return
  402.             }
  403.         }
  404.     } elseif { $option == "set" } {
  405.         lappend _fstack [::focus]
  406.         ::focus -force $path
  407.     }
  408. }
  409.