home *** CD-ROM | disk | FTP | other *** search
/ PC World 2002 May / PCWorld_2002-05_cd.bin / Software / TemaCD / activetcltk / ActiveTcl8.3.4.1-8.win32-ix86.exe / ActiveTcl8.3.4.1-win32-ix86 / lib / tk8.3 / tk.tcl < prev    next >
Encoding:
Text File  |  2001-10-22  |  11.0 KB  |  384 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.20.2.2 2001/10/19 17:33:00 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 Scriptics Corporation.
  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.  
  17. package require -exact Tk 8.3
  18. package require -exact Tcl 8.3
  19.  
  20. # Add Tk's directory to the end of the auto-load search path, if it
  21. # isn't already on the path:
  22.  
  23. if {[info exists auto_path] && [string compare {} $tk_library] && \
  24.     [lsearch -exact $auto_path $tk_library] < 0} {
  25.     lappend auto_path $tk_library
  26. }
  27.  
  28. # Turn off strict Motif look and feel as a default.
  29.  
  30. set tk_strictMotif 0
  31.  
  32. # Turn on useinputmethods (X Input Methods) by default.
  33. # We catch this because safe interpreters may not allow the call.
  34.  
  35. catch {tk useinputmethods 1}
  36.  
  37. # Create a ::tk namespace
  38.  
  39. namespace eval ::tk {
  40. }
  41.  
  42. # ::tk::PlaceWindow --
  43. #   place a toplevel at a particular position
  44. # Arguments:
  45. #   toplevel    name of toplevel window
  46. #   ?placement?    pointer ?center? ; places $w centered on the pointer
  47. #        widget widgetPath ; centers $w over widget_name
  48. #        defaults to placing toplevel in the middle of the screen
  49. #   ?anchor?    center or widgetPath
  50. # Results:
  51. #   Returns nothing
  52. #
  53. proc ::tk::PlaceWindow {w {place ""} {anchor ""}} {
  54.     wm withdraw $w
  55.     update idletasks
  56.     set checkBounds 1
  57.     if {[string equal -len [string length $place] $place "pointer"]} {
  58.     ## place at POINTER (centered if $anchor == center)
  59.     if {[string equal -len [string length $anchor] $anchor "center"]} {
  60.         set x [expr {[winfo pointerx $w]-[winfo reqwidth $w]/2}]
  61.         set y [expr {[winfo pointery $w]-[winfo reqheight $w]/2}]
  62.     } else {
  63.         set x [winfo pointerx $w]
  64.         set y [winfo pointery $w]
  65.     }
  66.     } elseif {[string equal -len [string length $place] $place "widget"] && \
  67.         [winfo exists $anchor] && [winfo ismapped $anchor]} {
  68.     ## center about WIDGET $anchor, widget must be mapped
  69.     set x [expr {[winfo rootx $anchor] + \
  70.         ([winfo width $anchor]-[winfo reqwidth $w])/2}]
  71.     set y [expr {[winfo rooty $anchor] + \
  72.         ([winfo height $anchor]-[winfo reqheight $w])/2}]
  73.     } else {
  74.     set x [expr {([winfo screenwidth $w]-[winfo reqwidth $w])/2}]
  75.     set y [expr {([winfo screenheight $w]-[winfo reqheight $w])/2}]
  76.     set checkBounds 0
  77.     }
  78.     if {$checkBounds} {
  79.     if {$x < 0} {
  80.         set x 0
  81.     } elseif {$x > ([winfo screenwidth $w]-[winfo reqwidth $w])} {
  82.         set x [expr {[winfo screenwidth $w]-[winfo reqwidth $w]}]
  83.     }
  84.     if {$y < 0} {
  85.         set y 0
  86.     } elseif {$y > ([winfo screenheight $w]-[winfo reqheight $w])} {
  87.         set y [expr {[winfo screenheight $w]-[winfo reqheight $w]}]
  88.     }
  89.     }
  90.     wm geometry $w +$x+$y
  91.     wm deiconify $w
  92. }
  93.  
  94. # ::tk::SetFocusGrab --
  95. #   swap out current focus and grab temporarily (for dialogs)
  96. # Arguments:
  97. #   grab    new window to grab
  98. #   focus    window to give focus to
  99. # Results:
  100. #   Returns nothing
  101. #
  102. proc ::tk::SetFocusGrab {grab {focus {}}} {
  103.     set index "$grab,$focus"
  104.     upvar ::tk::FocusGrab($index) data
  105.  
  106.     lappend data [focus]
  107.     set oldGrab [grab current $grab]
  108.     lappend data $oldGrab
  109.     if {[winfo exists $oldGrab]} {
  110.     lappend data [grab status $oldGrab]
  111.     }
  112.     # The "grab" command will fail if another application
  113.     # already holds the grab.  So catch it.
  114.     catch {grab $grab}
  115.     if {[winfo exists $focus]} {
  116.     focus $focus
  117.     }
  118. }
  119.  
  120. # ::tk::RestoreFocusGrab --
  121. #   restore old focus and grab (for dialogs)
  122. # Arguments:
  123. #   grab    window that had taken grab
  124. #   focus    window that had taken focus
  125. #   destroy    destroy|withdraw - how to handle the old grabbed window
  126. # Results:
  127. #   Returns nothing
  128. #
  129. proc ::tk::RestoreFocusGrab {grab focus {destroy destroy}} {
  130.     set index "$grab,$focus"
  131.     foreach {oldFocus oldGrab oldStatus} $::tk::FocusGrab($index) { break }
  132.     unset ::tk::FocusGrab($index)
  133.  
  134.     catch {focus $oldFocus}
  135.     grab release $grab
  136.     if {[string equal $destroy "withdraw"]} {
  137.     wm withdraw $grab
  138.     } else {
  139.     destroy $grab
  140.     }
  141.     if {[winfo exists $oldGrab] && [winfo ismapped $oldGrab]} {
  142.     if {[string equal $oldStatus "global"]} {
  143.         grab -global $oldGrab
  144.     } else {
  145.         grab $oldGrab
  146.     }
  147.     }
  148. }
  149.  
  150. # ::tk::GetSelection --
  151. #   This tries to obtain the default selection.
  152. #   This shadows the 8.4 version which handles UTF8_STRING as well.
  153. # Arguments:
  154. #   w    The widget for which the selection will be retrieved.
  155. #    Important for the -displayof property.
  156. #   sel    The source of the selection (PRIMARY or CLIPBOARD)
  157. # Results:
  158. #   Returns the selection, or an error if none could be found
  159. #
  160. proc ::tk::GetSelection {w {sel PRIMARY}} {
  161.     if {[catch {selection get -displayof $w -selection $sel} txt]} {
  162.     return -code error "could not find default selection"
  163.     } else {
  164.     return $txt
  165.     }
  166. }
  167.  
  168. # tkScreenChanged --
  169. # This procedure is invoked by the binding mechanism whenever the
  170. # "current" screen is changing.  The procedure does two things.
  171. # First, it uses "upvar" to make global variable "tkPriv" point at an
  172. # array variable that holds state for the current display.  Second,
  173. # it initializes the array if it didn't already exist.
  174. #
  175. # Arguments:
  176. # screen -        The name of the new screen.
  177.  
  178. proc tkScreenChanged screen {
  179.     set x [string last . $screen]
  180.     if {$x > 0} {
  181.     set disp [string range $screen 0 [expr {$x - 1}]]
  182.     } else {
  183.     set disp $screen
  184.     }
  185.  
  186.     uplevel #0 upvar #0 tkPriv.$disp tkPriv
  187.     global tkPriv
  188.     global tcl_platform
  189.  
  190.     if {[info exists tkPriv]} {
  191.     set tkPriv(screen) $screen
  192.     return
  193.     }
  194.     array set tkPriv {
  195.     activeMenu    {}
  196.     activeItem    {}
  197.     afterId        {}
  198.     buttons        0
  199.     buttonWindow    {}
  200.     dragging    0
  201.     focus        {}
  202.     grab        {}
  203.     initPos        {}
  204.     inMenubutton    {}
  205.     listboxPrev    {}
  206.     menuBar        {}
  207.     mouseMoved    0
  208.     oldGrab        {}
  209.     popup        {}
  210.     postedMb    {}
  211.     pressX        0
  212.     pressY        0
  213.     prevPos        0
  214.     selectMode    char
  215.     }
  216.     set tkPriv(screen) $screen
  217.     set tkPriv(tearoff) [string equal $tcl_platform(platform) "unix"]
  218.     set tkPriv(window) {}
  219. }
  220.  
  221. # Do initial setup for tkPriv, so that it is always bound to something
  222. # (otherwise, if someone references it, it may get set to a non-upvar-ed
  223. # value, which will cause trouble later).
  224.  
  225. tkScreenChanged [winfo screen .]
  226.  
  227. # tkEventMotifBindings --
  228. # This procedure is invoked as a trace whenever tk_strictMotif is
  229. # changed.  It is used to turn on or turn off the motif virtual
  230. # bindings.
  231. #
  232. # Arguments:
  233. # n1 - the name of the variable being changed ("tk_strictMotif").
  234.  
  235. proc tkEventMotifBindings {n1 dummy dummy} {
  236.     upvar $n1 name
  237.     
  238.     if {$name} {
  239.     set op delete
  240.     } else {
  241.     set op add
  242.     }
  243.  
  244.     event $op <<Cut>> <Control-Key-w>
  245.     event $op <<Copy>> <Meta-Key-w> 
  246.     event $op <<Paste>> <Control-Key-y>
  247. }
  248.  
  249. #----------------------------------------------------------------------
  250. # Define common dialogs on platforms where they are not implemented 
  251. # using compiled code.
  252. #----------------------------------------------------------------------
  253.  
  254. if {[string equal [info commands tk_chooseColor] ""]} {
  255.     proc tk_chooseColor {args} {
  256.     return [eval tkColorDialog $args]
  257.     }
  258. }
  259. if {[string equal [info commands tk_getOpenFile] ""]} {
  260.     proc tk_getOpenFile {args} {
  261.     if {$::tk_strictMotif} {
  262.         return [eval tkMotifFDialog open $args]
  263.     } else {
  264.         return [eval ::tk::dialog::file::tkFDialog open $args]
  265.     }
  266.     }
  267. }
  268. if {[string equal [info commands tk_getSaveFile] ""]} {
  269.     proc tk_getSaveFile {args} {
  270.     if {$::tk_strictMotif} {
  271.         return [eval tkMotifFDialog save $args]
  272.     } else {
  273.         return [eval ::tk::dialog::file::tkFDialog save $args]
  274.     }
  275.     }
  276. }
  277. if {[string equal [info commands tk_messageBox] ""]} {
  278.     proc tk_messageBox {args} {
  279.     return [eval tkMessageBox $args]
  280.     }
  281. }
  282. if {[string equal [info command tk_chooseDirectory] ""]} {
  283.     proc tk_chooseDirectory {args} {
  284.     return [eval ::tk::dialog::file::chooseDir::tkChooseDirectory $args]
  285.     }
  286. }
  287.     
  288. #----------------------------------------------------------------------
  289. # Define the set of common virtual events.
  290. #----------------------------------------------------------------------
  291.  
  292. switch $tcl_platform(platform) {
  293.     "unix" {
  294.     event add <<Cut>> <Control-Key-x> <Key-F20> 
  295.     event add <<Copy>> <Control-Key-c> <Key-F16>
  296.     event add <<Paste>> <Control-Key-v> <Key-F18>
  297.     event add <<PasteSelection>> <ButtonRelease-2>
  298.     # Some OS's define a goofy (as in, not <Shift-Tab>) keysym
  299.     # that is returned when the user presses <Shift-Tab>.  In order for
  300.     # tab traversal to work, we have to add these keysyms to the 
  301.     # PrevWindow event.
  302.     # The info exists is necessary, because tcl_platform(os) doesn't
  303.     # exist in safe interpreters.
  304.     if {[info exists tcl_platform(os)]} {
  305.         switch $tcl_platform(os) {
  306.         "IRIX"  -
  307.         "Linux" { event add <<PrevWindow>> <ISO_Left_Tab> }
  308.         "HP-UX" {
  309.             # This seems to be correct on *some* HP systems.
  310.             catch { event add <<PrevWindow>> <hpBackTab> }
  311.         }
  312.         }
  313.     }
  314.     trace variable tk_strictMotif w tkEventMotifBindings
  315.     set tk_strictMotif $tk_strictMotif
  316.     }
  317.     "windows" {
  318.     event add <<Cut>> <Control-Key-x> <Shift-Key-Delete>
  319.     event add <<Copy>> <Control-Key-c> <Control-Key-Insert>
  320.     event add <<Paste>> <Control-Key-v> <Shift-Key-Insert>
  321.     event add <<PasteSelection>> <ButtonRelease-2>
  322.     }
  323.     "macintosh" {
  324.     event add <<Cut>> <Control-Key-x> <Key-F2> 
  325.     event add <<Copy>> <Control-Key-c> <Key-F3>
  326.     event add <<Paste>> <Control-Key-v> <Key-F4>
  327.     event add <<PasteSelection>> <ButtonRelease-2>
  328.     event add <<Clear>> <Clear>
  329.     }
  330. }
  331.  
  332. # ----------------------------------------------------------------------
  333. # Read in files that define all of the class bindings.
  334. # ----------------------------------------------------------------------
  335.  
  336. if {[string compare $tcl_platform(platform) "macintosh"] && \
  337.     [string compare {} $tk_library]} {
  338.     source [file join $tk_library button.tcl]
  339.     source [file join $tk_library entry.tcl]
  340.     source [file join $tk_library listbox.tcl]
  341.     source [file join $tk_library menu.tcl]
  342.     source [file join $tk_library scale.tcl]
  343.     source [file join $tk_library scrlbar.tcl]
  344.     source [file join $tk_library text.tcl]
  345. }
  346.  
  347. # ----------------------------------------------------------------------
  348. # Default bindings for keyboard traversal.
  349. # ----------------------------------------------------------------------
  350.  
  351. event add <<PrevWindow>> <Shift-Tab>
  352. bind all <Tab> {tkTabToWindow [tk_focusNext %W]}
  353. bind all <<PrevWindow>> {tkTabToWindow [tk_focusPrev %W]}
  354.  
  355. # tkCancelRepeat --
  356. # This procedure is invoked to cancel an auto-repeat action described
  357. # by tkPriv(afterId).  It's used by several widgets to auto-scroll
  358. # the widget when the mouse is dragged out of the widget with a
  359. # button pressed.
  360. #
  361. # Arguments:
  362. # None.
  363.  
  364. proc tkCancelRepeat {} {
  365.     global tkPriv
  366.     after cancel $tkPriv(afterId)
  367.     set tkPriv(afterId) {}
  368. }
  369.  
  370. # tkTabToWindow --
  371. # This procedure moves the focus to the given widget.  If the widget
  372. # is an entry, it selects the entire contents of the widget.
  373. #
  374. # Arguments:
  375. # w - Window to which focus should be set.
  376.  
  377. proc tkTabToWindow {w} {
  378.     if {[string equal [winfo class $w] Entry]} {
  379.     $w selection range 0 end
  380.     $w icursor end
  381.     }
  382.     focus $w
  383. }
  384.