← Back to branch summary

~ubuntu-branches/ubuntu/natty/perl-tk/natty

« back to all changes in this revision

Viewing changes to t/listbox.t

  • Committer: Bazaar Package Importer
  • Author(s): Stephen Zander
  • Date: 2004-03-14 13:54:44 UTC
  • mfrom: (1.1.1 upstream)
  • Revision ID: james.westby@ubuntu.com-20040314135444-prc09u2or4dbr3to
Tags: 1:800.025-2
http://bugs.debian.org/237942
Add xlibs-dev to Build-Depends:,
Closes: #237942

Show diffs side-by-side

added added

removed removed

Lines of Context:
t/listbox.t
 
1
#!/usr/bin/perl -w
 
2
# -*- perl -*-
 
3
 
 
4
# This file is the translation of a Tcl script to test out the "listbox"
 
5
# command of Tk.  It is organized in the standard fashion for Tcl tests.
 
6
#
 
7
# Copyright (c) 1993-1994 The Regents of the University of California.
 
8
# Copyright (c) 1994-1997 Sun Microsystems, Inc.
 
9
# Copyright (c) 1998-1999 by Scriptics Corporation.
 
10
# All rights reserved.
 
11
#
 
12
# RCS: @(#) $Id: listbox.t,v 1.2 2002/04/17 21:06:12 eserte Exp $
 
13
#
 
14
# Translated to perl by Slaven Rezic
 
15
#
 
16
 
 
17
use strict;
 
18
use vars qw($Listbox);
 
19
 
 
20
use Tk;
 
21
 
 
22
BEGIN {
 
23
    $Listbox = "Listbox";
 
24
    #$Listbox = "TextList";
 
25
    eval "use Tk::$Listbox";
 
26
}
 
27
 
 
28
BEGIN {
 
29
    if (!eval q{
 
30
        use Test 1.13;
 
31
        1;
 
32
    }) {
 
33
        print "# tests only work with installed Test module:\n";
 
34
        print join("\n", map { "## $_" } split(/\n/, $@)), "\n";
 
35
        print "1..1\n";
 
36
        print "ok 1\n";
 
37
        exit;
 
38
    }
 
39
}
 
40
 
 
41
BEGIN { plan tests => 425 }
 
42
 
 
43
my $partial_top;
 
44
my $partial_lb;
 
45
 
 
46
my $mw = new MainWindow;
 
47
$mw->geometry('');
 
48
$mw->raise;
 
49
my $fixed = 'Courier -12';
 
50
ok(Tk::Exists($mw), 1);
 
51
 
 
52
# Create entries in the option database to be sure that geometry options
 
53
# like border width have predictable values.
 
54
$mw->optionAdd("*$Listbox.borderWidth",2);
 
55
$mw->optionAdd("*$Listbox.highlightThickness",2);
 
56
$mw->optionAdd("*$Listbox.font",'Helvetica -12 bold');
 
57
 
 
58
my $lb = $mw->$Listbox->pack;
 
59
ok(Tk::Exists($lb), 1);
 
60
ok($lb->isa("Tk::$Listbox"), 1);
 
61
$lb->update;
 
62
 
 
63
resetGridInfo();
 
64
 
 
65
foreach my $test
 
66
    (['-background', '#ff0000', '#ff0000', 'non-existent',
 
67
      'unknown color name "non-existent"'],
 
68
     [qw{-bd 4 4 badValue}, q{bad screen distance "badValue"}],
 
69
     ['-bg', '#ff0000', '#ff0000', 'non-existent',
 
70
      'unknown color name "non-existent"'],
 
71
     [qw{-borderwidth 1.3 1 badValue}, q{bad screen distance "badValue"}],
 
72
     [qw{-cursor arrow arrow badValue}, q{bad cursor spec "badValue"}],
 
73
# XXX error test skipped...
 
74
     [qw{-exportselection yes 1}, "", #"xyzzy",
 
75
      q{expected boolean value but got "xyzzy"}],
 
76
     ['-fg', '#110022', '#110022', 'bogus', q{unknown color name "bogus"}],
 
77
# XXX should test perl font object
 
78
#     ['-font', 'Helvetica 12', 'Helvetica 12', '', "font \"\" doesn't exist"],
 
79
     ['-foreground', '#110022', '#110022', 'bogus',
 
80
      q{unknown color name "bogus"}],
 
81
# XXX q{expected integer but got "20p"}
 
82
     [qw{-height 30 30 20p}, "'20p' isn't numeric"],
 
83
     ['-highlightbackground', '#112233', '#112233', 'ugly',
 
84
      q{unknown color name "ugly"}],
 
85
     ['-highlightcolor', '#123456', '#123456', 'bogus',
 
86
      q{unknown color name "bogus"}],
 
87
     [qw{-highlightthickness 6 6 bogus}, q{bad screen distance "bogus"}],
 
88
     [qw{-highlightthickness -2 0}, '', ''],
 
89
     [qw{-relief groove groove 1.5},
 
90
      ($Tk::VERSION < 803
 
91
       ? q{bad relief type "1.5": must be flat, groove, raised, ridge, solid, or sunken}
 
92
       : q{bad relief "1.5": must be flat, groove, raised, ridge, solid, or sunken})],
 
93
     ['-selectbackground', '#110022', '#110022', 'bogus',
 
94
      q{unknown color name "bogus"}],
 
95
     [qw{-selectborderwidth 1.3 1 badValue},
 
96
      q{bad screen distance "badValue"}],
 
97
     ['-selectforeground', '#654321', '#654321', 'bogus',
 
98
      q{unknown color name "bogus"}],
 
99
     [qw{-selectmode string string}, '', ''],
 
100
     [qw{-setgrid false 0}, "", # XXX "lousy",
 
101
      q{expected boolean value but got "lousy"}],
 
102
     ['-takefocus', "any string", "any string", '', ''],
 
103
     [qw{-width 45 45 3p}, "'3p' isn't numeric"],
 
104
      #XXXq{expected integer but got "3p"}],
 
105
#XXX Callback object      ['-xscrollcommand', 'Some command', 'Some command', '', ''],
 
106
#XXX     ['-yscrollcommand', 'Another command', 'Another command', '', ''],
 
107
#XXX not yet in 800.022     [qw{-listvar}, \$testVariable,  testVariable {}}, q{}],
 
108
    ) {
 
109
        my $name = $test->[0];
 
110
 
 
111
        if ($Listbox eq 'TextList' &&
 
112
            $name =~ /^-(bg|fg|foreground|height|selectborderwidth)$/) {
 
113
            skip(1,1);
 
114
            if ($test->[3] ne "") {
 
115
                skip(1,1);
 
116
            }
 
117
            next;
 
118
        }
 
119
 
 
120
        $lb->configure($name, $test->[1]);
 
121
        ok(($lb->configure($name))[4], $test->[2], "configuration option $name");
 
122
        ok($lb->cget($name), $test->[2], "cget call with $name");
 
123
        if ($test->[3] ne "") {
 
124
            eval {
 
125
                $lb->configure($name, $test->[3]);
 
126
            };
 
127
            ok($@ =~ /$test->[4]/, 1, "wrong error message for $name, got $@");
 
128
        }
 
129
        $lb->configure($name, ($lb->configure($name))[3]);
 
130
    }
 
131
 
 
132
if ($Listbox ne 'Listbox') {
 
133
    skip(1, 1);
 
134
} else {
 
135
    eval { Tk::listbox() };
 
136
    ok($@ =~ /Usage \$widget->listbox(...)/, 1, "wrong error message $@");
 
137
}
 
138
 
 
139
eval {
 
140
    $lb->destroy;
 
141
    $lb = $mw->$Listbox;
 
142
};
 
143
ok(Tk::Exists($lb), 1);
 
144
ok($lb->class, "$Listbox");
 
145
 
 
146
eval {
 
147
    $lb->destroy;
 
148
    $lb = $mw->$Listbox(-gorp => "foo");
 
149
};
 
