text widget 'peer' subcommand -- TIP#169 implementation

1 files changed, 530 insertions, 7 deletions

diff --git a/tests/text.test b/tests/text.test
index 27c922c..63b43ce 100644
--- a/tests/text.test
+++ b/tests/text.test
@@ -6,7 +6,7 @@
 # Copyright (c) 1998-1999 by Scriptics Corporation.
 # All rights reserved.
 #
-# RCS: @(#) $Id: text.test,v 1.31 2004/06/24 12:45:43 dkf Exp $
+# RCS: @(#) $Id: text.test,v 1.32 2004/09/10 12:13:43 vincentdarley Exp $
 
 package require tcltest 2.1
 eval tcltest::configure $argv
@@ -114,7 +114,7 @@ test text-1.[incr i] {text options} {
 	lappend result [lindex $i 4]
     }
     set result
-} {1 blue {} {} 0 7 watch 0 {} fixed #012 5 #123 #234 0 green 45 100 47 2 5 3 82 raised #ffff01234567 21 yellow 0 0 0 0 disabled {1i 2i 3i 4i} {any old thing} 1 73 word {x scroll command} {test command}}
+} {1 blue {} {} 0 7 watch {} 0 {} fixed #012 5 #123 #234 0 {} green 45 100 47 2 5 3 82 raised #ffff01234567 21 yellow 0 0 0 0 {} disabled {1i 2i 3i 4i} {any old thing} 1 73 word {x scroll command} {test command}}
 
 test text-2.1 {Tk_TextCmd procedure} {
     list [catch {text} msg] $msg
@@ -151,7 +151,7 @@ test text-3.1 {TextWidgetCmd procedure, basics} {
 } {1 {wrong # args: should be ".t option ?arg arg ...?"}}
 test text-3.2 {TextWidgetCmd procedure} {
     list [catch {.t gorp 1.0 z 1.2} msg] $msg
-} {1 {bad option "gorp": must be bbox, cget, compare, configure, count, debug, delete, dlineinfo, dump, edit, get, image, index, insert, mark, replace, scan, search, see, tag, window, xview, or yview}}
+} {1 {bad option "gorp": must be bbox, cget, compare, configure, count, debug, delete, dlineinfo, dump, edit, get, image, index, insert, mark, peer, replace, scan, search, see, tag, window, xview, or yview}}
 
 test text-4.1 {TextWidgetCmd procedure, "bbox" option} {
     list [catch {.t bbox} msg] $msg
@@ -219,7 +219,7 @@ test text-6.13 {TextWidgetCmd procedure, "compare" option} {
 } {1 {bad comparison operator "z": must be <, <=, ==, >=, >, or !=}}
 test text-6.14 {TextWidgetCmd procedure, "compare" option} {
     list [catch {.t co 1.0 z 1.2} msg] $msg
-} {1 {ambiguous option "co": must be bbox, cget, compare, configure, count, debug, delete, dlineinfo, dump, edit, get, image, index, insert, mark, replace, scan, search, see, tag, window, xview, or yview}}
+} {1 {ambiguous option "co": must be bbox, cget, compare, configure, count, debug, delete, dlineinfo, dump, edit, get, image, index, insert, mark, peer, replace, scan, search, see, tag, window, xview, or yview}}
 
 # "configure" option is already covered above
 
@@ -228,7 +228,7 @@ test text-7.1 {TextWidgetCmd procedure, "debug" option} {
 } {1 {wrong # args: should be ".t debug boolean"}}
 test text-7.2 {TextWidgetCmd procedure, "debug" option} {
     list [catch {.t de 0 1} msg] $msg
-} {1 {ambiguous option "de": must be bbox, cget, compare, configure, count, debug, delete, dlineinfo, dump, edit, get, image, index, insert, mark, replace, scan, search, see, tag, window, xview, or yview}}
+} {1 {ambiguous option "de": must be bbox, cget, compare, configure, count, debug, delete, dlineinfo, dump, edit, get, image, index, insert, mark, peer, replace, scan, search, see, tag, window, xview, or yview}}
 test text-7.3 {TextWidgetCmd procedure, "debug" option} {
     .t debug true
     .t deb
@@ -334,7 +334,8 @@ test text-8.19 {TextWidgetCmd procedure, "replace" option} {
     list [catch {.t replace 2.1 2.3 foo} err] $err
 } {0 {}}
 .t delete 1.0 end; .t insert 1.0 $prevtext
-test text-8.20 {TextWidgetCmd procedure, "replace" option} {
+test text-8.20 {TextWidgetCmd procedure, "replace" option with undo} {
+    .t configure -undo 0
     .t configure -undo 1
     # Ensure it is treated as a single undo action
     .t replace 2.1 2.3 foo
@@ -343,6 +344,90 @@ test text-8.20 {TextWidgetCmd procedure, "replace" option} {
     string equal [.t get 1.0 end-1c] $prevtext
 } {1}
 
+test text-8.21 {TextWidgetCmd procedure, "replace" option with undo} {
+    .t configure -undo 0
+    .t configure -undo 1
+    .t replace 2.1 2.3 foo
+    # Ensure we can override a text widget and intercept undo
+    # actions.  If in the future a different mechanism is available
+    # to do this, then we should be able to change this test.  The
+    # behaviour tested for here is not, strictly speaking, documented.
+    rename .t test.t
+    set res {}
+    proc .t {args} { lappend ::res $args ; uplevel 1 test.t $args }
+    .t edit undo
+    rename .t {}
+    rename test.t .t
+    .t configure -undo 0
+    set res
+} {{edit undo} {delete 2.1 2.4} {mark set insert 2.1} {see insert} {insert 2.1 ef} {mark set insert 2.3} {see insert}}
+
+test text-8.22 {TextWidgetCmd procedure, "replace" option with undo} {
+    .t configure -undo 0
+    .t configure -undo 1
+    # Ensure that undo (even composite undo like 'replace')
+    # works when the widget shows nothing useful.
+    .t replace 2.1 2.3 foo
+    .t configure -start 1 -end 1
+    .t edit undo
+    .t configure -start {} -end {}
+    .t configure -undo 0
+    if {![string equal [.t get 1.0 end-1c] $prevtext]} {
+	set res [list [.t get 1.0 end-1c] ne $prevtext]
+    } else {
+	set res 1
+    }
+} {1}
+
+.t delete 1.0 end; .t insert 1.0 $prevtext
+
+test text-8.23 {TextWidgetCmd procedure, "replace" option with peers, undo} {
+    .t configure -undo 0
+    .t configure -undo 1
+    .t peer create .tt -undo 1
+    # Ensure that undo (even composite undo like 'replace')
+    # works when the the event took place in one peer, which
+    # is then deleted, before the undo takes place in another peer.
+    .tt replace 2.1 2.3 foo
+    .tt configure -start 1 -end 1
+    destroy .tt
+    .t edit undo
+    .t configure -start {} -end {}
+    .t configure -undo 0
+    if {![string equal [.t get 1.0 end-1c] $prevtext]} {
+	set res [list [.t get 1.0 end-1c] ne $prevtext]
+    } else {
+        set res 1
+    }
+} {1}
+
+.t delete 1.0 end; .t insert 1.0 $prevtext
+
+test text-8.24 {TextWidgetCmd procedure, "replace" option with peers, undo} {
+    .t configure -undo 0
+    .t configure -undo 1
+    .t peer create .tt -undo 1
+    # Ensure that undo (even composite undo like 'replace')
+    # works when the the event took place in one peer, which
+    # is then deleted, before the undo takes place in another peer
+    # which isn't showing everything.
+    .tt replace 2.1 2.3 foo
+    set res [.tt get 2.1 2.4]
+    .tt configure -start 1 -end 1
+    destroy .tt
+    .t configure -start 3 -end 4
+    # msg will actually be set to a silently ignored error message here,
+    # (that the .tt command doesn't exist), but that is not important.
+    lappend res [catch {.t edit undo} msg]
+    .t configure -undo 0
+    .t configure -start {} -end {}
+    if {![string equal [.t get 1.0 end-1c] $prevtext]} {
+	lappend res [list [.t get 1.0 end-1c] ne $prevtext]
+    } else {
+	lappend res 1
+    }
+} {foo 0 1}
+
 .t delete 1.0 end; .t insert 1.0 $prevtext
 
 test text-9.1 {TextWidgetCmd procedure, "get" option} {
@@ -741,7 +826,7 @@ test text-10.2 {TextWidgetCmd procedure, "index" option} {
 } {1 {wrong # args: should be ".t index index"}}
 test text-10.3 {TextWidgetCmd procedure, "index" option} {
     list [catch {.t in a b} msg] $msg
-} {1 {ambiguous option "in": must be bbox, cget, compare, configure, count, debug, delete, dlineinfo, dump, edit, get, image, index, insert, mark, replace, scan, search, see, tag, window, xview, or yview}}
+} {1 {ambiguous option "in": must be bbox, cget, compare, configure, count, debug, delete, dlineinfo, dump, edit, get, image, index, insert, mark, peer, replace, scan, search, see, tag, window, xview, or yview}}
 test text-10.4 {TextWidgetCmd procedure, "index" option} {
     list [catch {.t index @xyz} msg] $msg
 } {1 {bad text index "@xyz"}}
@@ -2974,6 +3059,444 @@ test text-28.0 {repeated insert and scroll} {
     set result 1
 } {1}
 
+test text-29.0 {peer widgets} {
+    destroy .t .tt
+    toplevel .tt
+    pack [text .t]
+    pack [.t peer create .tt.t]
+    destroy .t .tt
+} {}
+
+test text-29.1 {peer widgets} {
+    destroy .t .t1 .t2
+    toplevel .t1
+    toplevel .t2
+    pack [text .t]
+    pack [.t peer create .t1.t]
+    pack [.t peer create .t2.t]
+    .t insert end "abcd\nabcd"
+    update
+    destroy .t1
+    update
+    .t insert end "abcd\nabcd"
+    update
+    destroy .t .t2
+    update
+} {}
+
+test text-29.2 {peer widgets} {
+    destroy .t .t1 .t2
+    toplevel .t1
+    toplevel .t2
+    pack [text .t]
+    pack [.t peer create .t1.t]
+    pack [.t peer create .t2.t]
+    .t insert end "abcd\nabcd"
+    update
+    destroy .t
+    update
+    .t2.t insert end "abcd\nabcd"
+    update
+    destroy .t .t2
+    update
+} {}
+
+test text-29.3 {peer widgets} {
+    destroy .t .tt
+    toplevel .tt
+    pack [text .t]
+    for {set i 1} {$i < 20} {incr i} {
+	.t insert end "Line $i\n"
+    }
+    pack [.t peer create .tt.t -start 5 -end 11]
+    update
+    destroy .t .tt
+} {}
+
+test text-29.4 {peer widgets} {
+    destroy .t .tt
+    toplevel .tt
+    pack [text .t]
+    for {set i 1} {$i < 20} {incr i} {
+	.t insert end "Line $i\n"
+    }
+    pack [.t peer create .tt.t -start 5 -end 11]
+    pack [.tt.t peer create .tt.t2]
+    set res [list [.tt.t index end] [.tt.t2 index end]]
+    update
+    destroy .t .tt
+    set res
+} {7.0 7.0}
+
+test text-29.4.1 {peer widgets} {
+    destroy .t .tt
+    toplevel .tt
+    pack [text .t]
+    for {set i 1} {$i < 20} {incr i} {
+	.t insert end "Line $i\n"
+    }
+    pack [.t peer create .tt.t -start 5 -end 11]
+    pack [.tt.t peer create .tt.t2 -start {} -end {}]
+    set res [list [.tt.t index end] [.tt.t2 index end]]
+    update
+    destroy .t .tt
+    set res
+} {7.0 21.0}
+
+test text-29.5 {peer widgets} {
+    destroy .t .tt
+    toplevel .tt
+    pack [text .t]
+    for {set i 1} {$i < 20} {incr i} {
+	.t insert end "Line $i\n"
+    }
+    pack [.t peer create .tt.t -start 5 -end 11]
+    update ; update
+    set p1 [.tt.t count -update -ypixels 1.0 end]
+    set p2 [.t count -update -ypixels 5.0 11.0]
+    if {$p1 == $p2} { 
+	set res "ok" 
+    } else {
+        set res "$p1 and $p2 not equal"
+    }
+    destroy .t .tt
+    set res
+} {ok}
+
+test text-29.6 {peer widgets} {
+    destroy .t .tt
+    toplevel .tt
+    pack [text .t]
+    for {set i 1} {$i < 20} {incr i} {
+	.t insert end "Line $i\n"
+    }
+    pack [.t peer create .tt.t -start 5 -end 11]
+    update ; update
+    .t delete 3.0 6.0
+    set res [.tt.t index end]
+    destroy .t .tt
+    set res
+} {6.0}
+
+test text-29.7 {peer widgets} {
+    destroy .t .tt
+    toplevel .tt
+    pack [text .t]
+    for {set i 1} {$i < 20} {incr i} {
+	.t insert end "Line $i\n"
+    }
+    pack [.t peer create .tt.t -start 5 -end 11]
+    update ; update
+    .t delete 8.0 12.0
+    set res [.tt.t index end]
+    destroy .t .tt
+    set res
+} {4.0}
+
+test text-29.8 {peer widgets} {
+    destroy .t .tt
+    toplevel .tt
+    pack [text .t]
+    for {set i 1} {$i < 20} {incr i} {
+	.t insert end "Line $i\n"
+    }
+    pack [.t peer create .tt.t -start 5 -end 11]
+    update ; update
+    .t delete 3.0 13.0
+    set res [.tt.t index end]
+    destroy .t .tt
+    set res
+} {1.0}
+
+test text-29.9 {peer widgets} {
+    destroy .t
+    pack [text .t]
+    for {set i 1} {$i < 100} {incr i} {
+	.t insert end "Line $i\n"
+    }
+    .t tag add sel 1.0 end-1c
+    set res {}
+    lappend res [.t tag ranges sel]
+    .t configure -start 10 -end 20
+    lappend res [.t tag ranges sel]
+    destroy .t
+    set res
+} {{1.0 100.0} {1.0 11.0}}
+
+test text-29.10 {peer widgets} {
+    destroy .t
+    pack [text .t]
+    for {set i 1} {$i < 100} {incr i} {
+	.t insert end "Line $i\n"
+    }
+    .t tag add sel 1.0 end-1c
+    set res {}
+    lappend res [.t tag ranges sel]
+    .t configure -start 11
+    lappend res [.t tag ranges sel]
+    destroy .t
+    set res
+} {{1.0 100.0} {1.0 90.0}}
+
+test text-29.11 {peer widgets} {
+    destroy .t
+    pack [text .t]
+    for {set i 1} {$i < 100} {incr i} {
+	.t insert end "Line $i\n"
+    }
+    .t tag add sel 1.0 end-1c
+    set res {}
+    lappend res [.t tag ranges sel]
+    .t configure -end 90
+    lappend res [.t tag ranges sel]
+    destroy .t
+    set res
+} {{1.0 100.0} {1.0 90.0}}
+
+test text-29.12 {peer widgets} {
+    destroy .t
+    pack [text .t]
+    for {set i 1} {$i < 20} {incr i} {
+	.t insert end "Line $i\n"
+    }
+    .t tag add sel 1.0 3.0 5.0 7.0 9.0 11.0 13.0 15.0 17.0 19.0 
+    set res {}
+    lappend res [.t tag prevrange sel 1.0]
+    .t configure -start 6 -end 12
+    lappend res [.t tag ranges sel]
+    lappend res "next" [.t tag nextrange sel 4.0] \
+      [.t tag nextrange sel 5.0] [.t tag nextrange sel 6.0] \
+      [.t tag nextrange sel 7.0]
+    lappend res "prev" [.t tag prevrange sel 1.0] \
+      [.t tag prevrange sel 2.0] [.t tag prevrange sel 3.0] \
+      [.t tag prevrange sel 4.0]
+    destroy .t
+    set res
+} {{} {1.0 2.0 4.0 6.0} next {4.0 6.0} {} {} {} prev {} {1.0 2.0} {1.0 2.0} {1.0 2.0}}
+
+test text-29.13 {peer widgets} {
+    destroy .t
+    pack [text .t]
+    for {set i 1} {$i < 20} {incr i} {
+	.t insert end "Line $i\n"
+    }
+    .t tag add sel 1.0 3.0 9.0 11.0 13.0 15.0 17.0 19.0 
+    set res {}
+    .t configure -start 6 -end 12
+    lappend res [.t tag ranges sel]
+    lappend res "next" [.t tag nextrange sel 4.0] \
+      [.t tag nextrange sel 5.0] [.t tag nextrange sel 6.0] \
+      [.t tag nextrange sel 7.0]
+    lappend res "prev" [.t tag prevrange sel 1.0] \
+      [.t tag prevrange sel 2.0] [.t tag prevrange sel 3.0] \
+      [.t tag prevrange sel 4.0]
+    destroy .t
+    set res
+} {{4.0 6.0} next {4.0 6.0} {} {} {} prev {} {} {} {}}
+
+test text-29.14 {peer widgets} {
+    destroy .t
+    pack [text .t]
+    for {set i 1} {$i < 20} {incr i} {
+	.t insert end "Line $i\n"
+    }
+    .t tag add sel 1.0 7.0 9.0 11.0 13.0 15.0 17.0 19.0 
+    set res {}
+    .t configure -start 6 -end 12
+    lappend res [.t tag ranges sel]
+    lappend res "next" [.t tag nextrange sel 4.0] \
+      [.t tag nextrange sel 5.0] [.t tag nextrange sel 6.0] \
+      [.t tag nextrange sel 7.0]
+    lappend res "prev" [.t tag prevrange sel 1.0] \
+      [.t tag prevrange sel 2.0] [.t tag prevrange sel 3.0] \
+      [.t tag prevrange sel 4.0]
+    destroy .t
+    set res
+} {{1.0 2.0 4.0 6.0} next {4.0 6.0} {} {} {} prev {} {1.0 2.0} {1.0 2.0} {1.0 2.0}}
+
+test text-29.15 {peer widgets} {
+    destroy .t
+    pack [text .t]
+    for {set i 1} {$i < 20} {incr i} {
+	.t insert end "Line $i\n"
+    }
+    set res {}
+    .t tag add sel 1.0 11.0
+    lappend res [.t tag ranges sel]
+    lappend res [catch {.t configure -start 15 -end 10}]
+    lappend res [.t tag ranges sel]
+    .t configure -start 6 -end 12
+    lappend res [.t tag ranges sel]
+    .t configure -start {} -end {}
+    lappend res [.t tag ranges sel]
+    destroy .t
+    set res
+} {{1.0 11.0} 1 {1.0 11.0} {1.0 6.0} {1.0 11.0}}
+
+test text-29.16 {peer widgets} {
+    destroy .t
+    pack [text .t]
+    for {set i 1} {$i < 20} {incr i} {
+	.t insert end "Line $i\n"
+    }
+    set res {}
+    .t tag add sel 1.0 11.0
+    lappend res [.t index sel.first]
+    lappend res [.t index sel.last]
+    destroy .t
+    set res
+} {1.0 11.0} 
+
+test text-29.17 {peer widgets} {
+    destroy .t
+    pack [text .t]
+    for {set i 1} {$i < 20} {incr i} {
+	.t insert end "Line $i\n"
+    }
+    set res {}
+    .t tag delete sel
+    set res [list [catch {.t index sel.first} msg] $msg]
+    destroy .t
+    set res
+} {1 {text doesn't contain any characters tagged with "sel"}} 
+
+proc makeText {} {
+    set w .g
+    set font "Times 11"
+    destroy .g
+    toplevel .g
+    frame $w.f -highlightthickness 2 -borderwidth 2 -relief sunken
+    set t $w.f.text
+    text $t -yscrollcommand "$w.scroll set" -setgrid true -font $font -width 70 \
+	    -height 35 -wrap word -highlightthickness 0 -borderwidth 0
+    pack $t -expand  yes -fill both
+    scrollbar $w.scroll -command "$t yview"
+    pack $w.scroll -side right -fill y
+    pack $w.f -expand yes -fill both
+    $t tag configure center -justify center -spacing1 5m -spacing3 5m
+    $t tag configure buttons -lmargin1 1c -lmargin2 1c -rmargin 1c \
+	    -spacing1 3m -spacing2 0 -spacing3 0
+    for {set i 0} {$i < 40} {incr i} {
+	$t insert end "${i}word "
+    }
+    return $t
+}
+
+test text-30.1 {line heights on creation} {
+    set w [makeText]
+    update ; after 1000 ; update
+    set before [$w count -ypixels 1.0 2.0]
+    $w insert 1.0 "a"
+    update
+    set after [$w count -ypixels 1.0 2.0]
+    destroy .g
+    if {$before != $after} {
+	set res "Count changed: $before $after"
+    } else {
+        set res "ok"
+    }
+} {ok}
+
+destroy .t
+text .t
+test text-31.1 {TextWidgetCmd procedure, "peer" option} {
+    list [catch {.t peer foo 1} msg] $msg
+} {1 {bad peer option "foo": must be create or names}}
+test text-31.2 {TextWidgetCmd procedure, "peer" option} {
+    list [catch {.t peer names foo} msg] $msg
+} {1 {wrong # args: should be ".t peer names"}}
+test text-31.3 {TextWidgetCmd procedure, "peer" option} {
+    list [catch {.t p names} msg] $msg
+} {0 {}}
+test text-31.4 {TextWidgetCmd procedure, "peer" option} {
+    .t peer names
+} {}
+test text-31.5 {TextWidgetCmd procedure, "peer" option} {
+    list [catch {.t peer create foo} msg] $msg
+} {1 {bad window path name "foo"}}
+test text-31.6 {TextWidgetCmd procedure, "peer" option} {
+    .t peer create .t2
+    set res {}
+    lappend res [.t peer names]
+    lappend res [.t2 peer names]
+    destroy .t2
+    lappend res [.t peer names]
+} {.t2 .t {}}
+test text-31.7 {peer widget -start, -end} {
+    set res [list [catch {.t configure -start 10 -end 5} msg] $msg]
+    .t configure -start {} -end {}
+    set res
+} {0 {}}
+test text-31.8 {peer widget -start, -end} {
+    .t delete 1.0 end
+    for {set i 1} {$i < 100} {incr i} {
+	.t insert end "Line $i\n"
+    }
+    list [catch {.t configure -start 10 -end 5} msg] $msg
+} {1 {-startline must be less than or equal to -endline}}
+test text-31.9 {peer widget -start, -end} {
+    .t delete 1.0 end
+    for {set i 1} {$i < 100} {incr i} {
+	.t insert end "Line $i\n"
+    }
+    set res [list [catch {.t configure -start 5 -end 10} msg] $msg]
+    .t configure -start {} -end {}
+    set res
+} {0 {}}
+
+test text-31.10 {peer widget -start, -end} {
+    .t delete 1.0 end
+    for {set i 1} {$i < 100} {incr i} {
+	.t insert end "Line $i\n"
+    }
+    set res [.t index end]
+    lappend res [catch {.t configure -start 5 -end 10 -tab foo}]
+    lappend res [.t index end]
+    lappend res [catch {.t configure -tab foo -start 15 -end 20}]
+    lappend res [.t index end]
+    .t configure -start {} -end {}
+    lappend res [.t index end]
+    set res
+} {101.0 1 101.0 1 101.0 101.0}
+
+test text-31.11 {peer widget -start, -end} {
+    .t delete 1.0 end
+    for {set i 1} {$i < 100} {incr i} {
+	.t insert end "Line $i\n"
+    }
+    set res [.t index end]
+    lappend res [catch {.t configure -start 5 -end 15}]
+    lappend res [.t index end]
+    lappend res [catch {.t configure -start 10 -end 40}]
+    lappend res [.t index end]
+    .t configure -start {} -end {}
+    lappend res [.t index end]
+    set res
+} {101.0 0 11.0 0 31.0 101.0}
+
+test text-32.1 {peer widget -start, -end and selection} {
+    .t delete 1.0 end
+    for {set i 1} {$i < 100} {incr i} {
+	.t insert end "Line $i\n"
+    }
+    .t tag add sel 10.0 20.0
+    set res {}
+    lappend res [.t tag ranges sel]
+    .t configure -start 5 -end 30
+    lappend res [.t tag ranges sel]
+    .t configure -start 5 -end 15
+    lappend res [.t tag ranges sel]
+    .t configure -start 15 -end 30
+    lappend res [.t tag ranges sel]
+    .t configure -start 15 -end 16
+    lappend res [.t tag ranges sel]
+    .t configure -start 25 -end 30
+    lappend res [.t tag ranges sel]
+    .t configure -start {} -end {}
+    lappend res [.t tag ranges sel]
+    set res
+} {{10.0 20.0} {6.0 16.0} {6.0 11.0} {1.0 6.0} {1.0 2.0} {} {10.0 20.0}}
+
 deleteWindows
 option clear