← Back to branch summary

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

« back to all changes in this revision

Viewing changes to t/property.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/property.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
use Data::Dumper;
 
13
 
 
14
BEGIN {
 
15
    if (!eval q{
 
16
        use Test::More;
 
17
        1;
 
18
    }) {
 
19
        print "1..0 # skip: no Test::More module\n";
 
20
        exit;
 
21
    }
 
22
}
 
23
 
 
24
unless ($Tk::platform eq 'unix') {
 
25
    plan skip_all => 'property only work on X11';
 
26
    exit 0;
 
27
}
 
28
 
 
29
plan tests => 38;
 
30
 
 
31
my $mw = tkinit;
 
32
$mw->geometry("+10+10");
 
33
 
 
34
{
 
35
    my @prop = $mw->property('list');
 
36
    is(scalar(@prop), 0, "No properties on mw");
 
37
    ok(!$mw->property('exists','_PERL_TK_ThisPropertyDoesNotExist'), "Not-existent property");
 
38
}
 
39
 
 
40
{
 
41
    my @prop = $mw->property('list','root');
 
42
    cmp_ok(scalar(@prop), ">=", 1, "It's very likely that there are properties on the root window");
 
43
    ok(!$mw->property('exists','_PERL_TK_ThisPropertyDoesNotExist'.rand(10),'root'), "Not-existent property");
 
44
}
 
45
 
 
46
# format=8 differs from format=16/32: The value to set and get is a
 
47
# string. If getting the property value, then a "\0" is appended (I
 
48
# don't know if this is intentional, this may change). With
 
49
# format=16/32 the values are array references with integers.
 
