← Back to branch summary

~ubuntu-branches/ubuntu/raring/perl-tk/raring

« back to all changes in this revision

Viewing changes to t/fbox.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/fbox.t
1
1
# -*- perl -*-
2
2
BEGIN { $|=1; $^W=1; }
3
3
use strict;
4
 
use Test;
5
 
 
6
 
BEGIN { plan test => 6 };
7
 
 
8
 
eval { require Tk };
9
 
ok($@, "", "loading Tk module");
10
 
 
11
 
eval { require Tk::FBox };
12
 
ok($@, "", "loading Tk::FBox module");
 
4
use FindBin;
 
5
use lib $FindBin::RealBin;
 
6
 
 
7
BEGIN {
 
8
    if (!eval q{
 
9
        use Test::More;
 
10
        1;
 
11
    }) {
 
12
        print "1..0 # skip: no Test::More module\n";
 
13
        exit;
 
14
    }
 
15
}
 
16
 
 
17
use TkTest qw(catch_grabs);
 
18
 
 
19
plan tests => 13;
 
20
 
 
21
if (!defined $ENV{BATCH}) { $ENV{BATCH} = 1 }
 
22
 
 
23
use_ok("Tk");
 
24
use_ok("Tk::FBox");
13
25
 
14
26
my $top = new MainWindow;
15
 
eval { $top->geometry('+10+10'); };  # This works for mwm and interactivePlacement
 
27
eval { $top->geometry('+10+10'); }; # This works for mwm and interactivePlacement
16
28
 
17
29
my $f;
 
30
 
 
31
my $delay = 500;
 
32
 
 
33
######################################################################
 
34
# open
18
35
eval {
19
36
    $f = $top->FBox(-defaultextension => ".PL",
20
37
                    -filetypes => [
27
44
                                  ],
28
45
                    -initialdir => ".",
29
46
                    -initialfile => "Makefile.PL",
30
 
                    -title => "Load file",
 
47
                    -title => "Load file (with filetypes)",
 
48
                    -type => "open",
 
49
                    -filter => "*.PL", # ignored
 
50
                    -font => "Helvetica 14",
 
51
                   );
 
52
};
 
53
is($@, "", "creating Tk::FBox widget");
 
54
 
 
55
catch_grabs {
 
56
    $f->after($delay, sub { $f->destroy }) if $ENV{BATCH};
 
57
    my $result = $f->Show;
 
58
    if (!$ENV{BATCH}) {
 
59
        diag "Result is <$result>";
 
60
    }
 
61
    pass("After showing FBox")
 
62
} 1;
 
63
 
 
64
######################################################################
 
65
# open without filetypes
 
66
eval {
 
67
    $f = $top->FBox(-defaultextension => ".PL",
 
68
                    -initialdir => ".",
 
69
                    -initialfile => "Makefile.PL",
 
70
                    -title => "Load file (without filetypes, with filter)",
31
71
                    -type => "open",
32
72
                    -filter => "*.PL",
33
73
                    -font => "Helvetica 14",
34
74
                   );
35
75
};
36
 
ok($@, "", "creating Tk::FBox widget");
37
 
 
38
 
$f->after(1000, sub { $f->destroy });
39
 
$f->Show;
40
 
ok(1);
41
 
 
 
76
is($@, "", "creating Tk::FBox widget");
 
77
 
 
78
catch_grabs {
 
79
    $f->after($delay, sub { $f->destroy }) if $ENV{BATCH};
 
80
    my $result = $f->Show;
 
81
    if (!$ENV{BATCH}) {
 
82
        diag "Result is <$result>";
 
83
    }
 
84
    pass("After showing FBox")
 
85
} 1;
 
86
 
 
87
######################################################################
 
88
# save
42
89
eval {
43
90
    $f = $top->FBox(-defaultextension => ".PL",
44
91
                    -filetypes => [
53
100
                    -initialfile => "Makefile.PL",
54
101
                    -title => "Save file",
55
102
                    -type => "save",
56
 
                    -filter => "*.PL",
57
 
                    -font => "Helvetica 14",
58
 
                   );
59
 
};
60
 
ok($@, "", "creating Tk::FBox widget for save");
61
 
$f->after(1000, sub { $f->destroy });
62
 
$f->Show;
63
 
ok(1);
 
103
                    -filter => "*.PL", # ignored
 
104
                    -font => "Helvetica 14",
 
105
                   );
 
106
};
 
107
is($@, "", "creating Tk::FBox widget for save");
 
108
 
 
109
catch_grabs {
 
110
    $f->after($delay, sub { $f->destroy }) if $ENV{BATCH};
 
111
    my $result = $f->Show;
 
112
    if (!$ENV{BATCH}) {
 
113
        diag "Result is <$result>";
 
114
    }
 
115
    pass("After showing FBox");
 
116
} 1;
 
117
 
 
118
######################################################################
 
119
# dir
 
120
eval {
 
121
    $f = $top->FBox(-initialdir => ".",
 
122
                    -title => "Choose directory",
 
123
                    -type => "dir",
 
124
                    -font => "Helvetica 14",
 
125
                   );
 
126
};
 
127
is($@, "", "creating Tk::FBox widget for choosing directories");
 
128
 
 
129
catch_grabs {
 
130
    $f->after($delay, sub { $f->destroy }) if $ENV{BATCH};
 
131
    my $result = $f->Show;
 
132
    if (!$ENV{BATCH}) {
 
133
        diag "Result is <$result>";
 
134
    }
 
135
    pass("After showing FBox");
 
136
} 1;
 
137
 
 
138
######################################################################
 
139
# getOpenFile etc.
 
140
SKIP: {
 
141
    skip("getOpenFile etc. only on X11", 3)
 
142
        if $Tk::platform ne 'unix';
 
143
 
 
144
    {
 
145
        my $mw = MainWindow->new;
 
146
        $mw->after($delay, sub { $mw->destroy }) if $ENV{BATCH};
 
147
        my $result = $mw->getOpenFile;
 
148
        if (!$ENV{BATCH}) {
 
149
            diag "Result is <$result>";
 
150
        }
 
151
        pass("called getOpenFile");
 
152
    }
 
153
 
 
154
    {
 
155
        my $mw = MainWindow->new;
 
156
        $mw->after($delay, sub { $mw->destroy }) if $ENV{BATCH};
 
157
        my $result = $mw->getSaveFile;
 
158
        if (!$ENV{BATCH}) {
 
159
            diag "Result is <$result>";
 
160
        }
 
161
        pass("called getSaveFile");
 
162
    }
 
163
 
 
164
    {
 
165
        my $mw = MainWindow->new;
 
166
        $mw->after($delay, sub { $mw->destroy }) if $ENV{BATCH};
 
167
        my $result = $mw->chooseDirectory;
 
168
        if (!$ENV{BATCH}) {
 
169
            diag "Result is <$result>";
 
170
        }
 
171
        pass("called chooseDirectory");
 
172
    }
 
173
}
64
174
 
65
175
1;
66
176
__END__