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
91
92
93
94
95
96
97
98
99
100
101
102
103
104
|
#!/usr/bin/perl -w
use strict;
use Gtk2::TestHelper tests => 20;
# $Header: /cvsroot/gtk2-perl/gtk2-perl-xs/Gtk2/t/GdkDnd.t,v 1.9 2006/08/07 18:36:02 kaffeetisch Exp $
my $window = Gtk2::Window -> new();
$window -> realize();
$window -> show_now;
###############################################################################
my $context = Gtk2::Gdk::DragContext -> new();
isa_ok($context, "Gtk2::Gdk::DragContext");
my @targets = (Gtk2::Gdk::Atom -> new("target-string"),
Gtk2::Gdk::Atom -> new("target-bitmap"));
$context = Gtk2::Gdk::DragContext -> begin($window -> window(), @targets);
isa_ok($context, "Gtk2::Gdk::DragContext");
my ($destination, $protocol);
SKIP: {
skip("GdkScreen is new in 2.2", 2)
unless Gtk2 -> CHECK_VERSION(2, 2, 0);
($destination, $protocol) = $context -> find_window_for_screen($window -> window(), Gtk2::Gdk::Screen -> get_default(), 0, 0);
ok(not defined $destination or ref $destination eq "Gtk2::Gdk::Window");
ok(not defined $destination or $protocol);
}
$context -> abort(0);
###############################################################################
$context = Gtk2::Gdk::DragContext -> begin($window -> window(), @targets);
isa_ok($context, "Gtk2::Gdk::DragContext");
ok($context -> protocol());
is($context -> is_source(), 1);
is($context -> source_window(), $window -> window());
# is_deeply([$context -> targets()], \@targets);
isa_ok(($context -> targets())[0], "Gtk2::Gdk::Atom");
($destination, $protocol) = $context -> find_window($window -> window(), 0, 0);
ok(not defined $destination or ref $destination eq "Gtk2::Gdk::Window");
ok(not defined $destination or $protocol);
SKIP: {
skip "find_window returned no destination window, skipping the tests that need one", 9
unless defined $destination;
# FIXME: what about the return value?
$context -> motion($destination, $protocol, 0, 0, [qw(copy)], [qw(copy move)], 0);
ok($context -> actions() == [qw(copy move)]);
ok($context -> suggested_action() == qw(copy));
is($context -> start_time(), 0);
SKIP: {
skip "can't do x11 stuff on this platform", 2
if $^O eq 'MSWin32';
is_deeply([Gtk2::Gdk::DragContext -> get_protocol($destination -> get_xid())],
[$destination -> get_xid(), $protocol]);
skip("get_protocol_for_display is new in 2.2", 1)
unless Gtk2->CHECK_VERSION (2, 2, 0);
is_deeply([Gtk2::Gdk::DragContext -> get_protocol_for_display(Gtk2::Gdk::Display -> get_default(), $destination -> get_xid())],
[$destination -> get_xid(), $protocol]);
}
is($context -> dest_window(), $destination);
TODO: { local $TODO = "This seems to fail harmlessly with Apple's X11";
isa_ok($context -> get_selection(), "Gtk2::Gdk::Atom");
}
$context -> status(qw(move), 0);
ok($context -> action() == qw(move));
$context -> status([], 0);
$context -> drop_reply(1, 0);
$context -> drop_finish(1, 0);
SKIP: {
skip "new 2.6 stuff", 1
unless Gtk2 -> CHECK_VERSION(2, 6, 0);
like($context -> drag_drop_succeeded(), qr/^(?:1|)$/);
}
$context -> drop(0);
$context -> abort(0);
}
__END__
Copyright (C) 2003 by the gtk2-perl team (see the file AUTHORS for the
full list). See LICENSE for more information.
|
