File: 1numentryplain.t

package info (click to toggle)
libtk-gbarr-perl 2.08-3
  • links: PTS, VCS
  • area: main
  • in suites: bookworm, forky, sid, trixie
  • size: 284 kB
  • sloc: perl: 1,875; makefile: 19
file content (90 lines) | stat: -rw-r--r-- 2,035 bytes parent folder | download | duplicates (4)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
BEGIN
  {
    $^W = 1;
    $| = 1;

    eval { require Test; };
    if ($@)
      {
        $^W=0;
        print "1..0\n";
        print STDERR "\n\tTest.pm module not installed.\n\tGrab it from CPAN.\n\t";
        exit;
      }
    Test->import;
  }
use strict;
use Tk;

my $mw;
BEGIN 
  {
    if (!eval { $mw = Tk::MainWindow->new })
      {
	print "1..0 # skip cannot open DISPLAY\n";
	CORE::exit;
      }
  }

BEGIN { plan tests => 10 };

my $nep;
{
   eval { require Tk::NumEntryPlain; };
   ok($@, "", 'Problem loading Tk::NumEntryPlain');
   eval { $nep = $mw->NumEntryPlain(); };
   ok($@, "", 'Problem creating NumEntryPlain widget');
   ok( Tk::Exists($nep) );
   eval { $nep->grid; };
   ok($@, "", '$text->grid problem');
   eval { $nep->update; };
   ok($@, "", '$nep->update problem');
}
##
## Check that -textvariable works for reading
##	(set work but not supported)
##
{
    my $num = 0;
    my $e = $mw->NumEntryPlain(-textvariable=>\$num);
    eval { $e->value(6); };
    ok($@, "", 'Problem setting value');
    ok($num, "6", "Textvariable is not updated");

    eval { $e->update; };
    ok($@, "", 'Problem in update after setting value');
}

##
## Check -increment, -bigincrement, -command and -browsecmd options
{
    my $command = 0;
    my $browsecmd = 0;
    my $e = $mw->NumEntryPlain(-increment    => 0.1,
			       -bigincrement => 50,
			       -command => sub { $command++ },
			       -browsecmd => sub { $browsecmd++ },
			      );
    ok($e->cget(-increment), 0.1);
    ok($e->cget(-bigincrement), 50);

    if (0) {
	# XXX eventGenerate does not work
	if ($Tk::VERSION < 800.017) {
	    skip("No -warp option for eventGenerate", 1) for (1..3);
	} else {
	    $e->update;
	    my $x = $e->width/2;
	    my $y = $e->height/2;
	    $e->eventGenerate("<Motion>", '-x' => $x, '-y' => $y, -warp => 1);
	    $e->eventGenerate("<Up>");
	    ok($e->get, "1");
	    ok($browsecmd, 1);
	    $e->eventGenerate("<Return>",
			      '-x' => $x, '-y' => $y,
			      -warp => 1);
	    ok($command, 1);
	}
    }
}