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