#! /bin/sh
# \
exec wish "$0" "$@"
# wrapping it up in an own namespace for sanity's sake.
namespace eval block_select {
package require Tk
package provide block_select 1.0
namespace export block_select
array set selCoords {}
array set block_selecting {}
# selection handler for the text widget. win is the text-widget,
# offset and len are provided by the selection caller. (see man selection)
#
# builds a list of lines in the text widget carrying the sel tag
# and constructs a buffer, ending lines with newlines if necessary.
# return that buffer.
proc sel_text {win off len} {
set start "0.0"
set lines [list]
set buf {}
while {[string length [set start [$win tag nextrange sel $start]]]} {
lappend lines [$win get [lindex $start 0] [lindex $start 1]]
set start [lindex $start 1]
}
foreach l $lines {
append buf $l
if {[string index $l end] != "\n"} then { append buf "\n" }
}
return [string range $buf $off [expr $off + $len]]
}
# control proc to mark the current selection
#
proc mark_text {win x2 y2} {
variable selCoords
selection clear
foreach {x1 y1} $selCoords($win) {}
if {$x1 > $x2} then {set x $x2; set endx $x1} else {set x $x1; set endx $x2}
if {$y1 > $y2} then {set y $y2; set endy $y1} else {set y $y1; set endy $y2}
while {$y <= $endy} {
set bb [$win bbox "@$x,$y"]
$win tag add sel "@$x,$y" "@$endx,$y"
incr y [lindex $bb 3]
}
}
proc block_select {win} {
variable selCoords
variable block_selecting
selection handle -format STRING -type STRING -selection PRIMARY $win [namespace code "sel_text $win "]
# start of selection
bind $win <Control-ButtonPress-1> [namespace code {
set selCoords(%W) [list %x %y]
set block_selecting(%W) 1
break; # stop default binding
}]
# during move
bind $win <Control-Motion> [namespace code {
if {[info exists block_selecting(%W)] && $block_selecting(%W)} then {
if {![info exists selCoords(%W)]} then {
set block_selecting(%W) 0
break
}
mark_text %W %x %y
break; # stop default binding
}
}]
# end selecting
bind $win <Control-ButtonRelease-1> [namespace code {
if {[info exists block_selecting(%W)] && $block_selecting(%W)} then {
mark_text %W %x %y
catch {unset selCoords(%W)}
}
set block-selecting(%W) 0
break; # stop default binding
}]
bind $win <KeyRelease-Control_L> [namespace code {
if {[info exists block_selecting(%W)] && $block_selecting(%W)} then {
set block-selecting(%W) 0
catch {unset selCoords(%W)}
}
}]
bind $win <KeyRelease-Control_R> [namespace code {
if {[info exists block_selecting(%W)] && $block_selecting(%W)} then {
set block-selecting(%W) 0
catch {unset selCoords(%W)}
}
}]
}
} ;# end of namespace
if {[info exists ::argv0] && $::argv0 == [info script]} then {
# Testing
proc build_text {parent} {
text ${parent}.t -exportselection true
pack ${parent}.t -expand yes -fill both
${parent}.t insert 0.0 {
block selecting fun: mult-table a*b
a/b 7 8 9 10 11 12 tabs mtabs
1 7 8 9 10 11 12 one one
2 14 16 18 20 22 24 two two
3 21 24 27 30 33 36 three three
4 28 32 36 40 44 48 four four
5 35 40 45 50 55 60 five five
6 42 48 54 60 66 72 six six
}
return ${parent}.t
}
# for testing:
wm withdraw .
toplevel .test
package require block_select
block_select::block_select [build_text .test]
}MSW / 20. Feb 2003: block-select now works fine with tabs, be it user-defined global tabs, tag tabs, default tabs .... should've used the coordinates right from the beginning.
Remark: This (atm?) only works with exportselection true (the default). Thought I'd mention it :)