150
ok($Tk::VERSION < 803
 
151
   ? $@ =~ /Bad option \`-gorp\'/
 
152
   : $@ =~ /unknown option \"-gorp\"/,
 
153
   1, "wrong error message, got $@");
 
154
ok(Tk::Exists($lb), 0);
 
155
 
 
156
$lb = $mw->$Listbox(-width => 20, -height => 5, -bd => 4,
 
157
                   -highlightthickness => 1,
 
158
                   -selectborderwidth => 2)->pack;
 
159
$lb->insert(0,
 
160
            'el0','el1','el2','el3','el4','el5','el6','el7','el8','el9','el10',
 
161
            'el11','el12','el13','el14','el15','el16','el17');
 
162
$lb->update;
 
163
eval { $lb->activate };
 
164
ok($@ =~ /wrong \# args: should be "\.listbox.* activate index"/, 1,
 
165
   "wrong error message, got $@");
 
166
 
 
167
eval { $lb->activate("fooey") };
 
168
ok($@ =~ /bad listbox index "fooey": must be active, anchor, end, \@x,y, or a number/, 1, "wrong error message, got $@");
 
169
 
 
170
$lb->activate(3);
 
171
ok($lb->index("active"), 3);
 
172
 
 
173
$lb->activate(-1);
 
174
ok($lb->index("active"), 0);
 
175
 
 
176
$lb->activate(30);
 
177
ok($lb->index("active"), 17);
 
178
 
 
179
$lb->activate("end");
 
180
ok($lb->index("active"), 17);
 
181
 
 
182
eval { $lb->bbox };
 
183
ok($@ =~ /wrong \# args: should be "\.listbox.* bbox index"/, 1,
 
184
   "wrong error message, got $@");
 
185
 
 
186
eval { $lb->bbox(qw/a b/) };
 
187
ok($@ =~ /wrong \# args: should be "\.listbox.* bbox index"/, 1,
 
188
   "wrong error message, got $@");
 
189
 
 
190
eval { $lb->bbox("fooey") };
 
191
ok($@ =~ /bad listbox index "fooey": must be active, anchor, end, \@x,y, or a number/, 1, "wrong error message, got $@");
 
192
 
 
193
$lb->yview(3);
 
194
$lb->update;
 
195
ok($lb->bbox(2), undef);
 
196
ok($lb->bbox(8), undef);
 
197
 
 
198
# Used to generate a core dump before a bug was fixed (the last
 
199
# element would be on-screen if it existed, but it doesn't exist).
 
200
eval {
 
201
    my $l2 = $mw->$Listbox;
 
202
    $l2->pack(-side => "top");
 
203
    $l2->waitVisibility;
 
204
    my $x = $l2->bbox(0);
 
205
    $l2->destroy;
 
206
};
 
207
ok($@, '', "wrong error message, got $@");
 
208
 
 
209
$lb->yview(3);
 
210
$lb->update;
 
211
ok(join(" ", $lb->bbox(3)), "7 7 17 14");
 
212
ok(scalar @{[$lb->bbox(3)]}, 4);
 
213
ok(($lb->bbox(3))[0], 7);
 
214
ok(($lb->bbox(3))[-1], 14);
 
215
ok(join(" ", $lb->bbox(4)), "7 26 17 14");
 
216
 
 
217
$lb->yview(0);
 
218
$lb->update;
 
219
ok($lb->bbox(-1), undef);
 
220
ok(join(" ", $lb->bbox(0)), "7 7 17 14");
 
221
 
 
222
$lb->yview("end");
 
223
$lb->update;
 
224
ok(join(" ", $lb->bbox(17)), "7 83 24 14");
 
225
ok(join(" ", $lb->bbox("end")), "7 83 24 14");
 
226
ok($lb->bbox(18), undef);
 
227
 
 
228
{
 
229
    my $t = $mw->Toplevel;
 
230
    $t->geometry("+0+0");
 
231
    my $lb = $t->$Listbox(-width => 10,
 
232
                         -height => 5);
 
233
    $lb->insert(0, "Short", "Somewhat longer",
 
234
                "Really, quite a whole lot longer than can possibly fit on the screen",
 
235
                "Short");
 
236
    $lb->pack;
 
237
    $lb->update;
 
238
    $lb->xview(moveto => 0.2);
 
239
    ok(join(" ", $lb->bbox(2)), '-72 39 393 14');
 
240
    $t->destroy;
 
241
}
 
242
 
 
243
mkPartial();
 
244
ok(join(" ", $partial_lb->bbox(3)), "5 56 24 14");
 
245
ok(join(" ", $partial_lb->bbox(4)), "5 73 23 14");
 
246
 
 
247
eval { $lb->cget };
 
248
ok($@ =~ /wrong \# args: should be \"\.listbox.* cget option\"/, 1,
 
249
   "wrong error message, got $@");
 
250
 
 
251
eval { $lb->cget(qw/a b/) };
 
252
ok($@ =~ /wrong \# args: should be \"\.listbox.* cget option\"/, 1,
 
253
   "wrong error message, got $@");
 
254
 
 
255
eval { $lb->cget(-gorp) };
 
256
ok($@ =~ /unknown option "-gorp"/, 1, "wrong error message, got $@");
 
257
 
 
258
ok($lb->cget(-setgrid), 0);
 
259
# XXX why 25 in Tk800?
 
260
ok(scalar @{[$lb->configure]}, ($Tk::VERSION < 803 ? 25 : 24));
 
261
ok(join(" ", $lb->configure(-setgrid)),
 
262
   "-setgrid setGrid SetGrid 0 0");
 
263
eval { $lb->configure(-gorp) };
 
264
ok($@ =~ /unknown option "-gorp"/, 1, "wrong error message, got $@");
 
265
 
 
266
{
 
267
    my $oldbd = $lb->cget(-bd);
 
268
    my $oldht = $lb->cget(-highlightthickness);
 
269
    $lb->configure(-bd => 3, -highlightthickness => 0);
 
270
    ok($lb->cget(-bd), 3);
 
271
    ok($lb->cget(-highlightthickness), 0);
 
272
    $lb->configure(-bd => $oldbd);
 
273
    $lb->configure(-highlightthickness => $oldht);
 
274
}
 
275
 
 
276
eval { $lb->curselection("a") };
 
277
ok($@ =~ /wrong \# args: should be \"\.listbox.* curselection\"/, 1,
 
278
   "wrong error message, got $@");
 
279
 
 
280
$lb->selection("clear", 0, "end");
 
281
$lb->selection("set", 3, 6);
 
282
$lb->selection("set", 9);
 
283
ok(join(" ", $lb->curselection), "3 4 5 6 9");
 
284
 
 
285
# alternative perl/Tk methods
 
286
$lb->selectionClear(0, "end");
 
287
$lb->selectionSet(3, 6);
 
288
$lb->selectionSet(9);
 
289
ok(join(" ", $lb->curselection), "3 4 5 6 9");
 
290
 
 
291
eval { $lb->delete };
 
292
ok($@ =~ /wrong \# args: should be \"\.listbox.* delete firstIndex \?lastIndex\?\"/, 1,
 
293
   "wrong error message, got $@");
 
294
 
 
295
eval { $lb->delete(qw/a b c/) };
 
296
ok($@ =~ /wrong \# args: should be \"\.listbox.* delete firstIndex \?lastIndex\?\"/, 1,
 
297
   "wrong error message, got $@");
 
298
 
 
299
eval { $lb->delete("badindex") };
 
300
ok($@ =~ /bad listbox index "badindex": must be active, anchor, end, \@x,y, or a number/, 1,
 
301
   "wrong error message, got $@");
 
302
 
 
303
eval { $lb->delete(2, "123ab") };
 
304
ok($@ =~ /bad listbox index "123ab": must be active, anchor, end, \@x,y, or a number/, 1,
 
305
   "wrong error message, got $@");
 
306
 
 
307
{
 
308
    my $l2 = $mw->$Listbox;
 
309
    $l2->insert(0, qw(el0 el1 el2 el3 el4 el5 el6 el7));
 
310
    $l2->delete(3);
 
311
    ok($l2->get(2), "el2");
 
312
    ok($l2->get(3), "el4");
 
313
    ok($l2->index("end"), "7");
 
314
    $l2->destroy;
 
315
}
 
316
 
 
317
{
 
318
    my $l2 = $mw->$Listbox;
 
319
    $l2->insert(0, qw(el0 el1 el2 el3 el4 el5 el6 el7));
 
320
    $l2->delete(2, 4);
 
321
    ok($l2->get(1), "el1");
 
322
    ok($l2->get(2), "el5");
 
323
    ok($l2->index("end"), "5");
 
324
    $l2->destroy;
 
325
}
 
326
 
 
327
{
 
328
    my $l2 = $mw->$Listbox;
 
329
    $l2->insert(0, qw(el0 el1 el2 el3 el4 el5 el6 el7));
 
330
    $l2->delete(-3, 2);
 
331
    ok(join(" ", $l2->get(0, "end")), "el3 el4 el5 el6 el7");
 
332
    $l2->destroy;
 
333
}
 
334
 
 
335
{
 
336
    my $l2 = $mw->$Listbox;
 
337
    $l2->insert(0, qw(el0 el1 el2 el3 el4 el5 el6 el7));
 
338
    $l2->delete(-3, -1);
 
339
    ok(join(" ", $l2->get(0, "end")), join(" ", map { "el$_" } (0 .. 7)));
 
340
    ok(scalar @{[$l2->get(0, "end")]}, 8);
 
341
    $l2->destroy;
 
342
}
 
343
 
 
344
{
 
345
    my $l2 = $mw->$Listbox;
 
346
    $l2->insert(0, qw(el0 el1 el2 el3 el4 el5 el6 el7));
 
347
    $l2->delete(2, "end");
 
348
    ok(join(" ", $l2->get(0, "end")), "el0 el1");
 
349
    ok(scalar @{[$l2->get(0, "end")]}, 2);
 
350
    $l2->destroy;
 
351
}
 
352
 
 
353
{
 
354
    my $l2 = $mw->$Listbox;
 
355
    $l2->insert(0, qw(el0 el1 el2 el3 el4 el5 el6 el7));
 
356
    $l2->delete(5, 20);
 
357
    ok(join(" ", $l2->get(0, "end")), "el0 el1 el2 el3 el4");
 
358
    ok(scalar @{[$l2->get(0, "end")]}, 5);
 
359
    $l2->destroy;
 
360
}
 
361
 
 
362
{
 
363
    my $l2 = $mw->$Listbox;
 
364
    $l2->insert(0, qw(el0 el1 el2 el3 el4 el5 el6 el7));
 
365
    $l2->delete("end", 20);
 
366
    ok(join(" ", $l2->get(0, "end")), "el0 el1 el2 el3 el4 el5 el6");
 
367
    ok(scalar @{[$l2->get(0, "end")]}, 7);
 
368
    $l2->destroy;
 
369
}
 
370
 
 
371
{
 
372
    my $l2 = $mw->$Listbox;
 
373
    $l2->insert(0, qw(el0 el1 el2 el3 el4 el5 el6 el7));
 
374
    $l2->delete(8, 20);
 
375
    ok(join(" ", $l2->get(0, "end")), "el0 el1 el2 el3 el4 el5 el6 el7");
 
376
    ok(scalar @{[$l2->get(0, "end")]}, 8);
 
377
    $l2->destroy;
 
378
}
 
379
 
 
380
eval { $lb->get };
 
381
ok($Tk::VERSION < 803
 
382
   ? $@ =~ /wrong \# args: should be \"\.listbox.* get first \?last\?\"/
 
383
   : $@ =~ /wrong \# args: should be \"\.listbox.* get firstIndex \?lastIndex\?\"/,
 
384
   1,
 
385
   "wrong error message, got $@");
 
386
 
 
387
eval { $lb->get(qw/a b c/) };
 
388
ok($Tk::VERSION < 803
 
389
   ? $@ =~ /wrong \# args: should be \"\.listbox.* get first \?last\?\"/
 
390
   : $@ =~ /wrong \# args: should be \"\.listbox.* get firstIndex \?lastIndex\?\"/,
 
391
   1,
 
392
   "wrong error message, got $@");
 
393
 
 
394
# XXX ok in perl/Tk
 
395
#  eval { $lb->get("2.4") };
 
396
#  ok($@ =~ /bad listbox index "2.4": must be active, anchor, end, \@x,y, or a number/, 1,
 
397
#     "wrong error message, got $@");
 
398
 
 
399
eval { $lb->get("badindex") };
 
400
ok($@ =~ /bad listbox index "badindex": must be active, anchor, end, \@x,y, or a number/, 1,
 
401
   "wrong error message, got $@");
 
402
 
 
403
eval { $lb->get("end", "bogus") };
 
404
ok($@ =~ /bad listbox index "bogus": must be active, anchor, end, \@x,y, or a number/, 1,
 
405
   "wrong error message, got $@");
 
406
 
 
407
{
 
408
    my $l2 = $mw->$Listbox;
 
409
    $l2->insert(0, qw(el0 el1 el2 el3 el4 el5 el6 el7));
 
410
    ok($l2->get(0), "el0");
 
411
    ok($l2->get(3), "el3");
 
412
    ok($l2->get("end"), "el7");
 
413
    $l2->destroy;
 
414
}
 
415
 
 
416
{
 
417
    my $l2 = $mw->$Listbox;
 
418
    ok($l2->get(0), undef);
 
419
    ok($l2->get("end"), undef);
 
420
    $l2->destroy;
 
421
}
 
422
 
 
423
{
 
424
    my $l2 = $mw->$Listbox;
 
425
    $l2->insert(0, qw(el0 el1 el2), "two words", qw(el4 el5 el6 el7));
 
426
    ok($l2->get(3), "two words");
 
427
    ok(($l2->get(3, "end"))[0], "two words");
 
428
    ok(join(" ", $l2->get(3, "end")), "two words el4 el5 el6 el7");
 
429
}
 
430
 
 
431
ok($lb->get(-1), undef);
 
432
ok($lb->get(-2, -1), undef);
 
433
ok(join(" ", $lb->get(-2, 3)), "el0 el1 el2 el3");
 
434
ok(scalar @{[ $lb->get(-2, 3) ]}, 4);
 
435
 
 
436
ok(join(" ", $lb->get(12, "end")), "el12 el13 el14 el15 el16 el17");
 
437
ok(scalar @{[ $lb->get(12, "end") ]}, 6);
 
438
ok(join(" ", $lb->get(12, 20)), "el12 el13 el14 el15 el16 el17");
 
439
ok(scalar @{[ $lb->get(12, 20) ]}, 6);
 
440
 
 
441
ok($lb->get("end"), "el17");
 
442
ok($lb->get(30), undef);
 
443
ok($lb->get(30, 35), ());
 
444
 
 
445
eval { $lb->index };
 
446
ok($@ =~ /wrong \# args: should be \"\.listbox.* index index\"/, 1,
 
447
   "wrong error message, got $@");
 
448
 
 
449
eval { $lb->index(qw/a b/) };
 
450
ok($@ =~ /wrong \# args: should be \"\.listbox.* index index\"/, 1,
 
451
   "wrong error message, got $@");
 
452
 
 
453
eval { $lb->index(qw/@/) };
 
454
ok($@ =~ /bad listbox index "\@": must be active, anchor, end, \@x,y, or a number/, 1,
 
455
   "wrong error message, got $@");
 
456
 
 
457
ok($lb->index(2), 2);
 
458
ok($lb->index(-1), -1);
 
459
ok($lb->index("end"), 18);
 
460
ok($lb->index(34), 34);
 
461
 
 
462
eval { $lb->insert };
 
463
ok($@ =~ /wrong \# args: should be \"\.listbox.* insert index \?element element \.\.\.\?\"/, 1,
 
464
   "wrong error message, got $@");
 
465
 
 
466
eval { $lb->insert("badindex") };
 
467
ok($@ =~ /bad listbox index "badindex": must be active, anchor, end, \@x,y, or a number/, 1,
 
468
   "wrong error message, got $@");
 
469
 
 
470
{
 
471
    my $l2 = $mw->$Listbox;
 
472
    $l2->insert("end", qw/a b c d e/);
 
473
    $l2->insert(3, qw/x y z/);
 
474
    ok(join(" ", $l2->get(0, "end")), 'a b c x y z d e');
 
475
    ok(scalar @{[ $l2->get(0, "end") ]}, 8);
 
476
    $l2->destroy;
 
477
}
 
478
 
 
479
{
 
480
    my $l2 = $mw->$Listbox;
 
481
    $l2->insert("end", qw/a b c/);
 
482
    $l2->insert(-1, qw/x/);
 
483
    ok(join(" ", $l2->get(0, "end")), 'x a b c');
 
484
    ok(scalar @{[ $l2->get(0, "end") ]}, 4);
 
485
    $l2->destroy;
 
486
}
 
487
 
 
488
{
 
489
    my $l2 = $mw->$Listbox;
 
490
    $l2->insert("end", qw/a b c/);
 
491
    $l2->insert("end", qw/x/);
 
492
    ok(join(" ", $l2->get(0, "end")), 'a b c x');
 
493
    ok(scalar @{[ $l2->get(0, "end") ]}, 4);
 
494
    $l2->destroy;
 
495
}
 
496
 
 
497
{
 
498
    my $l2 = $mw->$Listbox;
 
499
    $l2->insert("end", qw/a b c/);
 
500
    $l2->insert(43, qw/x/);
 
501
    ok(join(" ", $l2->get(0, "end")), 'a b c x');
 
502
    ok(scalar @{[ $l2->get(0, "end") ]}, 4);
 
503
    $l2->insert(4, qw/y/);
 
504
    ok(join(" ", $l2->get(0, "end")), 'a b c x y');
 
505
    $l2->insert(6, qw/z/);
 
506
    ok(join(" ", $l2->get(0, "end")), 'a b c x y z');
 
507
    $l2->destroy;
 
508
}
 
509
 
 
510
eval { $lb->nearest };
 
511
ok($@ =~ /wrong \# args: should be \"\.listbox.* nearest y\"/, 1,
 
512
   "wrong error message, got $@");
 
513
 
 
514
eval { $lb->nearest(qw/a b/) };
 
515
ok($@ =~ /wrong \# args: should be \"\.listbox.* nearest y\"/, 1,
 
516
   "wrong error message, got $@");
 
517
 
 
518
eval { $lb->nearest("badindex") };
 
519
ok($@ =~ /\'badindex\' isn\'t numeric/, 1,
 
520
   "wrong error message, got $@");
 
521
 
 
522
$lb->yview(3);
 
523
ok($lb->nearest(1000), 7);
 
524
 
 
525
eval { $lb->scan };
 
526
ok($Tk::VERSION < 803
 
527
   ? $@ =~ /wrong \# args: should be \"\.listbox.* scan mark x y\" or \"\.listbox.* scan dragto x y \?gain\?\"/
 
528
   : $@ =~ /wrong \# args: should be \"\.listbox.* scan mark\|dragto x y\"/, 1,
 
529
   "wrong error message, got $@");
 
530
 
 
531
eval { $lb->scan(qw/a b/) };
 
532
ok($Tk::VERSION < 803
 
533
   ? $@ =~ /wrong \# args: should be \"\.listbox.* scan mark x y\" or \"\.listbox.* scan dragto x y \?gain\?\"/
 
534
   : $@ =~ /wrong \# args: should be \"\.listbox.* scan mark\|dragto x y\"/, 1,
 
535
   "wrong error message, got $@");
 
536
 
 
537
eval { $lb->scan(qw/a b c d/) };
 
538
ok($Tk::VERSION < 803
 
539
   ? $@ =~ /\'b\' isn\'t numeric/
 
540
   : $@ =~ /wrong \# args: should be \"\.listbox.* scan mark\|dragto x y\"/,
 
541
   1, "wrong error message, got $@");
 
542
 
 
543
eval { $lb->scan(qw/foo bogus 2/) };
 
544
ok($@ =~ /\'bogus\' isn\'t numeric/,
 
545
   1, "wrong error message, got $@");
 
546
 
 
547
## ok in perl
 
548
#  eval { $lb->scan(qw/foo 2 2.3/) };
 
549
#  ok($@ =~ /'2.3' isn't numeric/, 1,
 
550
#     "wrong error message, got $@");
 
551
 
 
552
eval { $lb->scan(qw/foo 2 3/) };
 
553
ok($Tk::VERSION < 803
 
554
   ? $@ =~ /bad scan option \"foo\": must be mark or dragto/
 
555
   : $@ =~ /bad option \"foo\": must be mark, or dragto/,
 
556
   1, "wrong error message, got $@");
 
557
 
 
558
{
 
559
    my $t = $mw->Toplevel;
 
560
    $t->geometry("+0+0");
 
561
    my $lb = $t->$Listbox(-width => 10, -height => 5);
 
562
    $lb->insert(0, "Short", "Somewhat longer",
 
563
                "Really, quite a whole lot longer than can possibly fit on the screen", "Short",
 
564
                qw/a b c d e f g h i j/);
 
565
    $lb->pack;
 
566
    $lb->update;
 
567
    $lb->scan("mark", 100, 140);
 
568
    $lb->scan("dragto", 90, 137);
 
569
    $lb->update;
 
570
    ok(join(",",$lb->xview) =~ /^0\.24936.*,0\.42748.*$/, 1,
 
571
       join(",",$lb->xview));
 
572
    ok(join(",",$lb->yview) =~ /^0\.071428.*,0\.428571.*$/, 1,
 
573
       join(",",$lb->yview));
 
574
    $t->destroy;
 
575
}
 
576
 
 
577
eval { $lb->see };
 
578
ok($@ =~ /wrong \# args: should be \"\.listbox.* see index\"/, 1,
 
579
   "wrong error message, got $@");
 
580
 
 
581
eval { $lb->see("a","b") };
 
582
ok($@ =~ /wrong \# args: should be \"\.listbox.* see index\"/, 1,
 
583
   "wrong error message, got $@");
 
584
 
 
585
eval { $lb->see("badindex") };
 
586
ok($@ =~ /bad listbox index "badindex": must be active, anchor, end, \@x,y, or a number/, 1,
 
587
   "wrong error message, got $@");
 
588
 
 
589
$lb->yview(7);
 
590
$lb->see(7);
 
591
ok($lb->index('@0,0'), 7);
 
592
 
 
593
$lb->yview(7);
 
594
$lb->see(11);
 
595
ok($lb->index('@0,0'), 7);
 
596
 
 
597
$lb->yview(7);
 
598
$lb->see(6);
 
599
ok($lb->index('@0,0'), 6);
 
600
 
 
601
$lb->yview(7);
 
602
$lb->see(5);
 
603
ok($lb->index('@0,0'), 3);
 
604
 
 
605
$lb->yview(7);
 
606
$lb->see(12);
 
607
ok($lb->index('@0,0'), 8);
 
608
 
 
609
$lb->yview(7);
 
610
$lb->see(13);
 
611
ok($lb->index('@0,0'), 11);
 
612
 
 
613
$lb->yview(7);
 
614
$lb->see(-1);
 
615
ok($lb->index('@0,0'), 0);
 
616
 
 
617
$lb->yview(7);
 
618
$lb->see("end");
 
619
ok($lb->index('@0,0'), 13);
 
620
 
 
621
$lb->yview(7);
 
622
$lb->see(322);
 
623
ok($lb->index('@0,0'), 13);
 
624
 
 
625
mkPartial();
 
626
$partial_lb->see(4);
 
627
ok($partial_lb->index('@0,0'), 1);
 
628
 
 
629
eval { $lb->selection };
 
630
ok($@ =~ /wrong \# args: should be \"\.listbox.* selection option index \?index\?\"/, 1,
 
631
   "wrong error message, got $@");
 
632
 
 
633
eval { $lb->selection("a") };
 
634
ok($@ =~ /wrong \# args: should be \"\.listbox.* selection option index \?index\?\"/, 1,
 
635
   "wrong error message, got $@");
 
636
 
 
637
eval { $lb->selection(qw/a b c d/) };
 
638
ok($@ =~ /wrong \# args: should be \"\.listbox.* selection option index \?index\?\"/, 1,
 
639
   "wrong error message, got $@");
 
640
 
 
641
eval { $lb->selection(qw/a bogus/) };
 
642
ok($@ =~ /bad listbox index \"bogus\": must be active, anchor, end, \@x,y, or a number/, 1,
 
643
   "wrong error message, got $@");
 
644
 
 
645
eval { $lb->selection(qw/a 0 lousy/) };
 
646
ok($@ =~ /bad listbox index \"lousy\": must be active, anchor, end, \@x,y, or a number/, 1,
 
647
   "wrong error message, got $@");
 
648
 
 
649
eval { $lb->selection(qw/anchor 0 0/) };
 
650
ok($@ =~ /wrong \# args: should be \"\.listbox.* selection anchor index\"/, 1,
 
651
   "wrong error message, got $@");
 
652
 
 
653
$lb->selection("anchor", 5);
 
654
ok($lb->index("anchor"), 5);
 
655
$lb->selectionAnchor(0);
 
656
ok($lb->index("anchor"), 0);
 
657
 
 
658
$lb->selectionAnchor(-1);
 
659
ok($lb->index("anchor"), 0);
 
660
$lb->selectionAnchor("end");
 
661
ok($lb->index("anchor"), 17);
 
662
$lb->selectionAnchor(44);
 
663
ok($lb->index("anchor"), 17);
 
664
 
 
665
$lb->selection("clear", 0, "end");
 
666
$lb->selection("set", 2, 8);
 
667
$lb->selection("clear", 3, 4);
 
668
ok(join(",",$lb->curselection), "2,5,6,7,8");
 
669
 
 
670
$lb->selectionClear(0, "end");
 
671
$lb->selectionSet(2, 8);
 
672
$lb->selectionClear(3, 4);
 
673
ok(join(",",$lb->curselection), "2,5,6,7,8");
 
674
 
 
675
eval { $lb->selection(qw/includes 0 0/) };
 
676
ok($@ =~ /wrong \# args: should be \"\.listbox.* selection includes index\"/, 1,
 
677
   "wrong error message, got $@");
 
678
 
 
679
$lb->selectionClear(0, "end");
 
680
$lb->selectionSet(2,8);
 
681
$lb->selectionClear(4);
 
682
ok($lb->selection("includes", 3), 1);
 
683
ok($lb->selection("includes", 4), 0);
 
684
ok($lb->selection("includes", 5), 1);
 
685
ok($lb->selectionIncludes(3), 1);
 
686
 
 
687
$lb->selectionSet(0, "end");
 
688
ok($lb->selectionIncludes(-1), 0);
 
689
 
 
690
$lb->selectionClear(0, "end");
 
691
$lb->selectionSet("end");
 
692
ok($lb->selection("includes", "end"), 1);
 
693
 
 
694
$lb->selectionClear(0, "end");
 
695
$lb->selectionSet("end");
 
696
ok($lb->selection("includes", 44), 0);
 
697
 
 
698
{
 
699
    my $l2 = $mw->$Listbox;
 
700
    ok($l2->selectionIncludes(0), 0);
 
701
    $l2->destroy;
 
702
}
 
703
 
 
704
$lb->selection(qw(clear 0 end));
 
705
$lb->selection(qw(set 2));
 
706
$lb->selection(qw(set 5 7));
 
707
ok(join(" ", $lb->curselection), "2 5 6 7");
 
708
ok(scalar @{[$lb->curselection]}, 4);
 
709
$lb->selection(qw(set 5 7));
 
710
ok(join(" ", $lb->curselection), "2 5 6 7");
 
711
ok(scalar @{[$lb->curselection]}, 4);
 
712
 
 
713
eval { $lb->selection(qw/badOption 0 0/) };
 
714
ok($Tk::VERSION < 803
 
715
   ? $@ =~ /bad selection option \"badOption\": must be anchor, clear, includes, or set/
 
716
   : $@ =~ /bad option \"badOption\": must be anchor, clear, includes, or set/,
 
717
   1, "wrong error message, got $@");
 
718
 
 
719
eval { $lb->size(qw/a/) };
 
720
ok($@ =~ /wrong \# args: should be \"\.listbox.* size\"/, 1,
 
721
   "wrong error message, got $@");
 
722
 
 
723
ok($lb->size, 18);
 
724
 
 
725
{
 
726
    my $l2 = $mw->$Listbox;
 
727
    $l2->update;
 
728
    ok(($l2->xview)[0], 0);
 
729
    ok(($l2->xview)[1], 1);
 
730
    $l2->destroy;
 
731
}
 
732
 
 
733
eval { $lb->destroy };
 
734
$lb = $mw->$Listbox(-width => 10, -height => 5, -font => $fixed);
 
735
$lb->insert(qw/0 a b c d e f g h i j k l m n o p q r s t/);
 
736
$lb->pack;
 
737
$lb->update;
 
738
ok(($lb->xview)[0], 0);
 
739
ok(($lb->xview)[1], 1);
 
740
 
 
741
eval { $lb->destroy };
 
742
$lb = $mw->$Listbox(-width => 10, -height => 5, -font => $fixed);
 
743
$lb->insert(qw/0 a b c d e f g h i j k l m n o p q r s t/);
 
744
$lb->insert(qw/1 0123456789a123456789b123456789c123456789d123456789/);
 
745
$lb->pack;
 
746
$lb->update;
 
747
 
 
748
$lb->xview(4);
 
749
ok(join(",",$lb->xview), "0.08,0.28");
 
750
 
 
751
eval { $lb->xview("foo") };
 
752
ok($@ =~ /\'foo\' isn\'t numeric/, 1,
 
753
   "wrong error message, got $@");
 
754
 
 
755
eval { $lb->xview("zoom", "a", "b") };
 
756
ok($@ =~ /unknown option \"zoom\": must be moveto or scroll/, 1,
 
757
   "wrong error message, got $@");
 
758
 
 
759
$lb->xview(0);
 
760
$lb->xview(moveto => 0.4);
 
761
$lb->update;
 
762
ok(($lb->xview)[0], 0.4);
 
763
ok(($lb->xview)[1], 0.6);
 
764
 
 
765
$lb->xview(0);
 
766
$lb->xview(scroll => 2, "units");
 
767
$lb->update;
 
768
ok("@{[ $lb->xview ]}", '0.04 0.24');
 
769
 
 
770
$lb->xview(30);
 
771
$lb->xview(scroll => -1, "pages");
 
772
$lb->update;
 
773
ok("@{[ $lb->xview ]}", '0.44 0.64');
 
774
 
 
775
$lb->configure(-width => 1);
 
776
$lb->update;
 
777
$lb->xview(30);
 
778
$lb->xview("scroll", -4, "pages");
 
779
$lb->update;
 
780
ok("@{[ $lb->xview ]}", '0.52 0.54');
 
781
 
 
782
eval { $lb->destroy };
 
783
$lb = $mw->$Listbox->pack;
 
784
$lb->update;
 
785
ok(($lb->yview)[0], 0);
 
786
ok(($lb->yview)[1], 1);
 
787
 
 
788
eval { $lb->destroy };
 
789
$lb = $mw->$Listbox->pack;
 
790
$lb->insert(0, "el1");
 
791
$lb->update;
 
792
ok(($lb->yview)[0], 0);
 
793
ok(($lb->yview)[1], 1);
 
794
 
 
795
eval { $lb->destroy };
 
796
$lb = $mw->$Listbox(-width => 10, -height => 5, -font => $fixed);
 
797
$lb->insert(0,'a','b','c','d','e','f','g','h','i','j','k','l','m','n','o',
 
798
            'p','q','r','s','t');
 
799
$lb->pack;
 
800
$lb->update;
 
801
$lb->yview(4);
 
802
$lb->update;
 
803
ok(($lb->yview)[0], 0.2);
 
804
ok(($lb->yview)[1], 0.45);
 
805
 
 
806
mkPartial();
 
807
ok(($partial_lb->yview)[0], 0);
 
808
ok(($partial_lb->yview)[1] =~ /^0\.26666/, 1,
 
809
   "got " . (($partial_lb->yview)[1]));
 
810
 
 
811
eval { $lb->xview("foo") };
 
812
ok($@ =~ /\'foo\' isn\'t numeric/, 1,
 
813
   "wrong error message, got $@");
 
814
 
 
815
eval { $lb->xview("foo", "a", "b") };
 
816
ok($@ =~ /unknown option \"foo\": must be moveto or scroll/, 1,
 
817
   "wrong error message, got $@");
 
818
 
 
819
$lb->yview(0);
 
820
$lb->yview(moveto => 0.31);
 
821
ok("@{[ $lb->yview ]}", "0.3 0.55");
 
822
 
 
823
$lb->yview(2);
 
824
$lb->yview(scroll => 2 => "pages");
 
825
ok("@{[ $lb->yview ]}", "0.4 0.65");
 
826
 
 
827
$lb->yview(10);
 
828
$lb->yview(scroll => -3 => "units");
 
829
ok("@{[ $lb->yview ]}", "0.35 0.6");
 
830
 
 
831
$lb->configure(-height => 2);
 
832
$lb->update;
 
833
$lb->yview(15);
 
834
$lb->yview(scroll => -4 => "pages");
 
835
ok("@{[ $lb->yview ]}", "0.55 0.65");
 
836
 
 
837
# No tests for DestroyListbox:  I can't come up with anything to test
 
838
# in this procedure.
 
839
 
 
840
eval { $lb->destroy };
 
841
$lb = $mw->$Listbox(-setgrid => 1, -width => 25, -height => 15);
 
842
$lb->pack;
 
843
$mw->update;
 
844
ok(getsize($mw), "25x15");
 
845
$lb->configure(-setgrid => 0);
 
846
$mw->update;
 
847
ok(getsize($mw), "185x263");
 
848
 
 
849
resetGridInfo();
 
850
 
 
851
$lb->configure(-highlightthickness => -3);
 
852
ok($lb->cget(-highlightthickness), 0);
 
853
 
 
854
$lb->configure(-exportselection => 0);
 
855
$lb->delete(0, "end");
 
856
$lb->insert(0, qw(el0 el1 el2 el3 el4 el5 el6 el7 el8));
 
857
$lb->selection("set", 3, 5);
 
858
$lb->configure(-exportselection => 1);
 
859
ok($mw->SelectionGet, "el3\nel4\nel5");
 
860
 
 
861
my $e = $mw->Entry;
 
862
$e->insert(0, "abc");
 
863
$e->selection("from", 0);
 
864
$e->selection("to", 2);
 
865
$lb->configure(-exportselection => 0);
 
866
$lb->delete(0, "end");
 
867
$lb->insert(0, qw(el0 el1 el2 el3 el4 el5 el6 el7 el8));
 
868
$lb->selectionSet(3, 5);
 
869
$lb->selectionClear(3, 5);
 
870
$lb->configure(-exportselection => 1);
 
871
ok($mw->SelectionOwner, $e);
 
872
ok($mw->SelectionGet, "ab");
 
873
$e->destroy;
 
874
 
 
875
$mw->SelectionClear;
 
876
$lb->configure(-exportselection => 1);
 
877
$lb->delete(0, "end");
 
878
$lb->insert(qw(0 el0 el1 el2 el3 el4 el5 el6 el7 el8));
 
879
$lb->selection("set", 1, 1);
 
880
ok($mw->SelectionGet, "el1");
 
881
ok($lb->curselection, "1");
 
882
$lb->configure(-exportselection => 0);
 
883
eval { $mw->SelectionGet };
 
884
ok($@ =~ /PRIMARY selection doesn\'t exist or form \"STRING\" not defined/, 1,
 
885
   "wrong error message: $@");
 
886
ok($lb->curselection, "1");
 
887
$lb->selection("clear", 0, "end");
 
888
eval { $mw->SelectionGet };
 
889
ok($@ =~ /PRIMARY selection doesn\'t exist or form \"STRING\" not defined/, 1,
 
890
   "wrong error message: $@");
 
891
ok($lb->curselection, ());
 
892
$lb->selection("set", 1, 3);
 
893
eval { $mw->SelectionGet };
 
894
ok($@ =~ /PRIMARY selection doesn\'t exist or form \"STRING\" not defined/, 1,
 
895
   "wrong error message: $@");
 
896
ok("@{[$lb->curselection]}", "1 2 3");
 
897
$lb->configure(-exportselection => 1);
 
898
ok($mw->SelectionGet, "el1\nel2\nel3");
 
899
ok("@{[$lb->curselection]}", "1 2 3");
 
900
 
 
901
$lb->destroy;
 
902
$mw->geometry("300x300");
 
903
$mw->update;
 
904
$mw->geometry("");
 
905
$mw->withdraw;
 
906
$lb = $mw->$Listbox(-font => $fixed, -width => 15, -height => 20);
 
907
$lb->pack;
 
908
$lb->update;
 
909
$mw->deiconify;
 
910
ok(getsize($mw), "118x328");
 
911
$lb->configure(-setgrid => 1);
 
912
$mw->update;
 
913
ok(getsize($mw), "15x20");
 
914
 
 
915
$lb->destroy;
 
916
$mw->withdraw;
 
917
$lb = $mw->$Listbox(-font => $fixed, -width => 30, -height => 20,
 
918
                   -setgrid => 1);
 
919
$mw->geometry("+0+0");
 
920
$lb->pack;
 
921
$mw->update;
 
922
$mw->deiconify;
 
923
ok(getsize($mw), "30x20");
 
924
$mw->geometry("26x15");
 
925
$mw->update;
 
926
ok(getsize($mw), "26x15");
 
927
$lb->configure(-setgrid => 1);
 
928
$lb->update;
 
929
ok(getsize($mw), "26x15");
 
930
 
 
931
$mw->geometry("");
 
932
$lb->destroy;
 
933
resetGridInfo();
 
934
 
 
935
my @log;
 
936
 
 
937
$lb = $mw->$Listbox(-width => 15, -height => 20,
 
938
                   -xscrollcommand => sub { record("x", @_) },
 
939
                   -yscrollcommand => [qw/record y/],
 
940
                  )->pack;
 
941
$lb->update;
 
942
$lb->configure(-fg => "black");
 
943
@log = ();
 
944
$lb->update;
 
945
ok($log[0], "y 0 1");
 
946
ok($log[1], "x 0 1");
 
947
 
 
948
$lb->destroy;
 
949
my @x = qw/a b c d/;
 
950
#XXX these are missing: -listvar tests, because 800.023 do not know this option
 
951
# $lb = $mw->$Listbox(-listvar => \@x);
 
952
# ok(join(",",$lb->get(0, "end")), "a,b,c,d");
 
953
 
 
954
#test listbox-4.10 {ConfigureListbox, no listvar -> existing listvar} {
 
955
#    catch {destroy $_lb}
 
956
#    set x [list a b c d]
 
957
#    listbox $_lb
 
958
#    $_lb insert end 1 2 3 4
 
959
#    $_lb configure -listvar x
 
960
#    $_lb get 0 end
 
961
#} [list a b c d]
 
962
#test listbox-4.11 {ConfigureListbox procedure, listvar -> no listvar} {
 
963
#    catch {destroy $_lb}
 
964
#    set x [list a b c d]
 
965
#    listbox $_lb -listvar x
 
966
#    $_lb configure -listvar {}
 
967
#    $_lb insert end 1 2 3 4
 
968
#    list $x [$_lb get 0 end]
 
969
#} [list [list a b c d] [list a b c d 1 2 3 4]]
 
970
#test listbox-4.12 {ConfigureListbox procedure, listvar -> different listvar} {
 
971
#    catch {destroy $_lb}
 
972
#    set x [list a b c d]
 
973
#    set y [list 1 2 3 4]
 
974
#    listbox $_lb
 
975
#    $_lb configure -listvar x
 
976
#    $_lb configure -listvar y
 
977
#    $_lb insert end 5 6 7 8
 
978
#    list $x $y
 
979
#} [list [list a b c d] [list 1 2 3 4 5 6 7 8]]
 
980
#test listbox-4.13 {ConfigureListbox, no listvar -> non-existant listvar} {
 
981
#    catch {destroy $_lb}
 
982
#    catch {unset x}
 
983
#    listbox $_lb
 
984
#    $_lb insert end a b c d
 
985
#    $_lb configure -listvar x
 
986
#    set x
 
987
#} [list a b c d]
 
988
#test listbox-4.14 {ConfigureListbox, non-existant listvar} {
 
989
#    catch {destroy $_lb}
 
990
#    catch {unset x}
 
991
#    listbox $_lb -listvar x
 
992
#    list [info exists x] $x
 
993
#} [list 1 {}]
 
994
#test listbox-4.15 {ConfigureListbox, listvar -> non-existant listvar} {
 
995
#    catch {destroy $_lb}
 
996
#    catch {unset y}
 
997
#    set x [list a b c d]
 
998
#    listbox $_lb -listvar x
 
999
#    $_lb configure -listvar y
 
1000
#    list [info exists y] $y
 
1001
#} [list 1 [list a b c d]]
 
1002
#test listbox-4.16 {ConfigureListbox, listvar -> same listvar} {
 
1003
#    catch {destroy $_lb}
 
1004
#    set x [list a b c d]
 
1005
#    listbox $_lb -listvar x
 
1006
#    $_lb configure -listvar x
 
1007
#    set x
 
1008
#} [list a b c d]
 
1009
#test listbox-4.17 {ConfigureListbox, no listvar -> no listvar} {
 
1010
#    catch {destroy $_lb}
 
1011
#    listbox $_lb
 
1012
#    $_lb insert end a b c d
 
1013
#    $_lb configure -listvar {}
 
1014
#    $_lb get 0 end
 
1015
#} [list a b c d]
 
1016
#test listbox-4.18 {ConfigureListbox, no listvar -> bad listvar} {
 
1017
#    catch {destroy $_lb}
 
1018
#    listbox $_lb
 
1019
#    $_lb insert end a b c d
 
1020
#    set x {this is a " bad list}
 
1021
#    catch {$_lb configure -listvar x} result
 
1022
#    list [$_lb get 0 end] [$_lb cget -listvar] $result
 
1023
#} [list [list a b c d] {} \
 
1024
#       "unmatched open quote in list: invalid listvar value"]
 
1025
 
 
1026
# No tests for DisplayListbox:  I don't know how to test this procedure.
 
1027
 
 
1028
Tk::catch { $lb->destroy if Tk::Exists($lb) };
 
1029
$lb = $mw->$Listbox(-font => $fixed, -width => 15, -height => 20)->pack;
 
1030
ok($lb->reqwidth, 115);
 
1031
ok($lb->reqheight, 328);
 
1032
 
 
1033
eval { $lb->destroy };
 
1034
$lb = $mw->$Listbox(-font => $fixed, -width => 0, -height => 10)->pack;
 
1035
$lb->update;
 
1036
ok($lb->reqwidth, 17);
 
1037
ok($lb->reqheight, 168);
 
1038
 
 
1039
eval { $lb->destroy };
 
1040
$lb = $mw->$Listbox(-font => $fixed, -width => 0, -height => 10,
 
1041
                   -bd => 3)->pack;
 
1042
$lb->insert(0, "Short", "Really much longer", "Longer");
 
1043
$lb->update;
 
1044
ok($lb->reqwidth, 138);
 
1045
ok($lb->reqheight, 170);
 
1046
 
 
1047
eval { $lb->destroy };
 
1048
$lb = $mw->$Listbox(-font => $fixed, -width => 10, -height => 0,
 
1049
                  )->pack;
 
1050
$lb->update;
 
1051
ok($lb->reqwidth, 80);
 
1052
ok($lb->reqheight, 24);
 
1053
 
 
1054
eval { $lb->destroy };
 
1055
$lb = $mw->$Listbox(-font => $fixed, -width => 10, -height => 0,
 
1056
                   -highlightthickness => 0)->pack;
 
1057
$lb->insert(0, "Short", "Really much longer", "Longer");
 
1058
$lb->update;
 
1059
ok($lb->reqwidth, 76);
 
1060
ok($lb->reqheight, 52);
 
1061
 
 
1062
eval { $lb->destroy };
 
1063
# If "0" in selected font had 0 width, caused divide-by-zero error.
 
1064
$lb = $mw->$Listbox(-font => '{open look glyph}')->pack;
 
1065
$lb->update;
 
1066
 
 
1067
eval { $lb->destroy };
 
1068
$lb = $mw->$Listbox(-height => 2,
 
1069
                   -xscrollcommand => sub { record("x", @_) },
 
1070
                   -yscrollcommand => sub { record("y", @_) })->pack;
 
1071
$lb->update;
 
1072
 
 
1073
$lb->delete(0, "end");
 
1074
$lb->insert(qw/end a b c d/);
 
1075
$lb->insert(qw/5 x y z/);
 
1076
$lb->insert(qw/2 A/);
 
1077
$lb->insert(qw/0 q r s/);
 
1078
ok(join(" ",$lb->get(qw/0 end/)), 'q r s a b A c d x y z');
 
1079
 
 
1080
$lb->delete(qw/0 end/);
 
1081
$lb->insert(qw/0 a b c d e f g h i j/);
 
1082
$lb->selection(qw/anchor 2/);
 
1083
$lb->insert(qw/2 A B/);
 
1084
ok($lb->index(qw/anchor/), 4);
 
1085
 
 
1086
$lb->delete(qw/0 end/);
 
1087
$lb->insert(qw/0 a b c d e f g h i j/);
 
1088
$lb->selection(qw/anchor 2/);
 
1089
$lb->insert(qw/3 A B/);
 
1090
ok($lb->index(qw/anchor/), 2);
 
1091
 
 
1092
$lb->delete(qw/0 end/);
 
1093
$lb->insert(qw/0 a b c d e f g h i j/);
 
1094
$lb->yview(qw/3/);
 
1095
$lb->update;
 
1096
$lb->insert(qw/2 A B/);
 
1097
ok($lb->index(q/@0,0/), 5);
 
1098
 
 
1099
$lb->delete(qw/0 end/);
 
1100
$lb->insert(qw/0 a b c d e f g h i j/);
 
1101
$lb->yview(qw/3/);
 
1102
$lb->update;
 
1103
$lb->insert(qw/3 A B/);
 
1104
ok($lb->index(q/@0,0/), 3);
 
1105
 
 
1106
$lb->delete(qw/0 end/);
 
1107
$lb->insert(qw/0 a b c d e f g h i j/);
 
1108
$lb->activate(qw/5/);
 
1109
$lb->insert(qw/5 A B/);
 
1110
ok($lb->index(qw/active/), 7);
 
1111
 
 
1112
$lb->delete(qw/0 end/);
 
1113
$lb->insert(qw/0 a b c d e f g h i j/);
 
1114
$lb->activate(qw/5/);
 
1115
$lb->insert(qw/6 A B/);
 
1116
ok($lb->index(qw/active/), 5);
 
1117
 
 
1118
$lb->delete(qw/0 end/);
 
1119
$lb->insert(qw/0 a b c/);
 
1120
ok($lb->index(qw/active/), 2);
 
1121
 
 
1122
$lb->delete(qw/0 end/);
 
1123
$lb->insert(qw/0/);
 
1124
ok($lb->index(qw/active/), 0);
 
1125
 
 
1126
$lb->delete(qw/0 end/);
 
1127
$lb->insert(qw/0 a b/, "two words", qw/c d e f g h i j/);
 
1128
$lb->update;
 
1129
@log = ();
 
1130
$lb->insert(qw/0 word/);
 
1131
$lb->update;
 
1132
print "# @log\n";
 
1133
ok("@log" =~ /^y 0 0\.083333/);
 
1134
 
 
1135
$lb->delete(qw/0 end/);
 
1136
$lb->insert(qw/0 a b/, "two words", qw/c d e f g h i j/);
 
1137
$lb->update;
 
1138
@log = ();
 
1139
$lb->insert(0, "much longer entry");
 
1140
$lb->update;
 
1141
print "# @log\n";
 
1142
ok("$log[0]" =~ /^y 0 0\.083333/);
 
1143
ok("$log[1]", "x 0 1");
 
1144
 
 
1145
{
 
1146
    my $l2 = $mw->$Listbox(-width => 0, -height => 0)->pack(-side => "top");
 
1147
    $l2->insert(0, "a", "b", "two words", "c", "d");
 
1148
    ok($l2->reqwidth, 80);
 
1149
    ok($l2->reqheight, 93);
 
1150
    $l2->insert(0, "much longer entry");
 
1151
    ok($l2->reqwidth, 122);
 
1152
    ok($l2->reqheight, 110);
 
1153
    $l2->destroy;
 
1154
}
 
1155
 
 
1156
{
 
1157
      my @x = qw(a b c d);
 
1158
    ## -listvar XXX
 
1159
#      my $l2 = $mw->$Listbox(-listvar => \@x);
 
1160
#      $l2->insert(0, 1 .. 4);
 
1161
#      ok(join(" ", @x), "1 2 3 4 a b c d");
 
1162
#      ok(scalar @x, 8);
 
1163
#      ok($x[0], 1);
 
1164
#      ok($x[-1], "d");
 
1165
#      $l2->destroy;
 
1166
}
 
1167
 
 
1168
{
 
1169
    my $l2 = $mw->$Listbox;
 
1170
    $l2->insert(0, 0 .. 4);
 
1171
    $l2->selection("set", 2, 4);
 
1172
    $l2->insert(0, "a");
 
1173
    ok("@{[ $l2->curselection ]}", "3 4 5");
 
1174
    ok(scalar @{[ $l2->curselection ]}, 3);
 
1175
    $l2->destroy;
 
1176
}
 
1177
 
 
1178
$lb->delete(0, "end");
 
1179
$lb->insert(0, qw/a b c d e f g h i j/);
 
1180
$lb->selectionSet(1, 6);
 
1181
$lb->delete(4, 3);
 
1182
ok($lb->size, 10);
 
1183
ok($mw->SelectionGet, "b
 
1184
c
 
1185
d
 
1186
e
 
1187
f
 
1188
g");
 
1189
 
 
1190
$lb->delete(qw/0 end/);
 
1191
$lb->insert(qw/0 a b c d e f g h i j/);
 
1192
$lb->selection(qw/set 3 6/);
 
1193
$lb->delete(qw/4 4/);
 
1194
ok($lb->size, 9);
 
1195
ok($lb->get(4), "f");
 
1196
ok("@{[ $lb->curselection ]}", "3 4 5");
 
1197
ok(scalar @{[ $lb->curselection ]}, 3);
 
1198
ok(($lb->curselection)[0], 3);
 
1199
ok(($lb->curselection)[-1], 5);
 
1200
 
 
1201
$lb->delete(qw/0 end/);
 
1202
$lb->insert(qw/0 a b c d e f g h i j/);
 
1203
$lb->delete(qw/0 3/);
 
1204
ok($lb->size, 6);
 
1205
ok($lb->get(0), "e");
 
1206
ok($lb->get(1), "f");
 
1207
 
 
1208
$lb->delete(qw/0 end/);
 
1209
$lb->insert(qw/0 a b c d e f g h i j/);
 
1210
$lb->delete(qw/8 1000/);
 
1211
ok($lb->size, 8);
 
1212
ok($lb->get(7), "h");
 
1213
 
 
1214
$lb-> delete(0, qw/end/);
 
1215
$lb->insert(qw/0 a b c d e f g h i j/);
 
1216
$lb->selection(qw/anchor 2/);
 
1217
$lb->delete(qw/0 1/);
 
1218
ok($lb->index(qw/anchor/), 0);
 
1219
 
 
1220
$lb->delete(qw/0 end/);
 
1221
$lb->insert(qw/0 a b c d e f g h i j/);
 
1222
$lb->selection(qw/anchor 2/);
 
1223
$lb->delete(qw/2/);
 
1224
ok($lb->index(qw/anchor/), 2);
 
1225
 
 
1226
$lb->delete(qw/0 end/);
 
1227
$lb->insert(qw/0 a b c d e f g h i j/);
 
1228
$lb->selection(qw/anchor 4/);
 
1229
$lb->delete(qw/2 5/);
 
1230
ok($lb->index(qw/anchor/), 2);
 
1231
 
 
1232
$lb->delete(qw/0 end/);
 
1233
$lb->insert(qw/0 a b c d e f g h i j/);
 
1234
$lb->selection(qw/anchor 3/);
 
1235
$lb->delete(qw/4 5/);
 
1236
ok($lb->index(qw/anchor/), 3);
 
1237
 
 
1238
$lb->delete(qw/0 end/);
 
1239
$lb->insert(qw/0 a b c d e f g h i j/);
 
1240
$lb->yview(qw/3/);
 
1241
$lb->update;
 
1242
$lb->delete(qw/1 2/);
 
1243
ok($lb->index(q/@0,0/), 1);
 
1244
 
 
1245
$lb->delete(qw/0 end/);
 
1246
$lb->insert(qw/0 a b c d e f g h i j/);
 
1247
$lb->yview(qw/3/);
 
1248
$lb->update;
 
1249
$lb->delete(qw/3 4/);
 
1250
ok($lb->index(q/@0,0/), 3);
 
1251
 
 
1252
$lb->delete(qw/0 end/);
 
1253
$lb->insert(qw/0 a b c d e f g h i j/);
 
1254
$lb->yview(qw/3/);
 
1255
$lb->update;
 
1256
$lb->delete(qw/4 6/);
 
1257
ok($lb->index(q/@0,0/), 3);
 
1258
 
 
1259
$lb->delete(qw/0 end/);
 
1260
$lb->insert(qw/0 a b c d e f g h i j/);
 
1261
$lb->yview(qw/3/);
 
1262
$lb->update;
 
1263
$lb->delete(qw/3 end/);
 
1264
ok($lb->index(q/@0,0/), 2);
 
1265
 
 
1266
mkPartial();
 
1267
$partial_lb->yview(8);
 
1268
$mw->update;
 
1269
$partial_lb->delete(10, 13);
 
1270
ok($partial_lb->index('@0,0'), 7);
 
1271
 
 
1272
$lb->delete(qw/0 end/);
 
1273
$lb->insert(qw/0 a b c d e f g h i j/);
 
1274
$lb->activate(qw/6/);
 
1275
$lb->delete(qw/3 4/);
 
1276
ok($lb->index(qw/active/), 4);
 
1277
 
 
1278
$lb->delete(qw/0 end/);
 
1279
$lb->insert(qw/0 a b c d e f g h i j/);
 
1280
$lb->activate(qw/6/);
 
1281
$lb->delete(qw/5 7/);
 
1282
ok($lb->index(qw/active/), 5);
 
1283
 
 
1284
$lb->delete(qw/0 end/);
 
1285
$lb->insert(qw/0 a b c d e f g h i j/);
 
1286
$lb->activate(qw/6/);
 
1287
$lb->delete(qw/5 end/);
 
1288
ok($lb->index(qw/active/), 4);
 
1289
 
 
1290
$lb->delete(qw/0 end/);
 
1291
$lb->insert(qw/0 a b c d e f g h i j/);
 
1292
$lb->activate(qw/6/);
 
1293
$lb->delete(qw/0 end/);
 
1294
ok($lb->index(qw/active/), 0);
 
1295
 
 
1296
$lb->delete(qw/0 end/);
 
1297
$lb->insert(qw/0 a b c/, "two words", qw/d e f g h i j/);
 
1298
$lb->update;
 
1299
@log = ();
 
1300
$lb->delete(qw/4 6/);
 
1301
$lb->update;
 
1302
ok($log[0], "y 0 0.125");
 
1303
 
 
1304
$lb->delete(qw/0 end/);
 
1305
$lb->insert(qw/0 a b c/, "two words", qw/d e f g h i j/);
 
1306
$lb->update;
 
1307
@log = ();
 
1308
$lb->delete(qw/3/);
 
1309
$lb->update;
 
1310
ok($log[0], "y 0 0.1");
 
1311
ok($log[1], "x 0 1");
 
1312
 
 
1313
{
 
1314
    my $l2 = $mw->$Listbox(-width => 0, -height => 0)->pack(-side => "top");
 
1315
    $l2->insert(0, "a", "b", "two words", qw/c d e f g/);
 
1316
    ok($l2->reqwidth, 80);
 
1317
    ok($l2->reqheight, 144);
 
1318
    $l2->delete(2, 4);
 
1319
    ok($l2->reqwidth, 17);
 
1320
    ok($l2->reqheight, 93);
 
1321
    $l2->destroy;
 
1322
}
 
1323
 
 
1324
## -listvar
 
1325
#  catch {destroy .l2}
 
1326
#  test listbox-7.21 {DeleteEls procedure, check -listvar update} {
 
1327
#      catch {destroy .l2}
 
1328
#      set x [list a b c d]
 
1329
#      listbox .l2 -listvar x
 
1330
#      .l2 delete 0 1
 
1331
#      set x
 
1332
#  } [list c d]
 
1333
 
 
1334
$lb->destroy;
 
1335
$lb = $mw->$Listbox(-setgrid => 1)->pack;
 
1336
$lb->update;
 
1337
ok(getsize($mw), "20x10");
 
1338
$lb->destroy;
 
1339
ok(getsize($mw), "150x178");
 
1340
ok(Tk::Exists($lb), 0);
 
1341
 
 
1342
resetGridInfo();
 
1343
 
 
1344
$lb = $mw->$Listbox(-height => 5, -width => 10);
 
1345
$lb->insert(qw/0 a b c/, "A string that is very very long",
 
1346
            qw/ d e f g h i j k/);
 
1347
$lb->pack;
 
1348
$lb->update;
 
1349
$lb->place(qw/-width 50 -height 80/);
 
1350
$lb->update;
 
1351
ok(join(" ", $lb->xview) =~ /^0 0\.2222/);
 
1352
ok(join(" ", $lb->yview) =~ /^0 0\.3333/);
 
1353
 
 
1354
map { $_->destroy } $mw->children;
 
1355
my $l1 = $mw->$Listbox(-bg => "#543210");
 
1356
my $l2 = $l1;
 
1357
ok(join(",", map { $_->PathName } $mw->children) =~ /^\.listbox\d*$/, 1);
 
1358
ok($l2->cget(-bg), "#543210");
 
1359
$l2->destroy;
 
1360
 
 
1361
my $top = $mw->Toplevel;
 
1362
$top->geometry("+0+0");
 
1363
my $top_lb = $top->$Listbox(-setgrid => 1,
 
1364
                           -width => 20,
 
1365
                           -height => 10)->pack;
 
1366
$top_lb->update;
 
1367
ok($top->geometry, "20x10+0+0");
 
1368
$top_lb->destroy;
 
1369
ok($top->geometry, "150x178+0+0");
 
1370
 
 
1371
$lb = $mw->$Listbox->pack;
 
1372
$lb->delete(0, "end");
 
1373
$lb->insert(qw/0 el0 el1 el2 el3 el4 el5 el6 el7 el8 el9 el10 el11/);
 
1374
$lb->activate(3);
 
1375
ok($lb->index("active"), 3);
 
1376
$lb->activate(6);
 
1377
ok($lb->index("active"), 6);
 
1378
 
 
1379
$lb->selection(qw/anchor 2/);
 
1380
ok($lb->index(qw/anchor/), 2);
 
1381
 
 
1382
$lb->insert(qw/end A B C D E/);
 
1383
$lb->selection(qw/anchor end/);
 
1384
$lb->delete(qw/12 end/);
 
1385
ok($lb->index("anchor"), 12);
 
1386
ok($lb->index("end"), 12);
 
1387
 
 
1388
eval { $lb->index("a") };
 
1389
ok($@ =~ /bad listbox index \"a\": must be active, anchor, end, \@x,y, or a number/, 1, "wrong error message $@");
 
1390
 
 
1391
eval { $lb->index("\@") };
 
1392
ok($@ =~ /bad listbox index \"\@\": must be active, anchor, end, \@x,y, or a number/, 1, "wrong error message $@");
 
1393
 
 
1394
eval { $lb->index("\@foo") };
 
1395
ok($@ =~ /bad listbox index \"\@foo\": must be active, anchor, end, \@x,y, or a number/, 1, "wrong error message $@");
 
1396
 
 
1397
eval { $lb->index("\@1x3") };
 
1398
ok($@ =~ /bad listbox index \"\@1x3\": must be active, anchor, end, \@x,y, or a number/, 1, "wrong error message $@");
 
1399
 
 
1400
eval { $lb->index("\@1,") };
 
1401
ok($@ =~ /bad listbox index \"\@1,\": must be active, anchor, end, \@x,y, or a number/, 1, "wrong error message $@");
 
1402
 
 
1403
eval { $lb->index("\@1,foo") };
 
1404
ok($@ =~ /bad listbox index \"\@1,foo\": must be active, anchor, end, \@x,y, or a number/, 1, "wrong error message $@");
 
1405
 
 
1406
eval { $lb->index("\@1,2x") };
 
1407
ok($@ =~ /bad listbox index \"\@1,2x\": must be active, anchor, end, \@x,y, or a number/, 1, "wrong error message $@");
 
1408
 
 
1409
eval { $lb->index("1xy") };
 
1410
ok($@ =~ /bad listbox index \"1xy\": must be active, anchor, end, \@x,y, or a number/, 1, "wrong error message $@");
 
1411
 
 
1412
ok($lb->index("end"), 12);
 
1413
 
 
1414
ok($lb->get(qw/end/), "el11");
 
1415
 
 
1416
$lb->delete(qw/0 end/);
 
1417
ok($lb->index(qw/end/), 0);
 
1418
 
 
1419
$lb->delete(qw/0 end/);
 
1420
$lb->insert(qw/0 el0 el1 el2 el3 el4 el5 el6 el7 el8 el9 el10 el11/);
 
1421
$lb->update;
 
1422
 
 
1423
ok($lb->index(q/@5,57/), 3);
 
1424
ok($lb->index(q/@5,58/), 3);
 
1425
 
 
1426
ok($lb->index(qw/3/), 3);
 
1427
ok($lb->index(qw/20/), 20);
 
1428
 
 
1429
ok($lb->get(qw/20/), undef);
 
1430
 
 
1431
ok($lb->index(qw/-2/), -2);
 
1432
 
 
1433
$lb->delete(qw/0 end/);
 
1434
ok($lb->index(qw/1/), 1);
 
1435
 
 
1436
$lb->destroy;
 
1437
$lb = $mw->$Listbox(-height => 5)->pack;
 
1438
$lb->insert(qw/0 a b c d e f g h i j/);
 
1439
$lb->yview(qw/3/);
 
1440
$lb->update;
 
1441
ok($lb->index(q/@0,0/), 3);
 
1442
$lb->yview(qw/-1/);
 
1443
$lb->update;
 
1444
ok($lb->index(q/@0,0/), 0);
 
1445
 
 
1446
$lb->destroy;
 
1447
$lb = $mw->$Listbox(qw/-height 5/)->pack;
 
1448
$lb->insert(qw/0 a b c d e f g h i j/);
 
1449
$lb->yview(qw/3/);
 
1450
$lb->update;
 
1451
ok($lb->index(q/@0,0/), 3);
 
1452
$lb->yview(qw/20/);
 
1453
$lb->update;
 
1454
ok($lb->index(q/@0,0/), 5);
 
1455
 
 
1456
$lb->destroy;
 
1457
$lb = $mw->$Listbox(qw/-height 5 -yscrollcommand/, [qw/record y/])->pack;
 
1458
$lb->insert(qw/0 a b c d e f g h i j/);
 
1459
$lb->update;
 
1460
@log = ();
 
1461
$lb->yview(qw/2/);
 
1462
$lb->update;
 
1463
ok("@{[ $lb->yview ]}", "0.2 0.7");
 
1464
ok($log[0], "y 0.2 0.7");
 
1465
 
 
1466
$lb->destroy;
 
1467
$lb = $mw->$Listbox(qw/-height 5 -yscrollcommand/, [qw/record y/])->pack;
 
1468
$lb->insert(qw/0 a b c d e f g h i j/);
 
1469
$lb->update;
 
1470
@log = ();
 
1471
$lb->yview(qw/8/);
 
1472
$lb->update;
 
1473
ok("@{[ $lb->yview ]}", "0.5 1");
 
1474
ok($log[0], "y 0.5 1");
 
1475
 
 
1476
$lb->destroy;
 
1477
$lb = $mw->$Listbox(qw/-height 5 -yscrollcommand/, [qw/record y/])->pack;
 
1478
$lb->insert(qw/0 a b c d e f g h i j/);
 
1479
$lb->yview(qw/3/);
 
1480
$lb->update;
 
1481
@log = ();
 
1482
$lb->yview(qw/3/);
 
1483
$lb->update;
 
1484
ok("@{[ $lb->yview ]}", "0.3 0.8");
 
1485
ok(scalar @log, 0);
 
1486
 
 
1487
mkPartial();
 
1488
$partial_lb->yview(13);
 
1489
ok($partial_lb->index('@0,0'), 11);
 
1490
 
 
1491
$lb->destroy;
 
1492
$lb = $mw->$Listbox(-font => $fixed,
 
1493
                   -xscrollcommand => ["record", "x"],
 
1494
                   -width => 10);
 
1495
$lb->insert(qw/0 0123456789a123456789b123456789c123456789d123456789e123456789f123456789g123456789h123456789i123456789/);
 
1496
$lb->pack;
 
1497
$lb->update;
 
1498
 
 
1499
@log = ();
 
1500
$lb->xview(qw/99/);
 
1501
$lb->update;
 
1502
ok("@{[ $lb->xview ]}", "0.9 1");
 
1503
ok(($lb->xview)[0], 0.9);
 
1504
ok(($lb->xview)[1], 1);
 
1505
ok($log[0], "x 0.9 1");
 
1506
 
 
1507
@log = ();
 
1508
$lb->xview(qw/moveto -.25/);
 
1509
$lb->update;
 
1510
ok("@{[ $lb->xview ]}", "0 0.1");
 
1511
ok($log[0], "x 0 0.1");
 
1512
 
 
1513
$lb->xview(qw/10/);
 
1514
$lb->update;
 
1515
@log = ();
 
1516
$lb->xview(qw/10/);
 
1517
$lb->update;
 
1518
ok("@{[ $lb->xview ]}", "0.1 0.2");
 
1519
ok(scalar @log, 0);
 
1520
 
 
1521
$lb->destroy;
 
1522
$lb = $mw->$Listbox(-font => $fixed, -width => 10, -height => 5)->pack;
 
1523
$lb->insert(qw/0 a bb c d e f g h i j k l m n o p q r s/);
 
1524
$lb->insert(qw/0 0123456789a123456789b123456789c123456789d123456789/);
 
1525
$lb->update;
 
1526
my $width  = ($lb->bbox(2))[2] - ($lb->bbox(1))[2];
 
1527
my $height = ($lb->bbox(2))[1] - ($lb->bbox(1))[1];
 
1528
 
 
1529
$lb->yview(qw/0/);
 
1530
$lb->xview(qw/0/);
 
1531
$lb->scan(qw/mark 10 20/);
 
1532
$lb->scan(qw/dragto/, 10-$width, 20-$height);
 
1533
$lb->update;
 
1534
ok("@{[ $lb->xview ]}", "0.2 0.4");
 
1535
ok("@{[ $lb->yview ]}", "0.5 0.75");
 
1536
 
 
1537
$lb->yview(qw/5/);
 
1538
$lb->xview(qw/10/);
 
1539
$lb->scan(qw/mark 10 20/);
 
1540
$lb->scan(qw/dragto 20 40/);
 
1541
$lb->update;
 
1542
ok("@{[ $lb->xview ]}", "0 0.2");
 
1543
ok("@{[ $lb->yview ]}", "0 0.25");
 
1544
 
 
1545
$lb->scan(qw/dragto/, 20-$width, 40-$height);
 
1546
$lb->update;
 
1547
ok("@{[ $lb->xview ]}", "0.2 0.4");
 
1548
ok("@{[ $lb->yview ]}", "0.5 0.75");
 
1549
 
 
1550
$lb->yview(qw/moveto 1.0/);
 
1551
$lb->xview(qw/moveto 1.0/);
 
1552
$lb->scan(qw/mark 10 20/);
 
1553
$lb->scan(qw/dragto 5 10/);
 
1554
$lb->update;
 
1555
ok("@{[ $lb->xview ]}", "0.8 1");
 
1556
ok("@{[ $lb->yview ]}", "0.75 1");
 
1557
$lb->scan(qw/dragto/, 5+$width, 10+$height);
 
1558
$lb->update;
 
1559
ok("@{[ $lb->xview ]}", "0.62 0.82");
 
1560
ok("@{[ $lb->yview ]}", "0.25 0.5");
 
1561
 
 
1562
mkPartial();
 
1563
ok($partial_lb->nearest($partial_lb->height), 4);
 
1564
 
 
1565
$lb->destroy;
 
1566
$lb = $mw->$Listbox(-font => $fixed,
 
1567
                   -width => 20,
 
1568
                   -height => 10);
 
1569
$lb->insert(qw/0 a b c d e f g h i j k l m n o p q r s t/);
 
1570
$lb->yview(qw/4/);
 
1571
$lb->pack;
 
1572
$lb->update;
 
1573
 
 
1574
ok($lb->index(q/@50,0/), 4);
 
1575
 
 
1576
ok($lb->index(q/@50,35/), 5);
 
1577
ok($lb->index(q/@50,36/), 6);
 
1578
 
 
1579
ok($lb->index(q/@50,200/), 13);
 
1580
 
 
1581
$lb->delete(qw/0 end/);
 
1582
$lb->insert(qw/0 a b c d e f g h i j k l m n o p/);
 
1583
$lb->selection(qw/set 2 4/);
 
1584
$lb->selection(qw/set 7 12/);
 
1585
$lb->selection(qw/clear 4 7/);
 
1586
ok("@{[ $lb->curselection ]}", "2 3 8 9 10 11 12");
 
1587
 
 
1588
$lb->delete(qw/0 end/);
 
1589
$lb->insert(qw/0 a b c d e f g h i j k l m n o p/);
 
1590
 
 
1591
$e = $mw->Entry;
 
1592
$e->insert(0, "This is some text");
 
1593
$e->selection(qw/from 0/);
 
1594
$e->selection(qw/to 7/);
 
1595
$lb->selection(qw/clear 2 4/);
 
1596
ok($mw->SelectionOwner, $e);
 
1597
$lb->selection(qw/set 3/);
 
1598
ok($mw->SelectionOwner, $lb);
 
1599
ok($mw->SelectionGet, "d");
 
1600
 
 
1601
$lb->delete(qw/0 end/);
 
1602
$lb->selection(qw/clear 0 end/);
 
1603
$lb->selection(qw/set 0 end/);
 
1604
ok($lb->curselection, ());
 
1605
 
 
1606
$lb->delete(qw/0 end/);
 
1607
$lb->insert(qw/0 a b c d e f/);
 
1608
$lb->selection(qw/clear 0 end/);
 
1609
$lb->selection(qw/set -2 -1/);
 
1610
ok($lb->curselection, ());
 
1611
 
 
1612
$lb->delete(qw/0 end/);
 
1613
$lb->insert(qw/0 a b c d e f/);
 
1614
$lb->selection(qw/clear 0 end/);
 
1615
$lb->selection(qw/set -1 3/);
 
1616
ok(join(",",$lb->curselection), "0,1,2,3");
 
1617
 
 
1618
$lb->delete(qw/0 end/);
 
1619
$lb->insert(qw/0 a b c d e f/);
 
1620
$lb->selection(qw/clear 0 end/);
 
1621
$lb->selection(qw/set 2 4/);
 
1622
ok(join(" ", $lb->curselection), "2 3 4");
 
1623
 
 
1624
$lb->delete(qw/0 end/);
 
1625
$lb->insert(qw/0 a b c d e f/);
 
1626
$lb->selection(qw/clear 0 end/);
 
1627
$lb->selection(qw/set 4 end/);
 
1628
ok(join(" ", $lb->curselection), "4 5");
 
1629
 
 
1630
$lb->delete(qw/0 end/);
 
1631
$lb->insert(qw/0 a b c d e f/);
 
1632
$lb->selection(qw/clear 0 end/);
 
1633
$lb->selection(qw/set 4 30/);
 
1634
ok(join(",", $lb->curselection), "4,5");
 
1635
 
 
1636
$lb->delete(qw/0 end/);
 
1637
$lb->insert(qw/0 a b c d e f/);
 
1638
$lb->selection(qw/clear 0 end/);
 
1639
$lb->selection(qw/set end 30/);
 
1640
ok(join(",", $lb->curselection), 5);
 
1641
ok(scalar @{[ $lb->curselection ]}, 1);
 
1642
 
 
1643
$lb->delete(qw/0 end/);
 
1644
$lb->insert(qw/0 a b c d e f/);
 
1645
$lb->selection(qw/clear 0 end/);
 
1646
$lb->selection(qw/set 20 25/);
 
1647
ok($lb->curselection, ());
 
1648
 
 
1649
$lb->delete(qw/0 end/);
 
1650
$lb->insert(qw/0 a b c/, "two words", qw/ e f g h i \ k l m n o p/);
 
1651
$lb->selection(qw/set 2 4/);
 
1652
$lb->selection(qw/set 9/);
 
1653
$lb->selection(qw/set 11 12/);
 
1654
ok($mw->SelectionGet, "c\ntwo words\ne\n\\\nl\nm");
 
1655
 
 
1656
$lb->delete(qw/0 end/);
 
1657
$lb->insert(qw/0 a b c/, "two words", qw/ e f g h i \ k l m n o p/);
 
1658
$lb->selection(qw/set 3/);
 
1659
ok($mw->SelectionGet, "two words");
 
1660
 
 
1661
my $long = "This is quite a long string\n" x 11;
 
1662
$lb->delete(qw/0 end/);
 
1663
$lb->insert(0, "1$long", "2$long", "3$long", "4$long", "5$long");
 
1664
$lb->selection(qw/set 0 end/);
 
1665
ok($mw->SelectionGet, "1$long\n2$long\n3$long\n4$long\n5$long");
 
1666
 
 
1667
$lb->delete(qw/0 end/);
 
1668
$lb->insert(qw/0 a b c d e/);
 
1669
$lb->selection(qw/set 0 end/);
 
1670
$e->destroy;
 
1671
$e = $mw->Entry;
 
1672
$e->insert(0, "This is some text");
 
1673
$e->selection(qw/from 0/);
 
1674
$e->selection(qw/to 5/);
 
1675
ok($lb->curselection, ());
 
1676
 
 
1677
$lb->delete(qw/0 end/);
 
1678
$lb->insert(qw/0 a b c d e/);
 
1679
$lb->selection(qw/set 0 end/);
 
1680
$lb->configure(qw/-exportselection 0/);
 
1681
$e->destroy;
 
1682
$e = $top->Entry;
 
1683
$e->insert(0, "This is some text");
 
1684
$e->selection(qw/from 0/);
 
1685
$e->selection(qw/to 5/);
 
1686
ok(join(" ", $lb->curselection), "0 1 2 3 4");
 
1687
 
 
1688
$lb->destroy;
 
1689
$lb = $mw->$Listbox(-font => $fixed, -width => 10, -height => 5);
 
1690
$lb->pack;
 
1691
$lb->update;
 
1692
 
 
1693
$lb->configure(qw/-yscrollcommand/, [qw/record y/]);
 
1694
@log = ();
 
1695
$lb->insert(qw/0 a b c/);
 
1696
$lb->update;
 
1697
$lb->insert(qw/end d e f g h/);
 
1698
$lb->update;
 
1699
$lb->delete(qw/0 end/);
 
1700
$lb->update;
 
1701
ok($log[0], "y 0 1");
 
1702
ok($log[1], "y 0 0.625");
 
1703
ok($log[2], "y 0 1");
 
1704
 
 
1705
mkPartial();
 
1706
$partial_lb->configure(-yscrollcommand => ["record", "y"]);
 
1707
@log = ();
 
1708
$partial_lb->yview(3);
 
1709
$partial_lb->update;
 
1710
ok($log[0] =~ /^y 0\.2 0\.46666/);
 
1711
 
 
1712
@x = ();
 
1713
 
 
1714
sub Tk::Error {
 
1715
    push @x, @_;
 
1716
}
 
1717
 
 
1718
# XXX dumps core with 5.7.0 and 803.023
 
1719
$lb->configure(qw/-yscrollcommand gorp/);
 
1720
$lb->insert(qw/0 foo/);
 
1721
$lb->update;
 
1722
ok("@x" =~ /Undefined subroutine &main::gorp called.*vertical scrolling command executed by listbox/s, 1, "x is @x");
 
1723
 
 
1724
$lb->destroy;
 
1725
$lb = $mw->$Listbox(-font => $fixed, qw/-width 10 -height 5/)->pack;
 
1726
$lb->update;
 
1727
 
 
1728
$lb->configure(qw/-xscrollcommand/, ["record", "x"]);
 
1729
@log = ();
 
1730
$lb->insert(qw/0 abc/);
 
1731
$lb->update;
 
1732
$lb->insert(qw/0/, "This is a much longer string...");
 
1733
$lb->update;
 
1734
$lb->delete(qw/0 end/);
 
1735
$lb->update;
 
1736
ok($log[0], "x 0 1");
 
1737
ok($log[1] =~ /^x 0 0\.32258/, 1, "expected: x 0 0.32258 in $log[1]");
 
1738
ok($log[2], "x 0 1");
 
1739
 
 
1740
@x = ();
 
1741
$lb->configure(qw/-xscrollcommand bogus/);
 
1742
$lb->insert(qw/0 foo/);
 
1743
$lb->update;
 
1744
ok("@x" =~ /Undefined subroutine &main::bogus.*horizontal scrolling command executed by listbox/s, 1, "x is @x");
 
1745
 
 
1746
foreach ($mw->children) { $_->destroy }
 
1747
 
 
1748
## XXX not yet
 
1749
#  # tests for ListboxListVarProc
 
1750
#  test listbox-21.1 {ListboxListVarProc} {
 
1751
#      catch {destroy $_lb}
 
1752
#      catch {unset x}
 
1753
#      listbox $_lb -listvar x
 
1754
#      set x [list a b c d]
 
1755
#      $_lb get 0 end
 
1756
#  } [list a b c d]
 
1757
#  test listbox-21.2 {ListboxListVarProc} {
 
1758
#      catch {destroy $_lb}
 
1759
#      set x [list a b c d]
 
1760
#      listbox $_lb -listvar x
 
1761
#      unset x
 
1762
#      set x
 
1763
#  } [list a b c d]
 
1764
#  test listbox-21.3 {ListboxListVarProc} {
 
1765
#      catch {destroy $_lb}
 
1766
#      set x [list a b c d]
 
1767
#      listbox $_lb -listvar x
 
1768
#      $_lb configure -listvar {}
 
1769
#      unset x
 
1770
#      info exists x
 
1771
#  } 0
 
1772
#  test listbox-21.4 {ListboxListVarProc} {
 
1773
#      catch {destroy $_lb}
 
1774
#      set x [list a b c d]
 
1775
#      listbox $_lb -listvar x
 
1776
#      lappend x e f g
 
1777
#      $_lb size
 
1778
#  } 7
 
1779
#  test listbox-21.5 {ListboxListVarProc, test selection after listvar mod} {
 
1780
#      catch {destroy $_lb}
 
1781
#      set x [list a b c d e f g]
 
1782
#      listbox $_lb -listvar x
 
1783
#      $_lb selection set end
 
1784
#      set x [list a b c d]
 
1785
#      set x [list 0 1 2 3 4 5 6]
 
1786
#      $_lb curselection
 
1787
#  } {}
 
1788
#  test listbox-21.6 {ListboxListVarProc, test selection after listvar mod} {
 
1789
#      catch {destroy $_lb}
 
1790
#      set x [list a b c d]
 
1791
#      listbox $_lb -listvar x
 
1792
#      $_lb selection set 3
 
1793
#      lappend x e f g
 
1794
#      $_lb curselection
 
1795
#  } 3
 
1796
#  test listbox-21.7 {ListboxListVarProc, test selection after listvar mod} {
 
1797
#      catch {destroy $_lb}
 
1798
#      set x [list a b c d]
 
1799
#      listbox $_lb -listvar x
 
1800
#      $_lb selection set 0
 
1801
#      set x [linsert $x 0 1 2 3 4]
 
1802
#      $_lb curselection
 
1803
#  } 0
 
1804
#  test listbox-21.8 {ListboxListVarProc, test selection after listvar mod} {
 
1805
#      catch {destroy $_lb}
 
1806
#      set x [list a b c d]
 
1807
#      listbox $_lb -listvar x
 
1808
#      $_lb selection set 2
 
1809
#      set x [list a b c]
 
1810
#      $_lb curselection
 
1811
#  } 2
 
1812
#  test listbox-21.9 {ListboxListVarProc, test hscrollbar after listvar mod} {
 
1813
#      catch {destroy $_lb}
 
1814
#      catch {unset x}
 
1815
#      set log {}
 
1816
#      listbox $_lb -font $fixed -width 10 -xscrollcommand "record x" -listvar x
 
1817
#      pack $_lb
 
1818
#      update
 
1819
#      lappend x "0000000000"
 
1820
#      update
 
1821
#      lappend x "00000000000000000000"
 
1822
#      update
 
1823
#      set log
 
1824
#  } [list {x 0 1} {x 0 1} {x 0 0.5}]
 
1825
#  test listbox-21.10 {ListboxListVarProc, test hscrollbar after listvar mod} {
 
1826
#      catch {destroy $_lb}
 
1827
#      catch {unset x}
 
1828
#      set log {}
 
1829
#      listbox $_lb -font $fixed -width 10 -xscrollcommand "record x" -listvar x
 
1830
#      pack $_lb
 
1831
#      update
 
1832
#      lappend x "0000000000"
 
1833
#      update
 
1834
#      lappend x "00000000000000000000"
 
1835
#      update
 
1836
#      set x [list "0000000000"]
 
1837
#      update
 
1838
#      set log
 
1839
#  } [list {x 0 1} {x 0 1} {x 0 0.5} {x 0 1}]
 
1840
#  test listbox-21.11 {ListboxListVarProc, bad list} {
 
1841
#      catch {destroy $_lb}
 
1842
#      catch {unset x}
 
1843
#      listbox $_lb -listvar x
 
1844
#      set x [list a b c d]
 
1845
#      catch {set x {this is a " bad list}} result
 
1846
#      set result
 
1847
#  } {can't set "x": invalid listvar value}
 
1848
#  test listbox-21.12 {ListboxListVarProc, cleanup item attributes} {
 
1849
#      catch {destroy $_lb}
 
1850
#      set x [list a b c d e f g]
 
1851
#      listbox $_lb -listvar x
 
1852
#      $_lb itemconfigure end -fg red
 
1853
#      set x [list a b c d]
 
1854
#      set x [list 0 1 2 3 4 5 6]
 
1855
#      $_lb itemcget end -fg
 
1856
#  } {}
 
1857
#  test listbox-21.12 {ListboxListVarProc, cleanup item attributes} {
 
1858
#      catch {destroy $_lb}
 
1859
#      set x [list a b c d e f g]
 
1860
#      listbox $_lb -listvar x
 
1861
#      $_lb itemconfigure end -fg red
 
1862
#      set x [list a b c d]
 
1863
#      set x [list 0 1 2 3 4 5 6]
 
1864
#      $_lb itemcget end -fg
 
1865
#  } {}
 
1866
#  test listbox-21.13 {listbox item configurations and listvar based deletions} {
 
1867
#      catch {destroy $_lb}
 
1868
#      catch {unset x}
 
1869
#      listbox $_lb -listvar x
 
1870
#      $_lb insert end a b c
 
1871
#      $_lb itemconfigure 1 -fg red
 
1872
#      set x [list b c]
 
1873
#      $_lb itemcget 1 -fg
 
1874
#  } red
 
1875
#  test listbox-21.14 {listbox item configurations and listvar based inserts} {
 
1876
#      catch {destroy $_lb}
 
1877
#      catch {unset x}
 
1878
#      listbox $_lb -listvar x
 
1879
#      $_lb insert end a b c
 
1880
#      $_lb itemconfigure 0 -fg red
 
1881
#      set x [list 1 2 3 4 a b c]
 
1882
#      $_lb itemcget 0 -fg
 
1883
#  } red
 
1884
#  test listbox-21.15 {ListboxListVarProc, update vertical scrollbar} {
 
1885
#      catch {destroy $_lb}
 
1886
#      catch {unset x}
 
1887
#      set log {}
 
1888
#      listbox $_lb -listvar x -yscrollcommand "record y" -font fixed -height 3
 
1889
#      pack $_lb
 
1890
#      update
 
1891
#      lappend x a b c d e f
 
1892
#      update
 
1893
#      set log
 
1894
#  } [list {y 0 1} {y 0 0.5}]
 
1895
#  test listbox-21.16 {ListboxListVarProc, update vertical scrollbar} {
 
1896
#      catch {destroy $_lb}
 
1897
#      catch {unset x}
 
1898
#      listbox $_lb -listvar x -height 3
 
1899
#      pack $_lb
 
1900
#      update
 
1901
#      set x [list 0 1 2 3 4 5]
 
1902
#      $_lb yview scroll 3 units
 
1903
#      update
 
1904
#      set result {}
 
1905
#      lappend result [$_lb yview]
 
1906
#      set x [lreplace $x 3 3]
 
1907
#      set x [lreplace $x 3 3]
 
1908
#      set x [lreplace $x 3 3]
 
1909
#      update
 
1910
#      lappend result [$_lb yview]
 
1911
#      set result
 
1912
#  } [list {0.5 1} {0 1}]
 
1913
 
 
1914
# UpdateHScrollbar
 
1915
 
 
1916
@log = ();
 
1917
$lb = $mw->Listbox(-font => $fixed, -width => 10, -xscrollcommand => ["record", "x"])->pack;
 
1918
$mw->update;
 
1919
$lb->insert("end", "0000000000");
 
1920
$mw->update;
 
1921
$lb->insert("end", "00000000000000000000");
 
1922
$mw->update;
 
1923
ok($log[0], "x 0 1");
 
1924
ok($log[1], "x 0 1");
 
1925
ok($log[2], "x 0 0.5");
 
1926
 
 
1927
## no itemconfigure in Tk800.x
 
1928
#  # ConfigureListboxItem
 
1929
#  test listbox-23.1 {ConfigureListboxItem} {
 
1930
#      catch {destroy $_lb}
 
1931
#      listbox $_lb
 
1932
#      catch {$_lb itemconfigure 0} result
 
1933
#      set result
 
1934
#  } {item number "0" out of range}
 
1935
#  test listbox-23.2 {ConfigureListboxItem} {
 
1936
#      catch {destroy $_lb}
 
1937
#      listbox $_lb
 
1938
#      $_lb insert end a b c d
 
1939
#      $_lb itemconfigure 0
 
1940
#  } [list {-background background Background {} {}} \
 
1941
#       {-bg -background} \
 
1942
#       {-fg -foreground} \
 
1943
#       {-foreground foreground Foreground {} {}} \
 
1944
#       {-selectbackground selectBackground Foreground {} {}} \
 
1945
#       {-selectforeground selectForeground Background {} {}}]
 
1946
#  test listbox-23.3 {ConfigureListboxItem, itemco shortcut} {
 
1947
#      catch {destroy $_lb}
 
1948
#      listbox $_lb
 
1949
#      $_lb insert end a b c d
 
1950
#      $_lb itemco 0 -background
 
1951
#  } {-background background Background {} {}}
 
1952
#  test listbox-23.4 {ConfigureListboxItem, wrong num args} {
 
1953
#      catch {destroy $_lb}
 
1954
#      listbox $_lb
 
1955
#      $_lb insert end a
 
1956
#      catch {$_lb itemco} result
 
1957
#      set result
 
1958
#  } {wrong # args: should be "$_lb itemconfigure index ?option? ?value? ?option value ...?"}
 
1959
#  test listbox-23.5 {ConfigureListboxItem, multiple calls} {
 
1960
#      catch {destroy $_lb}
 
1961
#      listbox $_lb
 
1962
#      set i 0
 
1963
#      foreach color {red orange yellow green blue darkblue violet} {
 
1964
#       $_lb insert end $color
 
1965
#       $_lb itemconfigure $i -bg $color
 
1966
#       incr i
 
1967
#      }
 
1968
#      pack $_lb
 
1969
#      update
 
1970
#      list [$_lb itemcget 0 -bg] [$_lb itemcget 1 -bg] [$_lb itemcget 2 -bg] \
 
1971
#           [$_lb itemcget 3 -bg] [$_lb itemcget 4 -bg] [$_lb itemcget 5 -bg] \
 
1972
#           [$_lb itemcget 6 -bg]
 
1973
#  } {red orange yellow green blue darkblue violet}
 
1974
#  catch {destroy $_lb}
 
1975
#  listbox $_lb
 
1976
#  $_lb insert end a b c d
 
1977
#  set i 6
 
1978
#  #      {-background #ff0000 #ff0000 non-existent
 
1979
#  #        {unknown color name "non-existent"}}
 
1980
#  #      {-bg #ff0000 #ff0000 non-existent {unknown color name "non-existent"}}
 
1981
#  #      {-fg #110022 #110022 bogus {unknown color name "bogus"}}
 
1982
#  #      {-foreground #110022 #110022 bogus {unknown color name "bogus"}}
 
1983
#  #      {-selectbackground #110022 #110022 bogus {unknown color name "bogus"}}
 
1984
#  #      {-selectforeground #654321 #654321 bogus {unknown color name "bogus"}}
 
1985
#  #XXX
 
1986
#  foreach test { A } {
 
1987
#      set name [lindex $test 0]
 
1988
#      test listbox-23.$i {configuration options} {
 
1989
#       $_lb itemconfigure 0 $name [lindex $test 1]
 
1990
#       list [lindex [$_lb itemconfigure 0 $name] 4] [$_lb itemcget 0 $name]
 
1991
#      } [list [lindex $test 2] [lindex $test 2]]
 
1992
#      incr i
 
1993
#      if {[lindex $test 3] != ""} {
 
1994
#       test listbox-1.$i {configuration options} {
 
1995
#           list [catch {$_lb configure $name [lindex $test 3]} msg] $msg
 
1996
#       } [list 1 [lindex $test 4]]
 
1997
#      }
 
1998
#      $_lb configure $name [lindex [$_lb configure $name] 3]
 
1999
#      incr i
 
2000
#  }
 
2001
 
 
2002
#  # ListboxWidgetObjCmd, itemcget
 
2003
#  test listbox-24.1 {itemcget} {
 
2004
#      catch {destroy $_lb}
 
2005
#      listbox $_lb
 
2006
#      $_lb insert end a b c d
 
2007
#      $_lb itemcget 0 -fg
 
2008
#  } {}
 
2009
#  test listbox-24.2 {itemcget} {
 
2010
#      catch {destroy $_lb}
 
2011
#      listbox $_lb
 
2012
#      $_lb insert end a b c d
 
2013
#      $_lb itemconfigure 0 -fg red
 
2014
#      $_lb itemcget 0 -fg
 
2015
#  } red
 
2016
#  test listbox-24.3 {itemcget} {
 
2017
#      catch {destroy $_lb}
 
2018
#      listbox $_lb
 
2019
#      $_lb insert end a b c d
 
2020
#      catch {$_lb itemcget 0} result
 
2021
#      set result
 
2022
#  } {wrong # args: should be "$_lb itemcget index option"}
 
2023
#  test listbox-24.3 {itemcget, itemcg shortcut} {
 
2024
#      catch {destroy $_lb}
 
2025
#      listbox $_lb
 
2026
#      $_lb insert end a b c d
 
2027
#      catch {$_lb itemcg 0} result
 
2028
#      set result
 
2029
#  } {wrong # args: should be "$_lb itemcget index option"}
 
2030
 
 
2031
#  # General item configuration issues
 
2032
#  test listbox-25.1 {listbox item configurations and widget based deletions} {
 
2033
#      catch {destroy $_lb}
 
2034
#      listbox $_lb
 
2035
#      $_lb insert end a
 
2036
#      $_lb itemconfigure 0 -fg red
 
2037
#      $_lb delete 0 end
 
2038
#      $_lb insert end a
 
2039
#      $_lb itemcget 0 -fg
 
2040
#  } {}
 
2041
#  test listbox-25.2 {listbox item configurations and widget based inserts} {
 
2042
#      catch {destroy $_lb}
 
2043
#      listbox $_lb
 
2044
#      $_lb insert end a b c
 
2045
#      $_lb itemconfigure 0 -fg red
 
2046
#      $_lb insert 0 1 2 3 4
 
2047
#      list [$_lb itemcget 0 -fg] [$_lb itemcget 4 -fg]
 
2048
#  } [list {} red]
 
2049
 
 
2050
resetGridInfo();
 
2051
 
 
2052
sub record {
 
2053
    push @log, join(" ", @_);
 
2054
}
 
2055
 
 
2056
sub getsize {
 
2057
    my $w = shift;
 
2058
    my $geom = $w->geometry;
 
2059
    $geom =~ /(\d+x\d+)/;
 
2060
    $1;
 
2061
}
 
2062
 
 
2063
sub resetGridInfo {
 
2064
    # Some window managers, such as mwm, don't reset gridding information
 
2065
    # unless the window is withdrawn and re-mapped.  If this procedure
 
2066
    # isn't invoked, the window manager will stay in gridded mode, which
 
2067
    # can cause all sorts of problems.  The "wm positionfrom" command is
 
2068
    # needed so that the window manager doesn't ask the user to
 
2069
    # manually position the window when it is re-mapped.
 
2070
    $mw->withdraw;
 
2071
    $mw->positionfrom('user');
 
2072
    $mw->deiconify;
 
2073
}
 
2074
 
 
2075
# Procedure that creates a second listbox for checking things related
 
2076
# to partially visible lines.
 
2077
sub mkPartial {
 
2078
    eval {
 
2079
        $partial_top->destroy
 
2080
            if Tk::Exists($partial_top);
 
2081
    };
 
2082
    $partial_top = $mw->Toplevel;
 
2083
    $partial_top->geometry('+0+0');
 
2084
    $partial_lb = $partial_top->Listbox(-width => 30, -height => 5);
 
2085
    $partial_lb->pack('-expand',1,'-fill','both');
 
2086
    $partial_lb->insert('end','one','two','three','four','five','six','seven',
 
2087
                        'eight','nine','ten','eleven','twelve','thirteen',
 
2088
                        'fourteen','fifteen');
 
2089
    $partial_top->update;
 
2090
    my $geom = $partial_top->geometry;
 
2091
    my($width, $height) = $geom =~ /(\d+)x(\d+)/;
 
2092
    $partial_top->geometry($width . "x" . ($height-3));
 
2093
    $partial_top->update;
 
2094
}
 
2095
 
 
2096
__END__
 
2097