#! /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]

 }