← Back to branch summary

~ubuntu-branches/ubuntu/lucid/perl-tk/lucid

« back to all changes in this revision

Viewing changes to t/dialogbox.t

  • Committer: Bazaar Package Importer
  • Author(s): Colin Tuckley
  • Date: 2008-02-15 13:56:59 UTC
  • mfrom: (1.1.3 upstream) (4.1.1 hardy)
  • Revision ID: james.westby@ubuntu.com-20080215135659-ru2oqlykuju20fav
Tags: 1:804.028-1
http://bugs.debian.org/463080
http://bugs.debian.org/411129
* New Upstream Release (Closes: #463080).
* Update to Debhelper v5.
* Build with XFT=1 (Closes: #411129).

Show diffs side-by-side

added added

removed removed

Lines of Context:
t/dialogbox.t
1
1
# -*- perl -*-
2
2
BEGIN { $|=1; $^W=1; }
3
3
use strict;
4
 
use Test;
5
 
 
6
 
BEGIN { plan test => 8 };
 
4
 
 
5
BEGIN {
 
6
    if (!eval q{
 
7
        use Test::More;
 
8
        1;
 
9
    }) {
 
10
        print "1..0 # skip: no Test::More module\n";
 
11
        exit;
 
12
    }
 
13
}
 
14
 
 
15
my $interactive_tests = 4;
 
16
plan tests => 8 + $interactive_tests;
7
17
 
8
18
if (!defined $ENV{BATCH}) { $ENV{BATCH} = 1 }
9
19
 
10
 
eval { require Tk };
11
 
ok($@, "", "loading Tk module");
12
 
 
13
 
eval { require Tk::DialogBox };
14
 
ok($@, "", "loading Tk::DialogBox module");
 
20
use_ok("Tk");
 
21
use_ok("Tk::DialogBox");
15
22
 
16
23
my $top = new MainWindow;
 
24
$top->Message(-font => "Helvetica 24",
 
25
              -text => "This is the Main Window")->pack;
17
26
$top->withdraw unless $^O eq 'MSWin32';
18
27
eval { $top->geometry('+10+10'); };  # This works for mwm and interactivePlacement
19
28
 
20
29
{
21
30
    my $d = $top->DialogBox;
 
31
    $d->add("Label",
 
32
            -text => "A dialog box with some widgets." . 
 
33
            (!$ENV{BATCH} ? "\nClick OK to continue." : ""),
 
34
           )->pack;
22
35
    my $e = $d->add("Entry")->pack;
23
36
    $d->configure(-focus => $e,
24
37
                  -showcommand => sub {
25
38
                      my $w = shift;
26
 
                      ok($w, $d, "Callback parameter check");
 
39
                      is($w, $d, "Callback parameter check");
27
40
                      $d->update;
28
41
                      my $fc = $d->focusCurrent || "";
29
 
                      ok($fc eq "" || $fc eq $e, 1,
 
42
                      ok($fc eq "" || $fc eq $e,
30
43
                         "Check -focus option (current focus is on `$fc')");
31
44
                      my $ok_b = $d->Subwidget("B_OK");
32
 
                      ok(!!Tk::Exists($ok_b), 1, "Check default button");
33
 
                      ok(UNIVERSAL::isa($ok_b, "Tk::Button"));
 
45
                      ok(Tk::Exists($ok_b), "Check default button");
 
46
                      isa_ok($ok_b, "Tk::Button");
34
47
                      $ok_b->after(300, sub { $ok_b->invoke }) if $ENV{BATCH};
35
48
                  });
36
 
    ok($d->Show, "OK");
 
49
    is($d->Show, "OK", "Expected result");
37
50
}
38
51
 
39
52
{
40
53
    my $d = $top->DialogBox(-buttons => [qw(OK Cancel), "I don't know"],
41
54
                            -default_button => "Cancel");
42
 
    my $e = $d->add("Label", -text => "Hello, world!")->pack;
 
55
    my $e = $d->add("Label", -text => "Hello, world!\nPlease click the default button (Cancel)")->pack;
43
56
    $d->configure(-showcommand => sub {
44
57
                      $d->update;
45
58
                      my $d_b = $d->{default_button};
46
59
                      $d->after(300, sub { $d_b->invoke }) if $ENV{BATCH};
47
60
                  });
48
 
    ok($d->Show, "Cancel");
 
61
    is($d->Show, "Cancel", "Expected default button result");
 
62
}
 
63
 
 
64
SKIP: {
 
65
    skip("Needs non-BATCH mode (env BATCH=0 $^X -Mblib t/dialogbox.t)", $interactive_tests)
 
66
        if $ENV{BATCH};
 
67
 
 
68
    my $close_text = "Please close the dialog by using the window manager's close button";
 
69
 
 
70
    {
 
71
        my $d = $top->DialogBox(-buttons => [qw(OK)]);
 
72
        my $e = $d->add("Label", -text => $close_text)->pack;
 
73
        is($d->Show, "OK", "One button dialog - only button is cancel_button");
 
74
    }
 
75
 
 
76
    {
 
77
        my $d = $top->DialogBox(-buttons => [qw(OK Cancel)], -cancel_button => 'Cancel');
 
78
        my $e = $d->add("Label", -text => $close_text)->pack;
 
79
        is($d->Show, "Cancel", "Explicite cancel button");
 
80
    }    
 
81
 
 
82
    {
 
83
        my $d = $top->DialogBox(-buttons => [qw(OK Cancel)]);
 
84
        my $e = $d->add("Label", -text => $close_text)->pack;
 
85
        is($d->Show, undef, "No implicite cancel button with more than one buttons");
 
86
    }
 
87
 
 
88
    # This should be the last test
 
89
    {
 
90
        $top->raise;
 
91
        $top->deiconify;
 
92
        my $d = $top->DialogBox(-buttons => [qw(Ok Cancel)]);
 
93
        my $e = $d->add("Message", -text => "Please close the ***Main window*** using the window manager's close button. The test program must not hang.")->pack;
 
94
        ok(!$d->Show, "No hanging program after destroying main window");
 
95
    }
49
96
}
50
97
 
51
98
1;