1# cursor.tcl -- 2# 3# Tk cursor handling routines 4# 5# Copyright (c) 2001-2009 by Jeffrey Hobbs 6# 7# See the file "license.terms" for information on usage and redistribution 8# of this file, and for a DISCLAIMER OF ALL WARRANTIES. 9# 10# RCS: @(#) $Id: cursor.tcl,v 1.3 2009/04/24 22:03:48 hobbs Exp $ 11 12package require Tk 8.0 13package provide cursor 0.3 14 15namespace eval ::cursor { 16 namespace export propagate restore display 17 18 # Default to depthfirst (bottom up) restore to account for 19 # megawidgets that will self-propagate cursor changes down. 20 variable depthfirst 1 21 22 variable cursors [list \ 23 X_cursor arrow based_arrow_down based_arrow_up boat bogosity \ 24 bottom_left_corner bottom_right_corner bottom_side bottom_tee \ 25 box_spiral center_ptr circle clock coffee_mug cross cross_reverse \ 26 crosshair diamond_cross dot dotbox double_arrow draft_large \ 27 draft_small draped_box exchange fleur gobbler gumby hand1 hand2 \ 28 heart icon iron_cross left_ptr left_side left_tee leftbutton \ 29 ll_angle lr_angle man middlebutton mouse pencil pirate plus \ 30 question_arrow right_ptr right_side right_tee rightbutton \ 31 rtl_logo sailboat sb_down_arrow sb_h_double_arrow sb_left_arrow \ 32 sb_right_arrow sb_up_arrow sb_v_double_arrow shuttle sizing \ 33 spider spraycan star target tcross top_left_arrow top_left_corner \ 34 top_right_corner top_side top_tee trek ul_angle umbrella \ 35 ur_angle watch xterm \ 36 ] 37 38 switch -exact $::tcl_platform(os) { 39 "windows" { 40 lappend cursors no starting size \ 41 size_ne_sw size_ns size_nw_se size_we uparrow wait 42 } 43 "macintosh" { 44 lappend cursors text cross-hair 45 } 46 "unix" { 47 # no extra cursors 48 } 49 } 50} 51 52# ::cursor::propagate -- 53# 54# Propagates a cursor to a widget and all descendants. 55# 56# Arguments: 57# w Parent widget to set cursor on (includes children) 58# cursor The cursor to use 59# 60# Results: 61# Set the cursor of $w and all descendants to $cursor 62 63proc ::cursor::propagate {w cursor} { 64 variable CURSOR 65 66 # Ignores {} cursors or widgets that don't have a -cursor option 67 if {![catch {set CURSOR($w) [$w cget -cursor]}] && $CURSOR($w) != ""} { 68 $w config -cursor $cursor 69 } else { 70 catch {unset CURSOR($w)} 71 } 72 foreach child [winfo children $w] { propagate $child $cursor } 73} 74 75# ::cursor::restore -- 76# 77# Restores original cursor of a widget and all descendants. 78# 79# Arguments: 80# w Parent widget to restore cursor for (includes children) 81# cursor The default cursor to use (if none was cached by propagate) 82# 83# Results: 84# Restore the cursor of $w and all descendants 85 86proc ::cursor::restore {w {cursor {}}} { 87 variable depthfirst 88 variable CURSOR 89 90 if {$depthfirst} { 91 foreach child [winfo children $w] { restore $child $cursor } 92 } 93 if {[info exists CURSOR($w)]} { 94 $w config -cursor $CURSOR($w) 95 } else { 96 # Not all widgets have -cursor 97 catch {$w config -cursor $cursor} 98 } 99 if {!$depthfirst} { 100 foreach child [winfo children $w] { restore $child $cursor } 101 } 102} 103 104 105# ::cursor::display -- 106# 107# Show all known cursors for viewing 108# 109# Arguments: 110# w Parent widget to use for dialog 111# 112# Results: 113# Pops up a dialog 114 115proc ::cursor::display {{root .}} { 116 variable cursors 117 if {$root == "."} { 118 set t .__cursorDisplay 119 } else { 120 set t $root.__cursorDisplay 121 } 122 destroy $t 123 toplevel $t 124 wm withdraw $t 125 label $t.lbl -text "Select a cursor:" -anchor w 126 listbox $t.lb -selectmode single -yscrollcommand [list $t.sy set] 127 scrollbar $t.sy -orient v -command [list $t.lb yview] 128 button $t.d -text Dismiss -command [list destroy $t] 129 pack $t.d -side bottom 130 pack $t.lbl -side top -fill x 131 pack $t.sy -side right -fill y 132 pack $t.lb -side right -fill both -expand 1 133 eval [list $t.lb insert end] $cursors 134 bind $t.lb <Button-1> { %W config -cursor [%W get [%W nearest %y]] } 135 wm deiconify $t 136} 137 138