* library/ttk/cursors.tcl: backport ttk::cursor from HEAD

1 files changed, 167 insertions, 14 deletions

diff --git a/library/ttk/cursors.tcl b/library/ttk/cursors.tcl
index a151194..f5abd54 100644
--- a/library/ttk/cursors.tcl
+++ b/library/ttk/cursors.tcl
@@ -1,35 +1,188 @@
 #
-# $Id: cursors.tcl,v 1.1 2006/10/31 01:42:27 hobbs Exp $
+# $Id: cursors.tcl,v 1.1.4.1 2009/04/10 16:39:47 das Exp $
 #
-# Ttk package: Symbolic cursor names.
+# Map symbolic cursor names to platform-appropriate cursors.
 #
-# @@@ TODO: Figure out appropriate platform-specific cursors
-#	for the various functions.
+# The following cursors are defined:
+#
+#	standard	-- default cursor for most controls
+#	""		-- inherit cursor from parent window
+#	none		-- no cursor
+#
+#	text		-- editable widgets (entry, text)
+#	link		-- hyperlinks within text
+#	crosshair	-- graphic selection, fine control
+#	busy		-- operation in progress
+#	forbidden	-- action not allowed
+#
+#	hresize		-- horizontal resizing
+#	vresize		-- vertical resizing
+#
+# Also resize cursors for each of the compass points,
+# {nw,n,ne,w,e,sw,s,se}resize.
+#
+# Platform notes:
+#
+# Windows doesn't distinguish resizing at the 8 compass points,
+# only horizontal, vertical, and the two diagonals.
+#
+# OSX doesn't have resize cursors for nw, ne, sw, or se corners.
+# We use the Tk-defined X11 fallbacks for these.
+#
+# X11 doesn't have a "forbidden" cursor (usually a slashed circle);
+# "pirate" seems to be the conventional cursor for this purpose.
+#
+# Windows has an IDC_HELP cursor, but it's not available from Tk.
+#
+# Tk does not support "none" on Windows.
 #
 
 namespace eval ttk {
 
     variable Cursors
 
-    switch -glob $::tcl_platform(platform) {
-	"windows" {
+    # Use X11 cursor names as defaults, since Tk supplies these
+    # on all platforms.
+    #
+    array set Cursors {
+	""		""
+	none		none
+
+	standard	left_ptr
+	text 		xterm
+	link		hand2
+	crosshair	crosshair
+	busy		watch
+	forbidden	pirate
+
+	hresize 	sb_h_double_arrow
+	vresize 	sb_v_double_arrow
+
+	nresize 	top_side
+	sresize 	bottom_side
+	wresize 	left_side
+	eresize 	right_side
+	nwresize	top_left_corner
+	neresize	top_right_corner
+	swresize	bottom_left_corner
+	seresize	bottom_right_corner
+	move		fleur
+
+    }
+
+    # Platform-specific overrides for Windows and OSX.
+    #
+    switch [tk windowingsystem] {
+	"win32" {
 	    array set Cursors {
-		hresize 	sb_h_double_arrow
-		vresize 	sb_v_double_arrow
+		none		{}
+
+		standard	arrow
+		text		ibeam
+		link		hand2
+		crosshair	crosshair
+		busy		wait
+		forbidden	no
+
+		vresize 	size_ns
+		nresize 	size_ns
+		sresize		size_ns
+
+		wresize		size_we
+		eresize		size_we
+		hresize 	size_we
+
+		nwresize	size_nw_se
+		swresize	size_ne_sw
+
+		neresize	size_ne_sw
 		seresize	size_nw_se
 	    }
 	}
 
-	"unix" -
-	* {
-	    array set Cursors {
-		hresize 	sb_h_double_arrow
-		vresize 	sb_v_double_arrow
-		seresize	bottom_right_corner
+	"aqua" {
+	    if {[package vsatisfies [package provide Tk] 8.5]} {
+		# appeared 2007-04-23, Tk 8.5a6
+		array set Cursors {
+		    standard	arrow
+		    text 	ibeam
+		    link	pointinghand
+		    crosshair	crosshair
+		    busy	watch
+		    forbidden	notallowed
+
+		    hresize 	resizeleftright
+		    vresize 	resizeupdown
+		    nresize	resizeup
+		    sresize	resizedown
+		    wresize	resizeleft
+		    eresize	resizeright
+		}
 	    }
 	}
+    }
+}
+
+## ttk::cursor $cursor --
+#	Return platform-specific cursor for specified symbolic cursor.
+#
+proc ttk::cursor {name} {
+    variable Cursors
+    return $Cursors($name)
+}
+
+## ttk::setCursor $w $cursor --
+#	Set the cursor for specified window.
+#
+# [ttk::setCursor] should be used in <Motion> bindings
+# instead of directly calling [$w configure -cursor ...],
+# as the latter always incurs a server round-trip and
+# can lead to high CPU load (see [#1184746])
+#
 
+proc ttk::setCursor {w name} {
+    variable Cursors
+    if {[$w cget -cursor] ne $Cursors($name)} {
+	$w configure -cursor $Cursors($name)
+    }
+}
+
+## Interactive test harness:
+#
+proc ttk::CursorSampler {f} {
+    ttk::frame $f
+
+    set r 0
+    foreach row {
+	{nwresize nresize   neresize}
+	{ wresize move       eresize}
+	{swresize sresize   seresize}
+	{text link crosshair}
+	{hresize vresize ""}
+	{busy forbidden ""}
+	{none standard ""}
+    } {
+	set c 0
+	foreach cursor $row {
+	    set w $f.${r}${c}
+	    ttk::label $w -text $cursor -cursor [ttk::cursor $cursor] \
+		-relief solid -borderwidth 1 -padding 3
+	    grid $w -row $r -column $c -sticky nswe
+	    grid columnconfigure $f $c -uniform cols -weight 1
+	    incr c
+	}
+	grid rowconfigure $f $r -uniform rows -weight 1
+	incr r
     }
+
+    return $f
+}
+
+if {[info exists argv0] && $argv0 eq [info script]} {
+    wm title . "[array size ::ttk::Cursors] cursors"
+    pack [ttk::CursorSampler .f] -expand true -fill both
+    bind . <KeyPress-Escape> [list destroy .]
+    focus .f
 }
 
 #*EOF*