Tk Source Code

    clipboard append "first chunk"
    selection own -s CLIPBOARD .
	clipboard append " second chunk"
	clipboard get
} -cleanup {
    clipboard clear
}  -returnCodes ok -result {first chunk second chunk}
test clipboard-6.2 {Tk_ClipboardAppend procedure} -constraints unix -setup {
    clipboard clear
} -body {
    setupbg
    clipboard append -f INTEGER -t TEST "16"
    set result [dobg {clipboard get TEST}]
    return $result
} -cleanup {

    set lostSel {owned}
    selection own -command { set lostSel {lost1} } .f1
    selection own -command { set lostSel {lost2} } .f1
    set result $lostSel
    selection clear .f1
    lappend result $lostSel
} -result {owned lost2}
test select-3.7 {Tk_OwnSelection procedure} -constraints unix -setup {
    global lostSel
    setup
    setupbg
} -body {
    set lostSel {owned}
    selection own -command { set lostSel {lost1} } .f1
    update

    selection own -selection CLIPBOARD
} -result {.f1}
test select-4.3 {Tk_ClearSelection procedure} -setup {
    setup
} -body {
    list [selection clear .f1] [selection clear .f1]
} -result {{} {}}
test select-4.4 {Tk_ClearSelection procedure} -constraints unix -setup {
    global lostSel
    setup
    setupbg
} -body {
    set lostSel {owned}
    selection own -command { set lostSel {lost1} } .f1
    update

    selection own -command { set lostSel2 {lost2} } .f2
    update
    selection clear -displayof .f2
    update
    list $lostSel $lostSel2
} -result {owned lost2}
test select-4.6 {Tk_ClearSelection procedure} -constraints {
    unix altDisplay
} -setup {
    setup .f1
    setup .f2 $env(TK_ALT_DISPLAY)
    setupbg
} -body {
    set lostSel {owned}
    set lostSel2 {owned2}

    set selInfo ""
    selection handle .f1 {apply {{type offset count} {
	selection clear
	handler $type $offset $count
    }} STRING}
    list [selection get] $selInfo [catch {selection get} msg] $msg
} -result "$longValue {STRING 0 4000 STRING 4000 4000 STRING 8000 4000 STRING 12000 4000 STRING 16000 4000} 1 {PRIMARY selection doesn't exist or form \"STRING\" not defined}"
test select-5.9 {Tk_GetSelection procedure} -constraints unix -setup {
    setup
    setupbg
} -body {
    selection handle -selection PRIMARY .f1 {handler TEST} TEST
    update
    set selValue "Test value"
    set selInfo ""
    set result ""
    lappend result [dobg {selection get TEST}]
    cleanupbg
    lappend result $selInfo
} -result {{Test value} {TEST 0 4000}}
test select-5.10 {Tk_GetSelection procedure} -constraints unix -setup {
    setup
    setupbg
} -body {
    selection handle -selection PRIMARY .f1 {handler TEST} TEST
    update
    set selValue "Test value"
    set selInfo ""

    set result [list [catch {selection get TEST} msg] $msg $selInfo]
    set selValue "Test value2"
    set selInfo ""
    lappend result [catch {selection get -displayof .f2 TEST} msg] $msg \
	    $selInfo
} -result {0 {Test value} {TEST 0 4000} 1 {PRIMARY selection doesn't exist or form "TEST" not defined} {}}
test select-5.13 {Tk_GetSelection procedure} -constraints {
    unix altDisplay
} -setup {
    setup .f1
    setup .f2 $env(TK_ALT_DISPLAY)
    setupbg
} -body {
    selection handle -selection PRIMARY .f1 {handler TEST} TEST
    selection own .f1
    selection handle -selection PRIMARY .f2 {handler TEST2} TEST
    selection own .f2
    set selValue "Test value"
    set selInfo ""
    update
    set result ""
    lappend result [dobg "toplevel .t -screen $env(TK_ALT_DISPLAY); wm geom .t +0+0; selection get -displayof .t TEST"]
    set selValue "Test value2"
    lappend result [dobg "selection get TEST"]
    cleanupbg
    lappend result $selInfo
} -result {{Test value} {Test value2} {TEST2 0 4000 TEST 0 4000}}
test select-5.14 {Tk_GetSelection procedure} -constraints {
    unix altDisplay
} -setup {
    setup .f1
    setup .f2 $env(TK_ALT_DISPLAY)
    setupbg
} -body {
    selection handle -selection PRIMARY .f1 {handler TEST} TEST
    selection own .f1

    destroy .f1
    lappend result [selection own] [catch {selection get} msg] $msg
} -result {.f1 {} 1 {PRIMARY selection doesn't exist or form "STRING" not defined}}

##############################################################################

# Check reentrancy on losing selection
test select-8.1 {TkSelEventProc procedure} -constraints unix -setup {
    setup
    setupbg
} -body {
    selection own -selection CLIPBOARD -command {destroy .f1} .f1
    update
    dobg {selection own -selection CLIPBOARD .}

} -cleanup {
    cleanupbg
} -result {}

##############################################################################

test select-9.1 {SelCvtToX and SelCvtFromX procedures} -setup {
    setup
    setupbg
} -constraints unix -body {
    set selValue "1024"
    set selInfo ""
    selection handle -selection PRIMARY -format INTEGER -type TEST \
        .f1 {handler TEST}
    update
    set result ""
    lappend result [dobg {selection get TEST}]
    cleanupbg
    lappend result $selInfo
} -result {{0x400 } {TEST 0 4000}}
test select-9.2 {SelCvtToX and SelCvtFromX procedures} -setup {
    setup
    setupbg
} -constraints unix -body {
    set selValue "1024 0xffff  2048 -2  "
    set selInfo ""
    selection handle -selection PRIMARY -format INTEGER -type TEST \
	.f1 {handler TEST}
    set result ""
    lappend result [dobg {selection get TEST}]
    cleanupbg
    lappend result $selInfo
} -result {{0x400 0xffff 0x800 0xfffffffe } {TEST 0 4000}}
test select-9.3 {SelCvtToX and SelCvtFromX procedures} -setup {
    setup
    setupbg
} -constraints unix -body {
    set selValue "   "
    set selInfo ""
    selection handle -selection PRIMARY -format INTEGER -type TEST \
	.f1 {handler TEST}
    set result ""
    lappend result [dobg {selection get TEST}]
    cleanupbg
    lappend result $selInfo
} -result {{ } {TEST 0 4000}}
test select-9.4 {SelCvtToX and SelCvtFromX procedures} -setup {
    setup
    setupbg
} -constraints unix -body {
    set selValue "16 foobar 32"
    set selInfo ""
    selection handle -selection PRIMARY -format INTEGER -type TEST \
	.f1 {handler TEST}
    set result ""
    lappend result [dobg {selection get TEST}]
    cleanupbg
    lappend result $selInfo
} -result {{0x10 0x0 0x20 } {TEST 0 4000}}
test select-9.5 {SelCvtToX and SelCvtFromX procedures} -setup {
    setup
    setupbg
} -constraints unix -body {
    # Ensure that lists of atoms are constructed correctly, even when the
    # atom names have spaces in. [Bug 1353414]
    set selValue "foo bar"
    set selInfo ""
    set selType {text/x-tk-test;detail="foo bar"}
    selection handle -selection PRIMARY -format STRING -type $selType \
    .f1 [list handler $selType]
    lsort [dobg {selection get TARGETS}]
} -cleanup {
    cleanupbg
} -result {MULTIPLE TARGETS TIMESTAMP TK_APPLICATION TK_WINDOW {text/x-tk-test;detail="foo bar"}}

##############################################################################
# note, we are not testing MULTIPLE style selections

# most control paths have been exercised above
test select-10.1 {ConvertSelection procedure, race with selection clear} -constraints {
    unix 
} -setup {
    setup
} -body {
    proc Ready {fd} {
	variable x
	lappend x [gets $fd]
    }

    puts $fd {exit}
    flush $fd
    # Don't understand why, but the [loadTkCommand] above causes
    # a "broken pipe" error when Tk was actually [load]ed in the child.
    catch {close $fd}
    lappend x $selInfo
} -result {{1:PRIMARY selection doesn't exist or form "STRING" not defined} {}}
test select-10.2 {ConvertSelection procedure} -constraints unix -setup {
    setup
    setupbg
} -body {
    set selValue [string range $longValue 0 3999]
    set selInfo ""
    selection handle .f1 {handler STRING}
    set result ""
    lappend result [dobg {selection get}]
    cleanupbg
    lappend result $selInfo
} -result [list [string range $longValue 0 3999] {STRING 0 4000 STRING 4000 4000 STRING 0 4000 STRING 4000 4000}]
test select-10.3 {ConvertSelection procedure} -constraints unix -setup {
    setup
    setupbg
} -body {
    selection handle .f1 ERROR errHandler
    dobg {selection get ERROR}
} -cleanup {
    cleanupbg
} -result {PRIMARY selection doesn't exist or form "ERROR" not defined}
# testing timers
# This one hangs in Exceed
test select-10.4 {ConvertSelection procedure} -constraints {
    unix noExceed
} -setup {
    setup
    setupbg
} -body {
    set selValue $longValue
    set selInfo ""
    selection handle .f1 {errIncrHandler STRING}
    set result ""
    set pass 0
    lappend result [dobg {selection get}]
    cleanupbg
    lappend result $selInfo
} -result {{selection owner didn't respond} {STRING 0 4000 STRING 4000 4000 STRING 8000 4000 STRING 12000 4000 STRING 16000 4000 STRING 0 4000 STRING 4000 4000}}
test select-10.5 {ConvertSelection procedure, reentrancy issues} -constraints {
    unix 
} -setup {
    setup
    setupbg
} -body {
    set selValue "Test value"
    set selInfo ""
    selection handle -type TEST .f1 { handler TEST }
    selection handle -type STRING .f1 { badHandler .f1 STRING }
    set result ""
    lappend result [dobg {selection get}]
    cleanupbg
    lappend result $selInfo
} -result {{PRIMARY selection doesn't exist or form "STRING" not defined} {.f1 STRING 0 4000}}
test select-10.6 {ConvertSelection procedure, reentrancy issues} -constraints {
    unix 
} -setup {
    setup
    setupbg
} -body {
    proc weirdHandler {type offset count} {
	destroy .f1
	handler $type $offset $count

} -cleanup {
    rename weirdHandler {}
} -result {{PRIMARY selection doesn't exist or form "STRING" not defined} {STRING 0 4000}}

##############################################################################

# testing reentrancy
test select-11.1 {TkSelPropProc procedure} -constraints unix -setup {
    setup
    setupbg
} -body {
    set selValue $longValue
    set selInfo ""
    selection handle -type TEST .f1 { handler TEST }
    selection handle -type STRING .f1 { reallyBadHandler .f1 STRING }
    set result ""
    set pass 0
    lappend result [dobg {selection get}]
    cleanupbg
    lappend result $selInfo
} -result {{selection owner didn't respond} {.f1 STRING 0 4000 .f1 STRING 4000 4000 .f1 STRING 8000 4000 .f1 STRING 12000 4000 .f1 STRING 16000 4000 .f1 STRING 0 4000 .f1 STRING 4000 4000}}

##############################################################################

# Note, this assumes we are using CurrentTtime
test select-12.1 {DefaultSelection procedure} -constraints unix -body {
    setup
    set result [selection get -type TIMESTAMP]
    setupbg
    lappend result [dobg {selection get -type TIMESTAMP}]
    cleanupbg
    set result
} -result {0x0 {0x0 }}
test select-12.2 {DefaultSelection procedure} -constraints unix -body {
    setup
    set result [lsort [list [selection get -type TARGETS]]]
    setupbg
    lappend result [dobg {lsort [selection get -type TARGETS]}]
    cleanupbg
    set result
} -result {{MULTIPLE TARGETS TIMESTAMP TK_APPLICATION TK_WINDOW} {MULTIPLE TARGETS TIMESTAMP TK_APPLICATION TK_WINDOW}}
test select-12.3 {DefaultSelection procedure} -constraints unix -body {
    setup
    selection handle .f1 {handler TEST} TEST
    set result [list [lsort [selection get -type TARGETS]]]
    setupbg
    lappend result [dobg {lsort [selection get -type TARGETS]}]
    cleanupbg
    set result
} -result {{MULTIPLE TARGETS TEST TIMESTAMP TK_APPLICATION TK_WINDOW} {MULTIPLE TARGETS TEST TIMESTAMP TK_APPLICATION TK_WINDOW}}
test select-12.4 {DefaultSelection procedure} -constraints unix -setup {
    setup
    set result ""
} -body {
    lappend result [selection get -type TK_APPLICATION]
    setupbg
    lappend result [dobg {selection get -type TK_APPLICATION}]
    cleanupbg
    set result
} -result [list [winfo name .] [winfo name .]]
test select-12.5 {DefaultSelection procedure} -constraints unix -body {
    setup
    set result [selection get -type TK_WINDOW]
    setupbg
    lappend result [dobg {selection get -type TK_WINDOW}]
    cleanupbg
    set result
} -result {.f1 .f1}
test select-12.6 {DefaultSelection procedure} -body {
    setup
    selection handle .f1 {handler TARGETS.f1} TARGETS
    set selValue "Targets value"
    set selInfo ""
    set result [list [selection get TARGETS] $selInfo]
    selection handle .f1 {} TARGETS
    lappend result [selection get TARGETS]
} -result {{Targets value} {TARGETS.f1 0 4000} {MULTIPLE TARGETS TIMESTAMP TK_APPLICATION TK_WINDOW}}

test select-13.1 {SelectionSize procedure, handler deleted} -constraints {
    unix 
} -setup {
    setup
    setupbg
} -body {
    proc badHandler {path type offset count} {
	global selValue selInfo abortCount
	incr abortCount -1

    set j $i.1$i.2$i.3$i.4$i.5$i.6$i.7$i.8$i.9$i.10$i.11$i.12$i.13$i.14
    append longValue A$j B$j C$j D$j E$j F$j G$j H$j I$j K$j L$j M$j N$j
}

# ----------------------------------------------------------------------

test unixSelect-1.1 {TkSelGetSelection procedure: simple i18n text} -constraints {
    unix
} -setup {
    destroy .e
    setupbg
} -body {
    pack [entry .e]
    update
    .e insert 0 \u00fcber
    .e selection range 0 end
    dobg {string length [selection get]}
} -cleanup {
    cleanupbg
    destroy .e
} -result {4}

test unixSelect-1.2 {TkSelGetSelection procedure: simple i18n text, iso8859-1} -constraints {
    unix
} -setup {
    setupbg
} -body {
    dobg {
        pack [entry .e]
        update
        .e insert 0 \u00fc\u0444
        .e selection range 0 end
    }
    selection get
} -cleanup {
    cleanupbg
} -result \u00fc?

test unixSelect-1.3 {TkSelGetSelection procedure: simple i18n text, iso2022} -constraints {
    unix
} -setup {
    setupbg
    setup
} -body {
    selection handle -type COMPOUND_TEXT -format COMPOUND_TEXT . \
        {handler COMPOUND_TEXT}
    selection own .
    set selValue \u00fc\u0444
    set selInfo {}
    set result [dobg {
        set x [selection get -type COMPOUND_TEXT]
        list [string equal \u00fc\u0444 $x] [string length $x]
    }]
    lappend result $selInfo
} -cleanup {
    cleanupbg
} -result {1 2 {COMPOUND_TEXT 0 4000}}

test unixSelect-1.4 {TkSelGetSelection procedure: INCR i18n text, iso2022} -constraints {
    unix
} -setup {
    setupbg
    setup
} -body {
    # This test is subtle.  The selection ends up getting fetched twice by
    # Tk:  once to compute the length, and again to actually send the data.
    # The first time through, we don't convert the data to ISO2022, so the

    }]
    lappend result $selInfo
} -cleanup {
    cleanupbg
} -result {1 8000 {COMPOUND_TEXT 0 4000 COMPOUND_TEXT 4000 3999 COMPOUND_TEXT 7998 4000 COMPOUND_TEXT 0 4000 COMPOUND_TEXT 4000 3998 COMPOUND_TEXT 7997 4000}}

test unixSelect-1.5 {TkSelGetSelection procedure: simple i18n text, iso2022} -constraints {
    unix
} -setup {
    setupbg
    setup
} -body {
    selection handle -type COMPOUND_TEXT -format COMPOUND_TEXT . \
        {handler COMPOUND_TEXT}
    selection own .
    set selValue \u00fc\u0444
    set selInfo {}
    set result [dobg {
        set x [selection get -type COMPOUND_TEXT]
        list [string equal \u00fc\u0444 $x] [string length $x]
    }]
    lappend result $selInfo
} -cleanup {
    cleanupbg
} -result {1 2 {COMPOUND_TEXT 0 4000}}

test unixSelect-1.6 {TkSelGetSelection procedure: INCR i18n text} -constraints {
    unix
} -setup {
    setupbg
} -body {
    dobg [subst -nobackslashes {entry .e; pack .e; update
    .e insert 0 \u00fcber$longValue
    .e selection range 0 end}]
    string length [selection get]
} -cleanup {
    cleanupbg
} -result [expr {4 + [string length $longValue]}]

test unixSelect-1.7 {TkSelGetSelection procedure: INCR i18n text} -constraints {
    unix
} -setup {
    setupbg
} -body {
    dobg {
        pack [entry .e]
        update
        .e insert 0 [string repeat x 3999]\u00fc
        .e selection range 0 end
    }
    selection get
} -cleanup {
    cleanupbg
} -result [string repeat x 3999]\u00fc

test unixSelect-1.8 {TkSelGetSelection procedure: INCR i18n text} -constraints {
    unix
} -setup {
    setupbg
} -body {
    dobg {
        pack [entry .e]
        update
        .e insert 0 \u00fc[string repeat x 3999]
        .e selection range 0 end
    }
    selection get
} -cleanup {
    cleanupbg
} -result \u00fc[string repeat x 3999]

test unixSelect-1.9 {TkSelGetSelection procedure: INCR i18n text} -constraints {
    unix
} -setup {
    setupbg
} -body {
    dobg {
        pack [entry .e]
        update
        .e insert 0 [string repeat x 3999]\u00fc[string repeat x 4000]
        .e selection range 0 end
    }
    selection get
} -cleanup {
    cleanupbg
} -result [string repeat x 3999]\u00fc[string repeat x 4000]
# Now some tests to make sure that the right thing is done when
# transferring UTF8 selections, to prevent [Bug 614650] and its ilk
# from rearing its ugly head again.

test unixSelect-1.10 {TkSelGetSelection procedure: INCR i18n text, utf-8} -constraints {
    unix
} -setup {
    setupbg
} -body {
    dobg {
        pack [entry .e]
        update
        .e insert 0 [string repeat x 3999]\u00fc
        .e selection range 0 end
    }
    selection get -type UTF8_STRING
} -cleanup {
    cleanupbg
} -result [string repeat x 3999]\u00fc

test unixSelect-1.11 {TkSelGetSelection procedure: INCR i18n text, utf-8} -constraints {
    unix
} -setup {
    setupbg
} -body {
    dobg {
        pack [entry .e]
        update
        .e insert 0 \u00fc[string repeat x 3999]
        .e selection range 0 end
    }
    selection get -type UTF8_STRING
} -cleanup {
    cleanupbg
} -result \u00fc[string repeat x 3999]

test unixSelect-1.12 {TkSelGetSelection procedure: INCR i18n text, utf-8} -constraints {
    unix
} -setup {
    setupbg
} -body {
    dobg {
        pack [entry .e]
        update
        .e insert 0 [string repeat x 3999]\u00fc[string repeat x 4000]
        .e selection range 0 end
    }
    selection get -type UTF8_STRING
} -cleanup {
    cleanupbg
} -result [string repeat x 3999]\u00fc[string repeat x 4000]

test unixSelect-1.13 {TkSelGetSelection procedure: simple i18n text, utf-8} -constraints {
    unix
} -setup {
    destroy .e
    setupbg
} -body {
    pack [entry .e]
    update
    .e insert 0 \u00fcber\u0444
    .e selection range 0 end
    dobg {string length [selection get -type UTF8_STRING]}
} -cleanup {
    destroy .e
    cleanupbg
} -result {5}

test unixSelect-1.14 {TkSelGetSelection procedure: simple i18n text, utf-8} -constraints {
    unix
} -setup {
    setupbg
} -body {
    dobg {
        pack [entry .e]
        update
        .e insert 0 \u00fc\u0444
        .e selection range 0 end
    }
    selection get -type UTF8_STRING
} -cleanup {
    cleanupbg
} -result \u00fc\u0444

test unixSelect-1.15 {TkSelGetSelection procedure: INCR i18n text, utf-8} -constraints {
    unix
} -setup {
    setupbg
} -body {
    dobg {
        pack [entry .e]
        update
        .e insert 0 [string repeat [string repeat \u00c4\u00e4 50]\n 21]
        .e selection range 0 end
    }
    selection get -type UTF8_STRING
} -cleanup {
    cleanupbg
} -result [string repeat [string repeat \u00c4\u00e4 50]\n 21]

test unixSelect-1.16 {TkSelGetSelection procedure: INCR i18n text, utf-8} -constraints {
    unix
} -setup {
    setupbg
} -body {
    dobg {
        pack [entry .e]
        update
        .e insert 0 i[string repeat [string repeat \u00c4\u00e4 50]\n 21]
        .e selection range 0 end
    }
    selection get -type UTF8_STRING
} -cleanup {
    cleanupbg
} -result i[string repeat [string repeat \u00c4\u00e4 50]\n 21]

test unixSelect-1.17 {TkSelGetSelection procedure: INCR i18n text, utf-8} -constraints {
    unix
} -setup {
    setupbg
} -body {
    dobg {
        pack [text .t]
        update
        .t insert 1.0 [string repeat [string repeat \u00c4\u00e4 50]\n 21]
        # Has to be selected in a separate stage
        .t tag add sel 1.0 21.end+1c
    }
    after 10
    selection get -type UTF8_STRING
} -cleanup {
    cleanupbg
} -result [string repeat [string repeat \u00c4\u00e4 50]\n 21]

test unixSelect-1.18 {TkSelGetSelection procedure: INCR i18n text, utf-8} -constraints {
    unix
} -setup {
    setupbg
} -body {
    dobg {
        pack [text .t]
        update
        .t insert 1.0 i[string repeat [string repeat \u00c4\u00e4 50]\n 21]