50
{
 
51
    my $format = 8;
 
52
 
 
53
    $mw->property('set', '_PERL_TK_TestProperty_1', "CARDINAL", $format, "a");
 
54
    ok($mw->property('exists', '_PERL_TK_TestProperty_1'), "Format=$format, Property exists");
 
55
    is($mw->property('get', '_PERL_TK_TestProperty_1'), "a\0", "Expected get result")
 
56
        or diag(Dumper [$mw->property('get', '_PERL_TK_TestProperty_1')]);
 
57
    is_xprop('_PERL_TK_TestProperty_1', [map { ord } split //, "a\0"], "Expected xprop result");
 
58
 
 
59
    $mw->property('set', '_PERL_TK_TestProperty_1', "CARDINAL", $format, "abc");
 
60
    ok($mw->property('exists', '_PERL_TK_TestProperty_1'), "Format=$format, Property exists, longer value");
 
61
    is($mw->property('get', '_PERL_TK_TestProperty_1'), "abc\0")
 
62
        or diag(Dumper [$mw->property('get', '_PERL_TK_TestProperty_1')]);
 
63
    is_xprop('_PERL_TK_TestProperty_1', [map { ord } split //, "abc\0"]);
 
64
 
 
65
    my @list = $mw->property('list');
 
66
    ok((grep { $_ eq '_PERL_TK_TestProperty_1' } @list), "Found test property in list");
 
67
 
 
68
    my @list2 = $mw->property('list', hex $mw->id);
 
69
    is_deeply(\@list, \@list2, "Same list with explicite window id");
 
70
 
 
71
    $mw->property('delete', '_PERL_TK_TestProperty_1');
 
72
    ok(!$mw->property('exists', '_PERL_TK_TestProperty_1'), "Property deleted");
 
73
 
 
74
    my @list_after_delete = $mw->property('list');
 
75
    ok(!(grep { $_ eq '_PERL_TK_TestProperty_1' } @list_after_delete), "Not appearing in list anymore");
 
76
}
 
77
 
 
78
for my $format (16, 32) {
 
79
    $mw->property('set', '_PERL_TK_TestProperty_1', "CARDINAL", $format, [1]);
 
80
    ok($mw->property('exists', '_PERL_TK_TestProperty_1'), "Format=$format, Property exists");
 
81
    is_deeply([$mw->property('get', '_PERL_TK_TestProperty_1')], ["CARDINAL", 1], "Expected get result")
 
82
        or diag(Dumper [$mw->property('get', '_PERL_TK_TestProperty_1')]);
 
83
    is_xprop('_PERL_TK_TestProperty_1', [1], "Expected xprop result");
 
84
 
 
85
    $mw->property('set', '_PERL_TK_TestProperty_1', "CARDINAL", $format, [1,2,3]);
 
86
    ok($mw->property('exists', '_PERL_TK_TestProperty_1'), "Format=$format, Property exists, longer value");
 
87
    is_deeply([$mw->property('get', '_PERL_TK_TestProperty_1')], ["CARDINAL", 1,2,3])
 
88
        or diag(Dumper [$mw->property('get', '_PERL_TK_TestProperty_1')]);
 
89
    is_xprop('_PERL_TK_TestProperty_1', [1,2,3]);
 
90
 
 
91
    $mw->property('delete', '_PERL_TK_TestProperty_1');
 
92
    ok(!$mw->property('exists', '_PERL_TK_TestProperty_1'), "Property deleted");
 
93
}
 
94
 
 
95
# Test with ATOMs
 
96
{
 
97
    $mw->property('set', '_PERL_TK_TestProperty_2', "ATOM", 32, ['_PERL_TK_TestAtom_1']);
 
98
    ok($mw->property('exists', '_PERL_TK_TestProperty_2'), "Property with ATOM exists");
 
99
    is_deeply([$mw->property('get', '_PERL_TK_TestProperty_2')], ['ATOM', '_PERL_TK_TestAtom_1'], "Expected get result")
 
100
        or diag(Dumper [$mw->property('get', '_PERL_TK_TestProperty_2')]);
 
101
    is_xprop('_PERL_TK_TestProperty_2', ['_PERL_TK_TestAtom_1'], "Expected xprop result");
 
102
 
 
103
    my @list = $mw->property('list');
 
104
    ok((grep { $_ eq '_PERL_TK_TestProperty_2' } @list), "Found test property in list");
 
105
 
 
106
    $mw->property('delete', '_PERL_TK_TestProperty_2');
 
107
    ok(!$mw->property('exists', '_PERL_TK_TestProperty_2'), "Property deleted");
 
108
}
 
109
 
 
110
# Test with STRINGs
 
111
{
 
112
    $mw->property('set', '_PERL_TK_TestProperty_3', "STRING", 8, 'TestString');
 
113
    ok($mw->property('exists', '_PERL_TK_TestProperty_3'), "Property with STRING exists");
 
114
    is($mw->property('get', '_PERL_TK_TestProperty_3'), "TestString\0", "Expected get result")
 
115
        or diag(Dumper [$mw->property('get', '_PERL_TK_TestProperty_3')]);
 
116
    is_xprop('_PERL_TK_TestProperty_3', ['"TestString"'], "Expected xprop result");
 
117
 
 
118
    my @list = $mw->property('list');
 
119
    ok((grep { $_ eq '_PERL_TK_TestProperty_3' } @list), "Found test property in list");
 
120
 
 
121
    $mw->property('delete', '_PERL_TK_TestProperty_3');
 
122
    ok(!$mw->property('exists', '_PERL_TK_TestProperty_3'), "Property deleted");
 
123
}
 
124
 
 
125
sub is_xprop {
 
126
    my($prop, $expected, $testname) = @_;
 
127
 SKIP: {
 
128
        skip("xprop not in PATH", 1)
 
129
            if !xprop_is_in_path();
 
130
        my $mw_id = $mw->id;
 
131
        chomp(my $res = `xprop -notype -id $mw_id $prop`);
 
132
        $res =~ s{^\Q$prop\E\s*=\s*}{};
 
133
        my(@bytes) = split /\s*,\s*/, $res;
 
134
        is_deeply(\@bytes, $expected, $testname)
 
135
            or diag(Dumper \@bytes);
 
136
    }
 
137
}
 
138
 
 
139
{
 
140
    my $xprop_is_in_path;
 
141
    sub xprop_is_in_path {
 
142
        my($prog) = "xprop";
 
143
        my $path = eval {
 
144
            require File::Spec;
 
145
            require Config;
 
146
            return $prog if (File::Spec->file_name_is_absolute($prog) and -f $prog and -x $prog);
 
147
            my $sep = $Config::Config{'path_sep'} || ':';
 
148
            foreach (split(/$sep/o, $ENV{PATH})) {
 
149
                return "$_/$prog" if (-x "$_/$prog" && !-d "$_/$prog");
 
150
            }
 
151
            undef;
 
152
        };
 
153
        warn $@ if $@; # unlikely to happen
 
154
        $xprop_is_in_path = $path; # cache
 
155
        $path;
 
156
    }
 
157
}
 
158
 
 
159
__END__