home *** CD-ROM | disk | FTP | other *** search
/ PCNET 2006 September - Disc 1 / PCNET_CD_2006_09.iso / linux / puppy-barebones-2.01r2.iso / pup_201.sfs / usr / lib / tk8.5 / tk.tcl < prev    next >
Encoding:
Text File  |  2006-06-17  |  16.7 KB  |  584 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.56 2006/01/25 18:22:04 dgp 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.5
  17. package require -exact Tcl 8.5
  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 [format $src {expand}$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] && $::tk_library ne "" && \
  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 {$place eq ""} {
  83.     set x [expr {([winfo screenwidth $w]-[winfo reqwidth $w])/2}]
  84.     set y [expr {([winfo screenheight $w]-[winfo reqheight $w])/2}]
  85.     set checkBounds 0
  86.     } elseif {[string equal -length [string length $place] $place "pointer"]} {
  87.     ## place at POINTER (centered if $anchor == center)
  88.     if {[string equal -length [string length $anchor] $anchor "center"]} {
  89.         set x [expr {[winfo pointerx $w]-[winfo reqwidth $w]/2}]
  90.         set y [expr {[winfo pointery $w]-[winfo reqheight $w]/2}]
  91.     } else {
  92.         set x [winfo pointerx $w]
  93.         set y [winfo pointery $w]
  94.     }
  95.     } elseif {[string equal -length [string length $place] $place "widget"] && \
  96.         [winfo exists $anchor] && [winfo ismapped $anchor]} {
  97.     ## center about WIDGET $anchor, widget must be mapped
  98.     set x [expr {[winfo rootx $anchor] + \
  99.         ([winfo width $anchor]-[winfo reqwidth $w])/2}]
  100.     set y [expr {[winfo rooty $anchor] + \
  101.         ([winfo height $anchor]-[winfo reqheight $w])/2}]
  102.     } else {
  103.     set x [expr {([winfo screenwidth $w]-[winfo reqwidth $w])/2}]
  104.     set y [expr {([winfo screenheight $w]-[winfo reqheight $w])/2}]
  105.     set checkBounds 0
  106.     }
  107.     if {[tk windowingsystem] eq "win32"} {
  108.         # Bug 533519: win32 multiple desktops may produce negative geometry.
  109.         set checkBounds 0
  110.     }
  111.     if {$checkBounds} {
  112.     if {$x < 0} {
  113.         set x 0
  114.     } elseif {$x > ([winfo screenwidth $w]-[winfo reqwidth $w])} {
  115.         set x [expr {[winfo screenwidth $w]-[winfo reqwidth $w]}]
  116.     }
  117.     if {$y < 0} {
  118.         set y 0
  119.     } elseif {$y > ([winfo screenheight $w]-[winfo reqheight $w])} {
  120.         set y [expr {[winfo screenheight $w]-[winfo reqheight $w]}]
  121.     }
  122.     if {[tk windowingsystem] eq "aqua"} {
  123.         # Avoid the native menu bar which sits on top of everything.
  124.         if {$y < 20} { set y 20 }
  125.     }
  126.     }
  127.     wm geometry $w +$x+$y
  128.     wm deiconify $w
  129. }
  130.  
  131. # ::tk::SetFocusGrab --
  132. #   swap out current focus and grab temporarily (for dialogs)
  133. # Arguments:
  134. #   grab    new window to grab
  135. #   focus    window to give focus to
  136. # Results:
  137. #   Returns nothing
  138. #
  139. proc ::tk::SetFocusGrab {grab {focus {}}} {
  140.     set index "$grab,$focus"
  141.     upvar ::tk::FocusGrab($index) data
  142.  
  143.     lappend data [focus]
  144.     set oldGrab [grab current $grab]
  145.     lappend data $oldGrab
  146.     if {[winfo exists $oldGrab]} {
  147.     lappend data [grab status $oldGrab]
  148.     }
  149.     # The "grab" command will fail if another application
  150.     # already holds the grab.  So catch it.
  151.     catch {grab $grab}
  152.     if {[winfo exists $focus]} {
  153.     focus $focus
  154.     }
  155. }
  156.  
  157. # ::tk::RestoreFocusGrab --
  158. #   restore old focus and grab (for dialogs)
  159. # Arguments:
  160. #   grab    window that had taken grab
  161. #   focus    window that had taken focus
  162. #   destroy    destroy|withdraw - how to handle the old grabbed window
  163. # Results:
  164. #   Returns nothing
  165. #
  166. proc ::tk::RestoreFocusGrab {grab focus {destroy destroy}} {
  167.     set index "$grab,$focus"
  168.     if {[info exists ::tk::FocusGrab($index)]} {
  169.     foreach {oldFocus oldGrab oldStatus} $::tk::FocusGrab($index) { break }
  170.     unset ::tk::FocusGrab($index)
  171.     } else {
  172.     set oldGrab ""
  173.     }
  174.  
  175.     catch {focus $oldFocus}
  176.     grab release $grab
  177.     if {$destroy eq "withdraw"} {
  178.     wm withdraw $grab
  179.     } else {
  180.     destroy $grab
  181.     }
  182.     if {[winfo exists $oldGrab] && [winfo ismapped $oldGrab]} {
  183.     if {$oldStatus eq "global"} {
  184.         grab -global $oldGrab
  185.     } else {
  186.         grab $oldGrab
  187.     }
  188.     }
  189. }
  190.  
  191. # ::tk::GetSelection --
  192. #   This tries to obtain the default selection.  On Unix, we first try
  193. #   and get a UTF8_STRING, a type supported by modern Unix apps for
  194. #   passing Unicode data safely.  We fall back on the default STRING
  195. #   type otherwise.  On Windows, only the STRING type is necessary.
  196. # Arguments:
  197. #   w    The widget for which the selection will be retrieved.
  198. #    Important for the -displayof property.
  199. #   sel    The source of the selection (PRIMARY or CLIPBOARD)
  200. # Results:
  201. #   Returns the selection, or an error if none could be found
  202. #
  203. if {$tcl_platform(platform) eq "unix"} {
  204.     proc ::tk::GetSelection {w {sel PRIMARY}} {
  205.     if {[catch {selection get -displayof $w -selection $sel \
  206.         -type UTF8_STRING} txt] \
  207.         && [catch {selection get -displayof $w -selection $sel} txt]} {
  208.         return -code error "could not find default selection"
  209.     } else {
  210.         return $txt
  211.     }
  212.     }
  213. } else {
  214.     proc ::tk::GetSelection {w {sel PRIMARY}} {
  215.     if {[catch {selection get -displayof $w -selection $sel} txt]} {
  216.         return -code error "could not find default selection"
  217.     } else {
  218.         return $txt
  219.     }
  220.     }
  221. }
  222.  
  223. # ::tk::ScreenChanged --
  224. # This procedure is invoked by the binding mechanism whenever the
  225. # "current" screen is changing.  The procedure does two things.
  226. # First, it uses "upvar" to make variable "::tk::Priv" point at an
  227. # array variable that holds state for the current display.  Second,
  228. # it initializes the array if it didn't already exist.
  229. #
  230. # Arguments:
  231. # screen -        The name of the new screen.
  232.  
  233. proc ::tk::ScreenChanged screen {
  234.     set x [string last . $screen]
  235.     if {$x > 0} {
  236.     set disp [string range $screen 0 [expr {$x - 1}]]
  237.     } else {
  238.     set disp $screen
  239.     }
  240.  
  241.     uplevel #0 upvar #0 ::tk::Priv.$disp ::tk::Priv
  242.     variable ::tk::Priv
  243.     global tcl_platform
  244.  
  245.     if {[info exists Priv]} {
  246.     set Priv(screen) $screen
  247.     return
  248.     }
  249.     array set Priv {
  250.     activeMenu    {}
  251.     activeItem    {}
  252.     afterId        {}
  253.     buttons        0
  254.     buttonWindow    {}
  255.     dragging    0
  256.     focus        {}
  257.     grab        {}
  258.     initPos        {}
  259.     inMenubutton    {}
  260.     listboxPrev    {}
  261.     menuBar        {}
  262.     mouseMoved    0
  263.     oldGrab        {}
  264.     popup        {}
  265.     postedMb    {}
  266.     pressX        0
  267.     pressY        0
  268.     prevPos        0
  269.     selectMode    char
  270.     }
  271.     set Priv(screen) $screen
  272.     set Priv(tearoff) [string equal [tk windowingsystem] "x11"]
  273.     set Priv(window) {}
  274. }
  275.  
  276. # Do initial setup for Priv, so that it is always bound to something
  277. # (otherwise, if someone references it, it may get set to a non-upvar-ed
  278. # value, which will cause trouble later).
  279.  
  280. tk::ScreenChanged [winfo screen .]
  281.  
  282. # ::tk::EventMotifBindings --
  283. # This procedure is invoked as a trace whenever ::tk_strictMotif is
  284. # changed.  It is used to turn on or turn off the motif virtual
  285. # bindings.
  286. #
  287. # Arguments:
  288. # n1 - the name of the variable being changed ("::tk_strictMotif").
  289.  
  290. proc ::tk::EventMotifBindings {n1 dummy dummy} {
  291.     upvar $n1 name
  292.     
  293.     if {$name} {
  294.     set op delete
  295.     } else {
  296.     set op add
  297.     }
  298.  
  299.     event $op <<Cut>> <Control-Key-w>
  300.     event $op <<Copy>> <Meta-Key-w> 
  301.     event $op <<Paste>> <Control-Key-y>
  302.     event $op <<Undo>> <Control-underscore>
  303. }
  304.  
  305. #----------------------------------------------------------------------
  306. # Define common dialogs on platforms where they are not implemented 
  307. # using compiled code.
  308. #----------------------------------------------------------------------
  309.  
  310. if {![llength [info commands tk_chooseColor]]} {
  311.     proc ::tk_chooseColor {args} {
  312.     return [tk::dialog::color:: {expand}$args]
  313.     }
  314. }
  315. if {![llength [info commands tk_getOpenFile]]} {
  316.     proc ::tk_getOpenFile {args} {
  317.     if {$::tk_strictMotif} {
  318.         return [tk::MotifFDialog open {expand}$args]
  319.     } else {
  320.         return [::tk::dialog::file:: open {expand}$args]
  321.     }
  322.     }
  323. }
  324. if {![llength [info commands tk_getSaveFile]]} {
  325.     proc ::tk_getSaveFile {args} {
  326.     if {$::tk_strictMotif} {
  327.         return [tk::MotifFDialog save {expand}$args]
  328.     } else {
  329.         return [::tk::dialog::file:: save {expand}$args]
  330.     }
  331.     }
  332. }
  333. if {![llength [info commands tk_messageBox]]} {
  334.     proc ::tk_messageBox {args} {
  335.     return [tk::MessageBox {expand}$args]
  336.     }
  337. }
  338. if {![llength [info command tk_chooseDirectory]]} {
  339.     proc ::tk_chooseDirectory {args} {
  340.     return [::tk::dialog::file::chooseDir:: {expand}$args]
  341.     }
  342. }
  343.     
  344. #----------------------------------------------------------------------
  345. # Define the set of common virtual events.
  346. #----------------------------------------------------------------------
  347.  
  348. switch -- [tk windowingsystem] {
  349.     "x11" {
  350.     event add <<Cut>> <Control-Key-x> <Key-F20> 
  351.     event add <<Copy>> <Control-Key-c> <Key-F16>
  352.     event add <<Paste>> <Control-Key-v> <Key-F18>
  353.     event add <<PasteSelection>> <ButtonRelease-2>
  354.     event add <<Undo>> <Control-Key-z>
  355.     event add <<Redo>> <Control-Key-Z>
  356.     # Some OS's define a goofy (as in, not <Shift-Tab>) keysym
  357.     # that is returned when the user presses <Shift-Tab>.  In order for
  358.     # tab traversal to work, we have to add these keysyms to the 
  359.     # PrevWindow event.
  360.     # We use catch just in case the keysym isn't recognized.
  361.     # This is needed for XFree86 systems
  362.     catch { event add <<PrevWindow>> <ISO_Left_Tab> }
  363.     # This seems to be correct on *some* HP systems.
  364.     catch { event add <<PrevWindow>> <hpBackTab> }
  365.  
  366.     trace add variable ::tk_strictMotif write ::tk::EventMotifBindings
  367.     set ::tk_strictMotif $::tk_strictMotif
  368.     }
  369.     "win32" {
  370.     event add <<Cut>> <Control-Key-x> <Shift-Key-Delete>
  371.     event add <<Copy>> <Control-Key-c> <Control-Key-Insert>
  372.     event add <<Paste>> <Control-Key-v> <Shift-Key-Insert>
  373.     event add <<PasteSelection>> <ButtonRelease-2>
  374.       event add <<Undo>> <Control-Key-z>
  375.     event add <<Redo>> <Control-Key-y>
  376.     }
  377.     "aqua" {
  378.     event add <<Cut>> <Command-Key-x> <Key-F2> 
  379.     event add <<Copy>> <Command-Key-c> <Key-F3>
  380.     event add <<Paste>> <Command-Key-v> <Key-F4>
  381.     event add <<PasteSelection>> <ButtonRelease-2>
  382.     event add <<Clear>> <Clear>
  383.       event add <<Undo>> <Command-Key-z>
  384.     event add <<Redo>> <Command-Key-y>
  385.     }
  386. }
  387. # ----------------------------------------------------------------------
  388. # Read in files that define all of the class bindings.
  389. # ----------------------------------------------------------------------
  390.  
  391. if {$::tk_library ne ""} {
  392.     proc ::tk::SourceLibFile {file} {
  393.         namespace eval :: [list source [file join $::tk_library $file.tcl]]
  394.     }    
  395.     namespace eval ::tk {
  396.     SourceLibFile button
  397.     SourceLibFile entry
  398.     SourceLibFile listbox
  399.     SourceLibFile menu
  400.     SourceLibFile panedwindow
  401.     SourceLibFile scale
  402.     SourceLibFile scrlbar
  403.     SourceLibFile spinbox
  404.     SourceLibFile text
  405.     }
  406. }
  407. # ----------------------------------------------------------------------
  408. # Default bindings for keyboard traversal.
  409. # ----------------------------------------------------------------------
  410.  
  411. event add <<PrevWindow>> <Shift-Tab>
  412. bind all <Tab> {tk::TabToWindow [tk_focusNext %W]}
  413. bind all <<PrevWindow>> {tk::TabToWindow [tk_focusPrev %W]}
  414.  
  415. # ::tk::CancelRepeat --
  416. # This procedure is invoked to cancel an auto-repeat action described
  417. # by ::tk::Priv(afterId).  It's used by several widgets to auto-scroll
  418. # the widget when the mouse is dragged out of the widget with a
  419. # button pressed.
  420. #
  421. # Arguments:
  422. # None.
  423.  
  424. proc ::tk::CancelRepeat {} {
  425.     variable ::tk::Priv
  426.     after cancel $Priv(afterId)
  427.     set Priv(afterId) {}
  428. }
  429.  
  430. # ::tk::TabToWindow --
  431. # This procedure moves the focus to the given widget.
  432. # It sends a <<TraverseOut>> virtual event to the previous focus window, 
  433. # if any, before changing the focus, and a <<TraverseIn>> event
  434. # to the new focus window afterwards.
  435. #
  436. # Arguments:
  437. # w - Window to which focus should be set.
  438.  
  439. proc ::tk::TabToWindow {w} {
  440.     set focus [focus]
  441.     if {$focus ne ""} {
  442.     event generate $focus <<TraverseOut>>
  443.     }
  444.     focus $w
  445.     event generate $w <<TraverseIn>>
  446. }
  447.  
  448. # ::tk::UnderlineAmpersand --
  449. # This procedure takes some text with ampersand and returns
  450. # text w/o ampersand and position of the ampersand.
  451. # Double ampersands are converted to single ones.
  452. # Position returned is -1 when there is no ampersand.
  453. #
  454. proc ::tk::UnderlineAmpersand {text} {
  455.     set idx [string first "&" $text]
  456.     if {$idx >= 0} {
  457.     set underline $idx
  458.     # ignore "&&"
  459.     while {[string match "&" [string index $text [expr {$idx + 1}]]]} {
  460.         set base [expr {$idx + 2}]
  461.         set idx  [string first "&" [string range $text $base end]]
  462.         if {$idx < 0} {
  463.         break
  464.         } else {
  465.         set underline [expr {$underline + $idx + 1}]
  466.         incr idx $base
  467.         }
  468.     }
  469.     }
  470.     if {$idx >= 0} {
  471.     regsub -all -- {&([^&])} $text {\1} text
  472.     } 
  473.     return [list $text $idx]
  474. }
  475.  
  476. # ::tk::SetAmpText -- 
  477. # Given widget path and text with "magic ampersands",
  478. # sets -text and -underline options for the widget
  479. #
  480. proc ::tk::SetAmpText {widget text} {
  481.     lassign [UnderlineAmpersand $text] newtext under
  482.     $widget configure -text $newtext -underline $under
  483. }
  484.  
  485. # ::tk::AmpWidget --
  486. # Creates new widget, turning -text option into -text and
  487. # -underline options, returned by ::tk::UnderlineAmpersand.
  488. #
  489. proc ::tk::AmpWidget {class path args} {
  490.     set options {}
  491.     foreach {opt val} $args {
  492.     if {$opt eq "-text"} {
  493.         lassign [UnderlineAmpersand $val] newtext under
  494.         lappend options -text $newtext -underline $under
  495.     } else {
  496.         lappend options $opt $val
  497.     }
  498.     }
  499.     set result [$class $path {expand}$options]
  500.     if {$class eq "button"} {
  501.     bind $path <<AltUnderlined>> [list $path invoke]
  502.     }
  503.     return $result
  504. }
  505.  
  506. # ::tk::AmpMenuArgs --
  507. # Processes arguments for a menu entry, turning -label option into
  508. # -label and -underline options, returned by ::tk::UnderlineAmpersand.
  509. #
  510. proc ::tk::AmpMenuArgs {widget add type args} {
  511.     set options {}
  512.     foreach {opt val} $args {
  513.     if {$opt eq "-label"} {
  514.         lassign [UnderlineAmpersand $val] newlabel under
  515.         lappend options -label $newlabel -underline $under
  516.     } else {
  517.         lappend options $opt $val
  518.     }
  519.     }
  520.     $widget add $type {expand}$options
  521. }
  522.  
  523. # ::tk::FindAltKeyTarget --
  524. # search recursively through the hierarchy of visible widgets
  525. # to find button or label which has $char as underlined character
  526. #
  527. proc ::tk::FindAltKeyTarget {path char} {
  528.     switch -- [winfo class $path] {
  529.     Button -
  530.     Label {
  531.         if {[string equal -nocase $char \
  532.           [string index [$path cget -text] [$path cget -underline]]]} {
  533.         return $path
  534.         } else {
  535.         return {}
  536.         }
  537.     }
  538.     default {
  539.         foreach child [concat [grid slaves $path] \
  540.             [pack slaves $path] [place slaves $path]] {
  541.         set target [FindAltKeyTarget $child $char]
  542.         if {$target ne ""} {
  543.             return $target
  544.         }
  545.         }
  546.     }
  547.     }
  548.     return {}
  549. }
  550.  
  551. # ::tk::AltKeyInDialog --
  552. # <Alt-Key> event handler for standard dialogs. Sends <<AltUnderlined>>
  553. # to button or label which has appropriate underlined character
  554. #
  555. proc ::tk::AltKeyInDialog {path key} {
  556.     set target [FindAltKeyTarget $path $key]
  557.     if { $target eq ""} return
  558.     event generate $target <<AltUnderlined>>
  559. }
  560.  
  561. # ::tk::mcmaxamp --
  562. # Replacement for mcmax, used for texts with "magic ampersand" in it.
  563. #
  564.  
  565. proc ::tk::mcmaxamp {args} {
  566.     set maxlen 0
  567.     foreach arg $args {
  568.     # Should we run [mc] in caller's namespace?
  569.     lassign [UnderlineAmpersand [mc $arg]] msg
  570.     set length [string length $msg]
  571.     if {$length > $maxlen} {
  572.         set maxlen $length
  573.     }
  574.     }
  575.     return $maxlen
  576. }
  577. # For now, turn off the custom mdef proc for the mac:
  578.  
  579. if {[tk windowingsystem] eq "aqua"} {
  580.     namespace eval ::tk::mac {
  581.     set useCustomMDEF 0
  582.     }
  583. }
  584.