home *** CD-ROM | disk | FTP | other *** search
/ PC World 2005 June / PCWorld_2005-06_cd.bin / software / vyzkuste / firewally / firewally.exe / framework-2.3.exe / tk.tcl < prev    next >
Text File  |  2003-09-01  |  17KB  |  575 lines
  1. # tk.tcl --
  2. #
  3. # Initialization script normally executed in the interpreter for each
  4. # Tk-based application.  Arranges class bindings for widgets.
  5. #
  6. # RCS: @(#) $Id: tk.tcl,v 1.45 2002/10/10 16:34:51 hobbs Exp $
  7. #
  8. # Copyright (c) 1992-1994 The Regents of the University of California.
  9. # Copyright (c) 1994-1996 Sun Microsystems, Inc.
  10. # Copyright (c) 1998-2000 Ajuba Solutions.
  11. #
  12. # See the file "license.terms" for information on usage and redistribution
  13. # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  14.  
  15. # Insist on running with compatible versions of Tcl and Tk.
  16. package require -exact Tk 8.4
  17. package require -exact Tcl 8.4
  18.  
  19. # Create a ::tk namespace
  20. namespace eval ::tk {
  21.     # Set up the msgcat commands
  22.     namespace eval msgcat {
  23.     namespace export mc mcmax        
  24.         if {[interp issafe] || [catch {package require msgcat}]} {
  25.             # The msgcat package is not available.  Supply our own
  26.             # minimal replacement.
  27.             proc mc {src args} {
  28.                 return [eval [list format $src] $args]
  29.             }
  30.             proc mcmax {args} {
  31.                 set max 0
  32.                 foreach string $args {
  33.                     set len [string length $string]
  34.                     if {$len>$max} {
  35.                         set max $len
  36.                     }
  37.                 }
  38.                 return $max
  39.             }
  40.         } else {
  41.             # Get the commands from the msgcat package that Tk uses.
  42.             namespace import ::msgcat::mc
  43.             namespace import ::msgcat::mcmax
  44.             ::msgcat::mcload [file join $::tk_library msgs]
  45.         }
  46.     }
  47.     namespace import ::tk::msgcat::*
  48. }
  49.  
  50. # Add Tk's directory to the end of the auto-load search path, if it
  51. # isn't already on the path:
  52.  
  53. if {[info exists ::auto_path] && [string compare {} $::tk_library] && \
  54.     [lsearch -exact $::auto_path $::tk_library] < 0} {
  55.     lappend ::auto_path $::tk_library
  56. }
  57.  
  58. # Turn off strict Motif look and feel as a default.
  59.  
  60. set ::tk_strictMotif 0
  61.  
  62. # Turn on useinputmethods (X Input Methods) by default.
  63. # We catch this because safe interpreters may not allow the call.
  64.  
  65. catch {tk useinputmethods 1}
  66.  
  67. # ::tk::PlaceWindow --
  68. #   place a toplevel at a particular position
  69. # Arguments:
  70. #   toplevel    name of toplevel window
  71. #   ?placement?    pointer ?center? ; places $w centered on the pointer
  72. #        widget widgetPath ; centers $w over widget_name
  73. #        defaults to placing toplevel in the middle of the screen
  74. #   ?anchor?    center or widgetPath
  75. # Results:
  76. #   Returns nothing
  77. #
  78. proc ::tk::PlaceWindow {w {place ""} {anchor ""}} {
  79.     wm withdraw $w
  80.     update idletasks
  81.     set checkBounds 1
  82.     if {[string equal -len [string length $place] $place "pointer"]} {
  83.     ## place at POINTER (centered if $anchor == center)
  84.     if {[string equal -len [string length $anchor] $anchor "center"]} {
  85.         set x [expr {[winfo pointerx $w]-[winfo reqwidth $w]/2}]
  86.         set y [expr {[winfo pointery $w]-[winfo reqheight $w]/2}]
  87.     } else {
  88.         set x [winfo pointerx $w]
  89.         set y [winfo pointery $w]
  90.     }
  91.     } elseif {[string equal -len [string length $place] $place "widget"] && \
  92.         [winfo exists $anchor] && [winfo ismapped $anchor]} {
  93.     ## center about WIDGET $anchor, widget must be mapped
  94.     set x [expr {[winfo rootx $anchor] + \
  95.         ([winfo width $anchor]-[winfo reqwidth $w])/2}]
  96.     set y [expr {[winfo rooty $anchor] + \
  97.         ([winfo height $anchor]-[winfo reqheight $w])/2}]
  98.     } else {
  99.     set x [expr {([winfo screenwidth $w]-[winfo reqwidth $w])/2}]
  100.     set y [expr {([winfo screenheight $w]-[winfo reqheight $w])/2}]
  101.     set checkBounds 0
  102.     }
  103.     if {$checkBounds} {
  104.     if {$x < 0} {
  105.         set x 0
  106.     } elseif {$x > ([winfo screenwidth $w]-[winfo reqwidth $w])} {
  107.         set x [expr {[winfo screenwidth $w]-[winfo reqwidth $w]}]
  108.     }
  109.     if {$y < 0} {
  110.         set y 0
  111.     } elseif {$y > ([winfo screenheight $w]-[winfo reqheight $w])} {
  112.         set y [expr {[winfo screenheight $w]-[winfo reqheight $w]}]
  113.     }
  114.     if {[tk windowingsystem] eq "macintosh" \
  115.         || [tk windowingsystem] eq "aqua"} {
  116.         # Avoid the native menu bar which sits on top of everything.
  117.         if {$y < 20} { set y 20 }
  118.     }
  119.     }
  120.     wm geometry $w +$x+$y
  121.     wm deiconify $w
  122. }
  123.  
  124. # ::tk::SetFocusGrab --
  125. #   swap out current focus and grab temporarily (for dialogs)
  126. # Arguments:
  127. #   grab    new window to grab
  128. #   focus    window to give focus to
  129. # Results:
  130. #   Returns nothing
  131. #
  132. proc ::tk::SetFocusGrab {grab {focus {}}} {
  133.     set index "$grab,$focus"
  134.     upvar ::tk::FocusGrab($index) data
  135.  
  136.     lappend data [focus]
  137.     set oldGrab [grab current $grab]
  138.     lappend data $oldGrab
  139.     if {[winfo exists $oldGrab]} {
  140.     lappend data [grab status $oldGrab]
  141.     }
  142.     # The "grab" command will fail if another application
  143.     # already holds the grab.  So catch it.
  144.     catch {grab $grab}
  145.     if {[winfo exists $focus]} {
  146.     focus $focus
  147.     }
  148. }
  149.  
  150. # ::tk::RestoreFocusGrab --
  151. #   restore old focus and grab (for dialogs)
  152. # Arguments:
  153. #   grab    window that had taken grab
  154. #   focus    window that had taken focus
  155. #   destroy    destroy|withdraw - how to handle the old grabbed window
  156. # Results:
  157. #   Returns nothing
  158. #
  159. proc ::tk::RestoreFocusGrab {grab focus {destroy destroy}} {
  160.     set index "$grab,$focus"
  161.     if {[info exists ::tk::FocusGrab($index)]} {
  162.     foreach {oldFocus oldGrab oldStatus} $::tk::FocusGrab($index) { break }
  163.     unset ::tk::FocusGrab($index)
  164.     } else {
  165.     set oldGrab ""
  166.     }
  167.  
  168.     catch {focus $oldFocus}
  169.     grab release $grab
  170.     if {[string equal $destroy "withdraw"]} {
  171.     wm withdraw $grab
  172.     } else {
  173.     destroy $grab
  174.     }
  175.     if {[winfo exists $oldGrab] && [winfo ismapped $oldGrab]} {
  176.     if {[string equal $oldStatus "global"]} {
  177.         grab -global $oldGrab
  178.     } else {
  179.         grab $oldGrab
  180.     }
  181.     }
  182. }
  183.  
  184. # ::tk::GetSelection --
  185. #   This tries to obtain the default selection.  On Unix, we first try
  186. #   and get a UTF8_STRING, a type supported by modern Unix apps for
  187. #   passing Unicode data safely.  We fall back on the default STRING
  188. #   type otherwise.  On Windows, only the STRING type is necessary.
  189. # Arguments:
  190. #   w    The widget for which the selection will be retrieved.
  191. #    Important for the -displayof property.
  192. #   sel    The source of the selection (PRIMARY or CLIPBOARD)
  193. # Results:
  194. #   Returns the selection, or an error if none could be found
  195. #
  196. if {[string equal $tcl_platform(platform) "unix"]} {
  197.     proc ::tk::GetSelection {w {sel PRIMARY}} {
  198.     if {[catch {selection get -displayof $w -selection $sel \
  199.         -type UTF8_STRING} txt] \
  200.         && [catch {selection get -displayof $w -selection $sel} txt]} {
  201.         return -code error "could not find default selection"
  202.     } else {
  203.         return $txt
  204.     }
  205.     }
  206. } else {
  207.     proc ::tk::GetSelection {w {sel PRIMARY}} {
  208.     if {[catch {selection get -displayof $w -selection $sel} txt]} {
  209.         return -code error "could not find default selection"
  210.     } else {
  211.         return $txt
  212.     }
  213.     }
  214. }
  215.  
  216. # ::tk::ScreenChanged --
  217. # This procedure is invoked by the binding mechanism whenever the
  218. # "current" screen is changing.  The procedure does two things.
  219. # First, it uses "upvar" to make variable "::tk::Priv" point at an
  220. # array variable that holds state for the current display.  Second,
  221. # it initializes the array if it didn't already exist.
  222. #
  223. # Arguments:
  224. # screen -        The name of the new screen.
  225.  
  226. proc ::tk::ScreenChanged screen {
  227.     set x [string last . $screen]
  228.     if {$x > 0} {
  229.     set disp [string range $screen 0 [expr {$x - 1}]]
  230.     } else {
  231.     set disp $screen
  232.     }
  233.  
  234.     uplevel #0 upvar #0 ::tk::Priv.$disp ::tk::Priv
  235.     variable ::tk::Priv
  236.     global tcl_platform
  237.  
  238.     if {[info exists Priv]} {
  239.     set Priv(screen) $screen
  240.     return
  241.     }
  242.     array set Priv {
  243.     activeMenu    {}
  244.     activeItem    {}
  245.     afterId        {}
  246.     buttons        0
  247.     buttonWindow    {}
  248.     dragging    0
  249.     focus        {}
  250.     grab        {}
  251.     initPos        {}
  252.     inMenubutton    {}
  253.     listboxPrev    {}
  254.     menuBar        {}
  255.     mouseMoved    0
  256.     oldGrab        {}
  257.     popup        {}
  258.     postedMb    {}
  259.     pressX        0
  260.     pressY        0
  261.     prevPos        0
  262.     selectMode    char
  263.     }
  264.     set Priv(screen) $screen
  265.     set Priv(tearoff) [string equal [tk windowingsystem] "x11"]
  266.     set Priv(window) {}
  267. }
  268.  
  269. # Do initial setup for Priv, so that it is always bound to something
  270. # (otherwise, if someone references it, it may get set to a non-upvar-ed
  271. # value, which will cause trouble later).
  272.  
  273. tk::ScreenChanged [winfo screen .]
  274.  
  275. # ::tk::EventMotifBindings --
  276. # This procedure is invoked as a trace whenever ::tk_strictMotif is
  277. # changed.  It is used to turn on or turn off the motif virtual
  278. # bindings.
  279. #
  280. # Arguments:
  281. # n1 - the name of the variable being changed ("::tk_strictMotif").
  282.  
  283. proc ::tk::EventMotifBindings {n1 dummy dummy} {
  284.     upvar $n1 name
  285.     
  286.     if {$name} {
  287.     set op delete
  288.     } else {
  289.     set op add
  290.     }
  291.  
  292.     event $op <<Cut>> <Control-Key-w>
  293.     event $op <<Copy>> <Meta-Key-w> 
  294.     event $op <<Paste>> <Control-Key-y>
  295.     event $op <<Undo>> <Control-underscore>
  296. }
  297.  
  298. #----------------------------------------------------------------------
  299. # Define common dialogs on platforms where they are not implemented 
  300. # using compiled code.
  301. #----------------------------------------------------------------------
  302.  
  303. if {[string equal [info commands tk_chooseColor] ""]} {
  304.     proc ::tk_chooseColor {args} {
  305.     return [eval tk::dialog::color:: $args]
  306.     }
  307. }
  308. if {[string equal [info commands tk_getOpenFile] ""]} {
  309.     proc ::tk_getOpenFile {args} {
  310.     if {$::tk_strictMotif} {
  311.         return [eval tk::MotifFDialog open $args]
  312.     } else {
  313.         return [eval ::tk::dialog::file:: open $args]
  314.     }
  315.     }
  316. }
  317. if {[string equal [info commands tk_getSaveFile] ""]} {
  318.     proc ::tk_getSaveFile {args} {
  319.     if {$::tk_strictMotif} {
  320.         return [eval tk::MotifFDialog save $args]
  321.     } else {
  322.         return [eval ::tk::dialog::file:: save $args]
  323.     }
  324.     }
  325. }
  326. if {[string equal [info commands tk_messageBox] ""]} {
  327.     proc ::tk_messageBox {args} {
  328.     return [eval tk::MessageBox $args]
  329.     }
  330. }
  331. if {[string equal [info command tk_chooseDirectory] ""]} {
  332.     proc ::tk_chooseDirectory {args} {
  333.     return [eval ::tk::dialog::file::chooseDir:: $args]
  334.     }
  335. }
  336.     
  337. #----------------------------------------------------------------------
  338. # Define the set of common virtual events.
  339. #----------------------------------------------------------------------
  340.  
  341. switch [tk windowingsystem] {
  342.     "x11" {
  343.     event add <<Cut>> <Control-Key-x> <Key-F20> 
  344.     event add <<Copy>> <Control-Key-c> <Key-F16>
  345.     event add <<Paste>> <Control-Key-v> <Key-F18>
  346.     event add <<PasteSelection>> <ButtonRelease-2>
  347.     event add <<Undo>> <Control-Key-z>
  348.     event add <<Redo>> <Control-Key-Z>
  349.     # Some OS's define a goofy (as in, not <Shift-Tab>) keysym
  350.     # that is returned when the user presses <Shift-Tab>.  In order for
  351.     # tab traversal to work, we have to add these keysyms to the 
  352.     # PrevWindow event.
  353.     # We use catch just in case the keysym isn't recognized.
  354.     # This is needed for XFree86 systems
  355.     catch { event add <<PrevWindow>> <ISO_Left_Tab> }
  356.     # This seems to be correct on *some* HP systems.
  357.     catch { event add <<PrevWindow>> <hpBackTab> }
  358.  
  359.     trace variable ::tk_strictMotif w ::tk::EventMotifBindings
  360.     set ::tk_strictMotif $::tk_strictMotif
  361.     }
  362.     "win32" {
  363.     event add <<Cut>> <Control-Key-x> <Shift-Key-Delete>
  364.     event add <<Copy>> <Control-Key-c> <Control-Key-Insert>
  365.     event add <<Paste>> <Control-Key-v> <Shift-Key-Insert>
  366.     event add <<PasteSelection>> <ButtonRelease-2>
  367.       event add <<Undo>> <Control-Key-z>
  368.     event add <<Redo>> <Control-Key-y>
  369.     }
  370.     "aqua" {
  371.     event add <<Cut>> <Command-Key-x> <Key-F2> 
  372.     event add <<Copy>> <Command-Key-c> <Key-F3>
  373.     event add <<Paste>> <Command-Key-v> <Key-F4>
  374.     event add <<PasteSelection>> <ButtonRelease-2>
  375.     event add <<Clear>> <Clear>
  376.       event add <<Undo>> <Command-Key-z>
  377.     event add <<Redo>> <Command-Key-y>
  378.     }
  379.     "classic" {
  380.     event add <<Cut>> <Control-Key-x> <Key-F2> 
  381.     event add <<Copy>> <Control-Key-c> <Key-F3>
  382.     event add <<Paste>> <Control-Key-v> <Key-F4>
  383.     event add <<PasteSelection>> <ButtonRelease-2>
  384.     event add <<Clear>> <Clear>
  385.     event add <<Undo>> <Control-Key-z> <Key-F1>
  386.     event add <<Redo>> <Control-Key-Z>
  387.     }
  388. }
  389. # ----------------------------------------------------------------------
  390. # Read in files that define all of the class bindings.
  391. # ----------------------------------------------------------------------
  392.  
  393. if {$::tk_library ne ""} {
  394.     if {[string equal $tcl_platform(platform) "macintosh"]} {
  395.     proc ::tk::SourceLibFile {file} {
  396.         if {[catch {
  397.         namespace eval :: \
  398.             [list source [file join $::tk_library $file.tcl]]
  399.         }]} {
  400.         namespace eval :: [list source -rsrc $file]
  401.         }
  402.     }
  403.     } else {
  404.     proc ::tk::SourceLibFile {file} {
  405.         namespace eval :: [list source [file join $::tk_library $file.tcl]]
  406.     }    
  407.     }
  408.     namespace eval ::tk {
  409.     SourceLibFile button
  410.     SourceLibFile entry
  411.     SourceLibFile listbox
  412.     SourceLibFile menu
  413.     SourceLibFile panedwindow
  414.     SourceLibFile scale
  415.     SourceLibFile scrlbar
  416.     SourceLibFile spinbox
  417.     SourceLibFile text
  418.     }
  419. }
  420. # ----------------------------------------------------------------------
  421. # Default bindings for keyboard traversal.
  422. # ----------------------------------------------------------------------
  423.  
  424. event add <<PrevWindow>> <Shift-Tab>
  425. bind all <Tab> {tk::TabToWindow [tk_focusNext %W]}
  426. bind all <<PrevWindow>> {tk::TabToWindow [tk_focusPrev %W]}
  427.  
  428. # ::tk::CancelRepeat --
  429. # This procedure is invoked to cancel an auto-repeat action described
  430. # by ::tk::Priv(afterId).  It's used by several widgets to auto-scroll
  431. # the widget when the mouse is dragged out of the widget with a
  432. # button pressed.
  433. #
  434. # Arguments:
  435. # None.
  436.  
  437. proc ::tk::CancelRepeat {} {
  438.     variable ::tk::Priv
  439.     after cancel $Priv(afterId)
  440.     set Priv(afterId) {}
  441. }
  442.  
  443. # ::tk::TabToWindow --
  444. # This procedure moves the focus to the given widget.  If the widget
  445. # is an entry, it selects the entire contents of the widget.
  446. #
  447. # Arguments:
  448. # w - Window to which focus should be set.
  449.  
  450. proc ::tk::TabToWindow {w} {
  451.     if {[string equal [winfo class $w] Entry]} {
  452.     $w selection range 0 end
  453.     $w icursor end
  454.     }
  455.     focus $w
  456. }
  457.  
  458. # ::tk::UnderlineAmpersand --
  459. # This procedure takes some text with ampersand and returns
  460. # text w/o ampersand and position of the ampersand.
  461. # Double ampersands are converted to single ones.
  462. # Position returned is -1 when there is no ampersand.
  463. #
  464. proc ::tk::UnderlineAmpersand {text} {
  465.     set idx [string first "&" $text]
  466.     if {$idx >= 0} {
  467.     set underline $idx
  468.     # ignore "&&"
  469.     while {[string match "&" [string index $text [expr {$idx + 1}]]]} {
  470.         set base [expr {$idx + 2}]
  471.         set idx  [string first "&" [string range $text $base end]]
  472.         if {$idx < 0} {
  473.         break
  474.         } else {
  475.         set underline [expr {$underline + $idx + 1}]
  476.         incr idx $base
  477.         }
  478.     }
  479.     }
  480.     if {$idx >= 0} {
  481.     regsub -all -- {&([^&])} $text {\1} text
  482.     } 
  483.     return [list $text $idx]
  484. }
  485.  
  486. # ::tk::SetAmpText -- 
  487. # Given widget path and text with "magic ampersands",
  488. # sets -text and -underline options for the widget
  489. #
  490. proc ::tk::SetAmpText {widget text} {
  491.     foreach {newtext under} [::tk::UnderlineAmpersand $text] {
  492.     $widget configure -text $newtext -underline $under
  493.     }
  494. }
  495.  
  496. # ::tk::AmpWidget --
  497. # Creates new widget, turning -text option into -text and
  498. # -underline options, returned by ::tk::UnderlineAmpersand.
  499. #
  500. proc ::tk::AmpWidget {class path args} {
  501.     set wcmd [list $class $path]
  502.     foreach {opt val} $args {
  503.     if {[string equal $opt {-text}]} {
  504.         foreach {newtext under} [::tk::UnderlineAmpersand $val] {
  505.         lappend wcmd -text $newtext -underline $under
  506.         }
  507.     } else {
  508.         lappend wcmd $opt $val
  509.     }
  510.     }
  511.     eval $wcmd
  512.     if {$class=="button"} {
  513.     bind $path <<AltUnderlined>> [list $path invoke]
  514.     }
  515.     return $path
  516. }
  517.  
  518. # ::tk::FindAltKeyTarget --
  519. # search recursively through the hierarchy of visible widgets
  520. # to find button or label which has $char as underlined character
  521. #
  522. proc ::tk::FindAltKeyTarget {path char} {
  523.     switch [winfo class $path] {
  524.     Button -
  525.     Label {
  526.         if {[string equal -nocase $char \
  527.         [string index [$path cget -text] \
  528.         [$path cget -underline]]]} {return $path} else {return {}}
  529.     }
  530.     default {
  531.         foreach child \
  532.         [concat [grid slaves $path] \
  533.         [pack slaves $path] \
  534.         [place slaves $path] ] {
  535.         if {""!=[set target [::tk::FindAltKeyTarget $child $char]]} {
  536.             return $target
  537.         }
  538.         }
  539.     }
  540.     }
  541.     return {}
  542. }
  543.  
  544. # ::tk::AltKeyInDialog --
  545. # <Alt-Key> event handler for standard dialogs. Sends <<AltUnderlined>>
  546. # to button or label which has appropriate underlined character
  547. #
  548. proc ::tk::AltKeyInDialog {path key} {
  549.     set target [::tk::FindAltKeyTarget $path $key]
  550.     if { $target == ""} return
  551.     event generate $target <<AltUnderlined>>
  552. }
  553.  
  554. # ::tk::mcmaxamp --
  555. # Replacement for mcmax, used for texts with "magic ampersand" in it.
  556. #
  557.  
  558. proc ::tk::mcmaxamp {args} {
  559.     set maxlen 0
  560.     foreach arg $args {
  561.     set length [string length [lindex [::tk::UnderlineAmpersand [mc $arg]] 0]]
  562.     if {$length>$maxlen} {
  563.         set maxlen $length
  564.     }
  565.     }
  566.     return $maxlen
  567. }
  568. # For now, turn off the custom mdef proc for the mac:
  569.  
  570. if {[string equal [tk windowingsystem] "aqua"]} {
  571.     namespace eval ::tk::mac {
  572.     set useCustomMDEF 0
  573.     }
  574. }
  575.