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