archie/tk3.6/tests/listbox.test

# This file is a Tcl script to test out the "listbox" command
# of Tk.  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/listbox.test,v 1.3 93/04/24 14:03:10 ouster Exp $ (Berkeley)

if {[string compare test [info procs test]] == 1} then \
  {source defs}

foreach i [winfo children .] {
    destroy $i
}
wm geometry . {}
listbox .l -geometry 20x20 -bd 2 -relief raised
pack append . .l top
update

proc listboxGet {} {
    set last [.l size]
    set result {}
    for {set i 0} {$i < $last} {incr i} {
	lappend result [.l get $i]
    }
    return $result
}

test listbox-1.1 {insert widget command} {
    listboxGet
} {}
.l insert end a b c {d e}
test listbox-1.2 {insert widget command} {
    listboxGet
} {a b c {d e}}
.l i 1 x y
test listbox-1.3 {insert widget command} {
    listboxGet
} {a x y b c {d e}}
.l insert end xx
test listbox-1.4 {insert widget command} {
    listboxGet
} {a x y b c {d e} xx}
.l insert -2 early
test listbox-1.5 {insert widget command} {
    listboxGet
} {early a x y b c {d e} xx}
.l insert 100 late
test listbox-1.6 {insert widget command} {
    listboxGet
} {early a x y b c {d e} xx late}
test listbox-1.7 {insert widget command} {
    list [catch {.l insert 1} msg] $msg [listboxGet]
} {0 {} {early a x y b c {d e} xx late}}
test listbox-1.8 {insert widget command} {
    list [catch {.l insert} msg] $msg
} {1 {wrong # args: should be ".l insert index ?element element ...?"}}
test listbox-1.9 {insert widget command} {
    list [catch {.l insert gorp} msg] $msg
} {1 {bad listbox index "gorp"}}

test listbox-2.1 {delete widget command} {
    .l delete 0 end
    .l insert 0 a b c d e
    .l delete 1
    listboxGet
} {a c d e}
test listbox-2.2 {delete widget command} {
    .l delete 0 end
    .l insert 0 a b c d e
    .l d 1 3
    listboxGet
} {a e}
test listbox-2.3 {delete widget command} {
    .l delete 0 end
    .l insert 0 a b c d e
    .l delete 3 end
    listboxGet
} {a b c}
test listbox-2.4 {delete widget command} {
    .l delete 0 end
    .l insert 0 a b c d e
    .l delete end
    listboxGet
} {a b c d}
test listbox-2.5 {delete widget command} {
    .l delete 0 end
    .l insert 0 a b c d e
    .l delete 0
    listboxGet
} {b c d e}
test listbox-2.6 {delete widget command} {
    .l delete 0 end
    .l insert 0 a b c d e
    .l delete 3 2
    listboxGet
} {a b c d e}
test listbox-2.7 {delete widget command} {
    .l delete 0 end
    .l insert 0 a b c d e
    .l delete -2 2
    listboxGet
} {d e}
test listbox-2.8 {delete widget command} {
    .l delete 0 end
    .l insert 0 a b c d e
    .l delete 1 1000
    listboxGet
} {a}
test listbox-2.9 {delete widget command} {
    .l delete 0 end
    .l delete end
    listboxGet
} {}
test listbox-2.10 {delete widget command} {
    list [catch {.l delete} msg] $msg
} {1 {wrong # args: should be ".l delete firstIndex ?lastIndex?"}}
test listbox-2.11 {delete widget command} {
    list [catch {.l delete 1 2 3} msg] $msg
} {1 {wrong # args: should be ".l delete firstIndex ?lastIndex?"}}
test listbox-2.12 {delete widget command} {
    list [catch {.l delete eof} msg] $msg
} {1 {bad listbox index "eof"}}

.l delete 0 end
.l insert 0 el0 el1 el2 el3 el4
update
test listbox-3.1 {get widget command} {
    .l get 0
} el0
test listbox-3.2 {get widget command} {
    .l g 1
} el1
test listbox-3.3 {get widget command} {
    .l get end
} el4
test listbox-3.4 {get widget command} {
    .l get -2
} el0
test listbox-3.5 {get widget command} {
    .l get 100
} el4
test listbox-3.6 {get widget command} {
    list [catch {.l get} msg] $msg
} {1 {wrong # args: should be ".l get index"}}
test listbox-3.7 {get widget command} {
    list [catch {.l get 1 2} msg] $msg
} {1 {wrong # args: should be ".l get index"}}
test listbox-3.8 {get widget command} {
    list [catch {.l get junk} msg] $msg
} {1 {bad listbox index "junk"}}

.l delete 0 end
for {set i 0} {$i < 30} {incr i} {
    .l insert end el$i
}
test listbox-4.1 {nearest widget command} {
    .l n 0
} 0
test listbox-4.2 {nearest widget command} {
    .l nearest [winfo height .l]
} 19
.l yview 5
test listbox-4.3 {nearest widget command} {
    .l nearest 0
} 5
test listbox-4.4 {nearest widget command} {
    .l nearest [winfo height .l]
} 24
test listbox-4.5 {nearest widget command} {
    list [catch {.l nearest} msg] $msg
} {1 {wrong # args: should be ".l nearest y"}}
test listbox-4.6 {nearest widget command} {
    list [catch {.l nearest 1 2} msg] $msg
} {1 {wrong # args: should be ".l nearest y"}}
test listbox-4.7 {nearest widget command} {
    list [catch {.l nearest gorp} msg] $msg
} {1 {expected integer but got "gorp"}}

test listbox-5.1 {selections} {
    .l curselection
} {}
test listbox-5.2 {selections} {
    .l select clear
    .l select from 1
    .l curselection
} {1}
test listbox-5.3 {selections} {
    .l select clear
    .l select from end
    .l curselection
} {29}
test listbox-5.4 {selections} {
    .l select clear
    .l select to 2
    .l curselection
} {2}
test listbox-5.5 {selections} {
    .l select clear
    .l select from 23
    .l select to end
    .l curselection
} {23 24 25 26 27 28 29}
test listbox-5.6 {selections} {
    .l select clear
    .l select from 23
    .l select to 20
    .l curselection
} {20 21 22 23}
test listbox-5.7 {selections} {
    .l select clear
    .l select from 23
    .l select to 28
    .l select to 20
    .l curselection
} {20 21 22 23}
test listbox-5.8 {selections} {
    .l select clear
    .l select from 5
    .l select to 10
    .l select adjust 12
    .l curselection
} {5 6 7 8 9 10 11 12}
test listbox-5.9 {selections} {
    .l select clear
    .l select from 5
    .l select to 10
    .l select adjust 9
    .l curselection
} {5 6 7 8 9}
test listbox-5.10 {selections} {
    .l select c
    .l select f 5
    .l select t 10
    .l select a 6
    .l curselection
} {6 7 8 9 10}
test listbox-5.11 {selections} {
    .l select clear
    .l select from 5
    .l select t 10
    .l select adjust 3
    .l curselection
} {3 4 5 6 7 8 9 10}
test listbox-5.12 {selections} {
    .l select clear
    .l select from 5
    .l select to 10
    .l select adjust 12
    .l select adjust 7
    .l curselection
} {7 8 9 10 11 12}
test listbox-5.13 {selections} {
    .l select clear
    .l select from 5
    .l select to 10
    .l select clear
    .l curselection
} {}
test listbox-5.14 {selections} {
    list [catch {.l select} msg] $msg
} {1 {too few args: should be ".l select option ?index?"}}
test listbox-5.15 {selections} {
    list [catch {.l select adjust} msg] $msg
} {1 {wrong # args: should be ".l select option index"}}
test listbox-5.16 {selections} {
    list [catch {.l select adjust 1 2} msg] $msg
} {1 {wrong # args: should be ".l select option index"}}
test listbox-5.17 {selections} {
    list [catch {.l select adjust junk} msg] $msg
} {1 {bad listbox index "junk"}}
test listbox-5.18 {selections} {
    list [catch {.l select clear 1} msg] $msg
} {1 {wrong # args: should be ".l select clear"}}
test listbox-5.19 {selections} {
    list [catch {.l select from} msg] $msg
} {1 {wrong # args: should be ".l select option index"}}
test listbox-5.20 {selections} {
    list [catch {.l select from 1 2} msg] $msg
} {1 {wrong # args: should be ".l select option index"}}
test listbox-5.21 {selections} {
    list [catch {.l select from eof} msg] $msg
} {1 {bad listbox index "eof"}}
test listbox-5.22 {selections} {
    list [catch {.l select to} msg] $msg
} {1 {wrong # args: should be ".l select option index"}}
test listbox-5.23 {selections} {
    list [catch {.l select to 1 2} msg] $msg
} {1 {wrong # args: should be ".l select option index"}}
test listbox-5.24 {selections} {
    list [catch {.l select to eof} msg] $msg
} {1 {bad listbox index "eof"}}

proc lbSelUpdateTest {cmd} {
    .l delete 0 end
    .l insert 0 el0 el1 el2 el3 el4 el5 el6 el7 el8
    .l select from 3
    .l select to 6
    uplevel $cmd
    .l curselection
}
test listbox-6.1 {selections and inserts/deletes} {
    lbSelUpdateTest {.l delete 1}
} {2 3 4 5}
test listbox-6.2 {selections and inserts/deletes} {
    lbSelUpdateTest {.l delete 1 4}
} {1 2}
test listbox-6.3 {selections and inserts/deletes} {
    lbSelUpdateTest {.l delete 4}
} {3 4 5}
test listbox-6.4 {selections and inserts/deletes} {
    lbSelUpdateTest {.l delete 5 7}
} {3 4}
test listbox-6.5 {selections and inserts/deletes} {
    lbSelUpdateTest {.l delete end}
} {3 4 5 6}
test listbox-6.6 {selections and inserts/deletes} {
    lbSelUpdateTest {.l delete 1 7}
} {}
test listbox-6.7 {selections and inserts/deletes} {
    lbSelUpdateTest {.l insert 1 x}
} {4 5 6 7}
test listbox-6.8 {selections and inserts/deletes} {
    lbSelUpdateTest {.l insert 3 x y}
} {5 6 7 8}
test listbox-6.9 {selections and inserts/deletes} {
    lbSelUpdateTest {.l insert 4 x}
} {3 4 5 6 7}
test listbox-6.10 {selections and inserts/deletes} {
    lbSelUpdateTest {.l insert 7 x y}
} {3 4 5 6}

catch {unset x}
set x {}
test listbox-7.1 {-exportselection option} {
    selection clear .
    .l select from 1
    lappend x [catch {selection get} msg] $msg [.l curselection]
    .l config -exportselection 0
    lappend x [catch {selection get} msg] $msg [.l curselection]
    .l select clear
    lappend x [catch {selection get} msg] $msg [.l curselection]
    .l select from 1
    .l select to 3
    lappend x [catch {selection get} msg] $msg [.l curselection]
    .l config -exportselection 1
    lappend x [catch {selection get} msg] $msg [.l curselection]
} {0 el1 1 1 {selection doesn't exist or form "STRING" not defined} 1 1 {selection doesn't exist or form "STRING" not defined} {} 1 {selection doesn't exist or form "STRING" not defined} {1 2 3} 0 {el1 el2 el3} {1 2 3}}
test list-7.2 {-exportselection option} {
    .l select from 1
    .l select to 3
    selection clear .
    list [catch {selection get} msg] $msg [.l curselection]
} {1 {selection doesn't exist or form "STRING" not defined} {}}

.l delete 0 end
for {set i 0} {$i < 30} {incr i} {
    .l insert end el$i
}
test list-8.1 {yview widget command} {
    .l yview 0
    .l nearest 0
} 0
test list-8.2 {yview widget command} {
    .l yview end
    .l nearest 0
} 29
test list-8.3 {yview widget command} {
    .l yview 5
    .l nearest 0
} 5
test list-8.4 {yview widget command} {
    .l yview 5
    .l delete 1 3
    .l nearest 0
} 2
test list-8.5 {yview widget command} {
    .l yview 5
    .l delete 5 8
    .l nearest 0
} 5
test list-8.6 {yview widget command} {
    .l yview 5
    .l delete 10
    .l nearest 0
} 5
test list-8.6 {yview widget command} {
    list [catch {.l yview} msg] $msg
} {1 {wrong # args: should be ".l yview index"}}
test list-8.7 {yview widget command} {
    list [catch {.l yview 1 2} msg] $msg
} {1 {wrong # args: should be ".l yview index"}}
test list-8.8 {yview widget command} {
    list [catch {.l yview junk} msg] $msg
} {1 {bad listbox index "junk"}}

test listbox-9.1 {miscellaneous} {
    list [catch {.l} msg] $msg
} {1 {wrong # args: should be ".l option ?arg arg ...?"}}
test listbox-9.2 {miscellaneous} {
    list [catch {.l junk} msg] $msg
} {1 {bad option "junk": must be configure, curselection, delete, get, insert, nearest, scan, select, size, xview, or yview}}
test listbox-9.3 {miscellaneous} {
    list [catch {.l s} msg] $msg
} {1 {bad option "s": must be configure, curselection, delete, get, insert, nearest, scan, select, size, xview, or yview}}
destroy .l
test listbox-9.4 {miscellaneous} {
    list [catch {.l} msg] $msg
} {1 {invalid command name ".l"}}