213 lines
7.5 KiB
Plaintext
213 lines
7.5 KiB
Plaintext
# This file is a Tcl script to test out Tk's selection management code,
|
|
# especially the "selection" command. It is organized in the standard
|
|
# fashion for Tcl tests.
|
|
#
|
|
# Copyright (c) 1993 The Regents of the University of California.
|
|
# All rights reserved.
|
|
#
|
|
# Permission is hereby granted, without written agreement and without
|
|
# license or royalty fees, to use, copy, modify, and distribute this
|
|
# software and its documentation for any purpose, provided that the
|
|
# above copyright notice and the following two paragraphs appear in
|
|
# all copies of this software.
|
|
#
|
|
# IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY FOR
|
|
# DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT
|
|
# OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN IF THE UNIVERSITY OF
|
|
# CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|
|
#
|
|
# THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES,
|
|
# INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
|
|
# AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS
|
|
# ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION TO
|
|
# PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS.
|
|
#
|
|
# $Header: /user6/ouster/wish/tests/RCS/select.test,v 1.4 93/06/04 08:44:14 ouster Exp $ (Berkeley)
|
|
|
|
if {[string compare test [info procs test]] == 1} {
|
|
source defs
|
|
}
|
|
|
|
catch {destroy .f1}
|
|
catch {destroy .f2}
|
|
catch {destroy .f3}
|
|
|
|
frame .f1
|
|
frame .f2
|
|
frame .f3
|
|
|
|
proc handler {type offset count} {
|
|
global selValue selInfo
|
|
|
|
lappend selInfo $type $offset $count
|
|
set numBytes [expr {[string length $selValue] - $offset}]
|
|
if {$numBytes <= 0} {
|
|
return ""
|
|
}
|
|
string range $selValue $offset [expr $numBytes+$offset]
|
|
}
|
|
|
|
proc errHandler args {
|
|
error "selection handler aborted"
|
|
}
|
|
|
|
# Eliminate any existing selection on the screen. This is needed in case
|
|
# there is a selection in some other application, in order to prevent races
|
|
# from causing false errors in the tests below.
|
|
|
|
selection clear .
|
|
after 1000
|
|
|
|
test select-1.1 {simple Tcl-based handler} {
|
|
selection own .f1
|
|
lsort [selection get TARGETS]
|
|
} {APPLICATION MULTIPLE TARGETS TIMESTAMP WINDOW_NAME}
|
|
selection handle .f1 {handler TEST} TEST
|
|
test select-1.2 {simple Tcl-based handler} {
|
|
selection own .f1
|
|
lsort [selection get TARGETS]
|
|
} {APPLICATION MULTIPLE TARGETS TEST TIMESTAMP WINDOW_NAME}
|
|
test select-1.3 {simple Tcl-based handler} {
|
|
selection own .f1
|
|
set selValue "Test value"
|
|
set selInfo ""
|
|
list [selection get TEST] $selInfo
|
|
} {{Test value} {TEST 0 4000}}
|
|
selection handle .f1 {handler STRING}
|
|
test select-1.4 {simple Tcl-based handler} {
|
|
selection own .f1
|
|
lsort [selection get TARGETS]
|
|
} {APPLICATION MULTIPLE STRING TARGETS TEST TIMESTAMP WINDOW_NAME}
|
|
test select-1.5 {simple Tcl-based handler} {
|
|
selection own .f1
|
|
set selValue ""
|
|
set selInfo ""
|
|
list [selection get] $selInfo
|
|
} {{} {STRING 0 4000}}
|
|
test select-1.6 {simple Tcl-based handler} {
|
|
list [catch {selection get BADTARGET} msg] $msg
|
|
} {1 {selection doesn't exist or form "BADTARGET" not defined}}
|
|
test select-1.7 {simple Tcl-based handler} {
|
|
set lostSel {XXX}
|
|
selection own .f1 {set lostSel "selection gone"}
|
|
selection own .f2
|
|
set lostSel
|
|
} {selection gone}
|
|
selection handle .f1 ERROR errHandler
|
|
test select-1.8 {simple Tcl-based handler} {
|
|
selection own .f1
|
|
list [catch {selection get ERROR} msg] $msg
|
|
} {1 {selection doesn't exist or form "ERROR" not defined}}
|
|
if $atBerkeley {
|
|
test select-1.9 {simple Tcl-based handler} {
|
|
set lostSel {XXX}
|
|
set selValue "Test2"
|
|
set selInfo ""
|
|
selection own .f1 {set lostSel "selection gone"}
|
|
destroy .f1
|
|
list [catch {selection get} msg] $msg $lostSel $selInfo
|
|
} {1 {selection doesn't exist or form "STRING" not defined} XXX {}}
|
|
}
|
|
|
|
selection handle .f2 {handler STRING.f2}
|
|
set selValue ""
|
|
foreach i {a b c d e f g j h i j k l m o p q r s t u v w x y z} {
|
|
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 selValue 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 select-2.1 {long retrievals} {
|
|
selection own .f2
|
|
set selInfo ""
|
|
list [selection get] $selInfo
|
|
} "$selValue {STRING.f2 0 4000 STRING.f2 4000 4000 STRING.f2 8000 4000 STRING.f2 12000 4000 STRING.f2 16000 4000}"
|
|
|
|
test select-3.1 {handlers provided by Tk} {
|
|
selection own .f2
|
|
list [selection get APPLICATION] [selection get WINDOW_NAME]
|
|
} [list [winfo name .] .f2]
|
|
selection handle .f2 {handler TARGETS.f2} TARGETS
|
|
test select-3.2 {handlers provided by Tk} {
|
|
selection own .f2
|
|
set selValue "Timestamp value"
|
|
set selInfo ""
|
|
list [selection get TARGETS] $selInfo
|
|
} {{Timestamp value} {TARGETS.f2 0 4000}}
|
|
selection handle .f2 {} TARGETS
|
|
test select-3.3 {handlers provided by Tk} {
|
|
selection get TARGETS
|
|
} {APPLICATION MULTIPLE TARGETS TIMESTAMP WINDOW_NAME STRING}
|
|
|
|
catch {destroy .f1}
|
|
frame .f1
|
|
selection handle .f1 {handler TEST1.f1} TEST1
|
|
selection handle .f1 {handler TEST2.f1} TEST2
|
|
selection handle .f1 {handler TEST3.f1} TEST3
|
|
test select-4.1 {modifying and deleting handlers} {
|
|
selection handle .f1 {handler TEST1.new} TEST1
|
|
selection own .f1
|
|
set selValue "value"
|
|
set selInfo ""
|
|
list [selection get TEST1] $selInfo
|
|
} {value {TEST1.new 0 4000}}
|
|
selection handle .f1 {} TEST2
|
|
test select-4.2 {modifying and deleting handlers} {
|
|
selection get TARGETS
|
|
} {APPLICATION MULTIPLE TARGETS TIMESTAMP WINDOW_NAME TEST3 TEST1}
|
|
selection handle .f1 {} TEST1
|
|
test select-4.3 {modifying and deleting handlers} {
|
|
selection get TARGETS
|
|
} {APPLICATION MULTIPLE TARGETS TIMESTAMP WINDOW_NAME TEST3}
|
|
selection handle .f1 {} TEST3
|
|
test select-4.4 {modifying and deleting handlers} {
|
|
selection get TARGETS
|
|
} {APPLICATION MULTIPLE TARGETS TIMESTAMP WINDOW_NAME}
|
|
|
|
test select-5.1 {clearing the selection} {
|
|
selection own .f2
|
|
set result [selection get WINDOW_NAME]
|
|
selection clear .
|
|
list $result [catch {selection get WINDOW_NAME} msg] $msg
|
|
} {.f2 1 {selection doesn't exist or form "WINDOW_NAME" not defined}}
|
|
|
|
test select-6.1 {selection own option} {
|
|
selection own .f2
|
|
selection own
|
|
} .f2
|
|
test select-6.2 {selection own option} {
|
|
selection own .f3
|
|
selection clear .
|
|
selection own
|
|
} {}
|
|
|
|
test select-6.1 {errors in selection command} {
|
|
list [catch selection msg] $msg
|
|
} {1 {wrong # args: should be "selection option ?arg arg ...?"}}
|
|
test select-6.2 {errors in selection command} {
|
|
list [catch {selection junk} msg] $msg
|
|
} {1 {bad option "junk": must be clear, get, handle, or own}}
|
|
test select-6.3 {errors in selection command} {
|
|
list [catch {selection clear} msg] $msg
|
|
} {1 {wrong # args: should be "selection clear window"}}
|
|
test select-6.4 {errors in selection command} {
|
|
list [catch {selection clear foo} msg] $msg
|
|
} {1 {bad window path name "foo"}}
|
|
test select-6.5 {errors in selection command} {
|
|
list [catch {selection get a b} msg] $msg
|
|
} {1 {too may args: should be "selection get ?type?"}}
|
|
test select-6.6 {errors in selection command} {
|
|
list [catch {selection handle a} msg] $msg
|
|
} {1 {wrong # args: should be "selection handle window command ?type? ?format?"}}
|
|
test select-6.7 {errors in selection command} {
|
|
list [catch {selection handle a b c d e} msg] $msg
|
|
} {1 {wrong # args: should be "selection handle window command ?type? ?format?"}}
|
|
test select-6.8 {errors in selection command} {
|
|
list [catch {selection own a b c} msg] $msg
|
|
} {1 {wrong # args: should be "selection own ?window? ?command?"}}
|
|
test select-6.9 {errors in selection command} {
|
|
list [catch {selection own junk} msg] $msg
|
|
} {1 {bad window path name "junk"}}
|
|
|
|
destroy .f1
|
|
destroy .f2
|
|
destroy .f3
|