← Back to branch summary

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

« back to all changes in this revision

Viewing changes to t/Tkxs.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/Tkxs.t
 
1
#!/usr/bin/perl -w
 
2
# -*- perl -*-
 
3
 
 
4
#
 
5
# $Id: $
 
6
# Author: Slaven Rezic
 
7
#
 
8
 
 
9
use strict;
 
10
 
 
11
use Tk;
 
12
 
 
13
BEGIN {
 
14
    if (!eval q{
 
15
        use Test::More;
 
16
        1;
 
17
    }) {
 
18
        print "1..0 # skip: no Test::More module\n";
 
19
        exit;
 
20
    }
 
21
}
 
22
 
 
23
my $all_tests = 37;
 
24
 
 
25
plan tests => $all_tests;
 
26
 
 
27
SKIP: {
 
28
    skip('Set $ENV{TEST_AUTHOR} to a true value to run.', $all_tests)
 
29
        unless $ENV{TEST_AUTHOR};
 
30
 
 
31
    my $mw = tkinit;
 
32
    $mw->geometry("+10+10");
 
33
    my $l = $mw->Label(-text => "The Tk.xs test")->pack;
 
34
    
 
35
    {
 
36
        my $winid = $mw->PointToWindow(1,1);
 
37
        ok(defined $winid, "PointToWindow: got window id <$winid>");
 
38
    }
 
39
    
 
40
    # XXX FontInfo_* ?
 
41
    # XXX LangFontRank ?
 
42
    
 
43
    {
 
44
        ok(Tk::BLACK, "Colors: Black");
 
45
        ok(Tk::WHITE, "White");
 
46
        ok(Tk::NORMAL_BG, "Normal bg");
 
47
        ok(Tk::ACTIVE_BG, "Active bg");
 
48
        ok(Tk::SELECT_BG, "Select bg");
 
49
        ok(Tk::SELECT_FG, "Select fg");
 
50
        ok(Tk::TROUGH, "Trough");
 
51
        ok(Tk::INDICATOR, "Indicator");
 
52
        ok(Tk::DISABLED, "Disabled");
 
53
    }
 
54
    
 
55
    {
 
56
        is($mw->Count, 1, "Exactly one main window");
 
57
        $mw->Synchronize();
 
58
        pass("Called pTk_Synchronize");
 
59
    }
 
60
    
 
61
    {
 
62
        my $time_before = time;
 
63
        my $timeofday   = Tk::timeofday;
 
64
        my $time_after  = time;
 
65
        cmp_ok($time_before-1, "<=", $timeofday, "Time of day");
 
66
        cmp_ok($time_after+1, ">=", $timeofday);
 
67
    }
 
68
    
 
69
    {
 
70
        my($x1,$y1) = $mw->GetPointerCoords;
 
71
        my($x2,$y2) = $mw->pointerxy;
 
72
        is($x1, $x2, "GetPointerCoords and pointerxy should get the same");
 
73
        is($y1, $y2);
 
74
    }
 
75
    
 
76
    {
 
77
        ok($mw->IsTopLevel, "IsTopLevel positive");
 
78
        ok(!$l->IsTopLevel, "IsTopLevel negative");
 
79
        ok($mw->IsWidget, "IsWidget positive on toplevel");
 
80
        ok($l->IsWidget, "IsWidget positive on label");
 
81
        my $l2 = $mw->Label; $l2->destroy;
 
82
        ok(!$l2->IsWidget, "IsWidget negative (destroyed label)");
 
83
    }
 
84
    
 
85
    {
 
86
        ok(!$mw->IsMapped, "Toplevel not yet mapped");
 
87
    }
 
88
    
 
89
    # From now on we have a mapped window
 
90
    $mw->update;
 
91
    
 
92
    {
 
93
        ok($mw->IsMapped, "Toplevel is now mapped");
 
94
    }
 
95
    
 
96
    {
 
97
        my($x1,$y1) = $mw->WindowXY;
 
98
        my($x2,$y2) = ($mw->rootx, $mw->rooty);
 
99
        my($x3,$y3) = $mw->GetRootCoords;
 
100
    
 
101
        is($x1,$x2, "WindowXY gets the same as rootx/rooty");
 
102
        is($y1,$y2);
 
103
        is("$x1/$y1", "$x3/$y3", "GetRootCoords also the same");
 
104
    }
 
105
    
 
106
    {
 
107
        my $MYBITMAP = __PACKAGE__ . "::mybitmap";
 
108
        my $hbits = pack("b8"x5,
 
109
                         ".....11.",
 
110
                         "...11.1.",
 
111
                         ".11...1.",
 
112
                         "...11.1.",
 
113
                         ".....11.");
 
114
        $mw->DefineBitmap($MYBITMAP => 8,5, $hbits);
 
115
        $mw->Label(-bitmap => $MYBITMAP)->pack;
 
116
        pass("Using bitmap defined with DefineBitmap");
 
117
    
 
118
        my $pixmapid = $mw->GetBitmap($MYBITMAP);
 
119
        ok(defined $pixmapid, "GetBitmap returned <$pixmapid>");
 
120
        my $invalid = $mw->GetBitmap("this_really_does_not_exist");
 
121
        ok(!defined $invalid, "Invalid GetBitmap");
 
122
    }
 
123
    
 
124
    {
 
125
        $mw->XSync(0);
 
126
        pass("Called XSync(0)");
 
127
        $mw->XSync(1);
 
128
        pass("Called XSync(1)");
 
129
    }
 
130
    
 
131
    {
 
132
        $mw->MoveWindow(11,11);
 
133
        my($x1,$y1) = $mw->GetRootCoords;
 
134
        is("$x1/$y1", "11/11", "MoveWindow on toplevel");
 
135
    
 
136
        $mw->MoveToplevelWindow(12,12);
 
137
        # no change in GetRootCoords here, is this intended?
 
138
        pass("Called MoveToplevelWindow");
 
139
    
 
140
        $mw->MoveResizeWindow(13,13,200,50);
 
141
        pass("Called MoveResizeWindow");
 
142
    
 
143
        $mw->ResizeWindow(100,50);
 
144
        pass("Called ResizeWindow");
 
145
    }
 
146
    
 
147
    {
 
148
        my $font = $l->cget(-font);
 
149
        my $psname;
 
150
        $font->PostscriptFontName($psname);
 
151
        ok($psname, "Found postscript font name <$psname>");
 
152
    }
 
153
    
 
154
    {
 
155
        local $TODO = "GetFocusWin does not seem to return anything";
 
156
        isa_ok($mw->GetFocusWin, "Tk::Widget", "GetFocusWin returns a widget");
 
157
    }
 
158
    
 
159
    # missing: UnmanageGeometry, DisableButtonEvents, MakeAtom,
 
160
    # SendClientMessage, GetVRootGeometry, Colormap, Display, ScreenNumber etc.
 
161
}
 
162
 
 
163
__END__