]> git.sur5r.net Git - i3/i3/blob - testcases/lib/i3test.pm
c94101e19eb794450df66472b91dd71ada305e87
[i3/i3] / testcases / lib / i3test.pm
1 package i3test;
2 # vim:ts=4:sw=4:expandtab
3 use strict; use warnings;
4
5 use File::Temp qw(tmpnam tempfile tempdir);
6 use Test::Builder;
7 use X11::XCB::Rect;
8 use X11::XCB::Window;
9 use X11::XCB qw(:all);
10 use AnyEvent::I3;
11 use EV;
12 use List::Util qw(first);
13 use Time::HiRes qw(sleep);
14 use Cwd qw(abs_path);
15 use Scalar::Util qw(blessed);
16 use SocketActivation;
17
18 use v5.10;
19
20 use Exporter ();
21 our @EXPORT = qw(
22     get_workspace_names
23     get_unused_workspace
24     fresh_workspace
25     get_ws_content
26     get_ws
27     get_focused
28     open_empty_con
29     open_window
30     open_floating_window
31     get_dock_clients
32     cmd
33     sync_with_i3
34     does_i3_live
35     exit_gracefully
36     workspace_exists
37     focused_ws
38     get_socket_path
39     launch_with_config
40     wait_for_event
41     wait_for_map
42     wait_for_unmap
43     $x
44 );
45
46 my $tester = Test::Builder->new();
47 my $_cached_socket_path = undef;
48 my $_sync_window = undef;
49 my $tmp_socket_path = undef;
50
51 our $x;
52
53 BEGIN {
54     my $window_count = 0;
55     sub counter_window {
56         return $window_count++;
57     }
58 }
59
60 sub import {
61     my $class = shift;
62     my $pkg = caller;
63
64     my $test_most_args = @_ ? "qw(@_)" : "";
65     local $@;
66     eval << "__";
67 package $pkg;
68 use Test::Most $test_most_args;
69 use Data::Dumper;
70 use AnyEvent::I3;
71 use Time::HiRes qw(sleep);
72 use Test::Deep qw(eq_deeply cmp_deeply);
73 __
74     $tester->bail_out("$@") if $@;
75     feature->import(":5.10");
76     strict->import;
77     warnings->import;
78
79     $x ||= i3test::X11->new;
80     @_ = ($class);
81     goto \&Exporter::import;
82 }
83
84 #
85 # Waits for the next event and calls the given callback for every event to
86 # determine if this is the event we are waiting for.
87 #
88 # Can be used to wait until a window is mapped, until a ClientMessage is
89 # received, etc.
90 #
91 # wait_for_event $x, 0.25, sub { $_[0]->{response_type} == MAP_NOTIFY };
92 #
93 sub wait_for_event {
94     my ($timeout, $cb) = @_;
95
96     my $cv = AE::cv;
97
98     my $prep = EV::prepare sub {
99         $x->flush;
100     };
101
102     my $check = EV::check sub {
103         while (defined(my $event = $x->poll_for_event)) {
104             if ($cb->($event)) {
105                 $cv->send(1);
106                 last;
107             }
108         }
109     };
110
111     my $watcher = EV::io $x->get_file_descriptor, EV::READ, sub {
112         # do nothing, we only need this watcher so that EV picks up the events
113     };
114
115     # Trigger timeout after $timeout seconds (can be fractional)
116     my $t = AE::timer $timeout, 0, sub { warn "timeout ($timeout secs)"; $cv->send(0) };
117
118     my $result = $cv->recv;
119     undef $t;
120     return $result;
121 }
122
123 # thin wrapper around wait_for_event which waits for MAP_NOTIFY
124 # make sure to include 'structure_notify' in the window’s event_mask attribute
125 sub wait_for_map {
126     my ($win) = @_;
127     my $id = (blessed($win) && $win->isa('X11::XCB::Window')) ? $win->id : $win;
128     wait_for_event 2, sub {
129         $_[0]->{response_type} == MAP_NOTIFY and $_[0]->{window} == $id
130     };
131 }
132
133 # Wrapper around wait_for_event which waits for UNMAP_NOTIFY. Also calls
134 # sync_with_i3 to make sure i3 also picked up and processed the UnmapNotify
135 # event.
136 sub wait_for_unmap {
137     my ($win) = @_;
138     # my $id = (blessed($win) && $win->isa('X11::XCB::Window')) ? $win->id : $win;
139     wait_for_event 2, sub {
140         $_[0]->{response_type} == UNMAP_NOTIFY # and $_[0]->{window} == $id
141     };
142     sync_with_i3($x);
143 }
144
145 #
146 # Opens a new window (see X11::XCB::Window), maps it, waits until it got mapped
147 # and synchronizes with i3.
148 #
149 # set dont_map to a true value to avoid mapping
150 #
151 # default values:
152 #     class => WINDOW_CLASS_INPUT_OUTPUT
153 #     rect => [ 0, 0, 30, 30 ]
154 #     background_color => '#c0c0c0'
155 #     event_mask => [ 'structure_notify' ]
156 #     name => 'Window <n>'
157 #
158 sub open_window {
159     my ($x, $args) = @_;
160     my %args = ($args ? %$args : ());
161
162     my $dont_map = delete $args{dont_map};
163
164     $args{class} //= WINDOW_CLASS_INPUT_OUTPUT;
165     $args{rect} //= [ 0, 0, 30, 30 ];
166     $args{background_color} //= '#c0c0c0';
167     $args{event_mask} //= [ 'structure_notify' ];
168     $args{name} //= 'Window ' . counter_window();
169
170     my $window = $x->root->create_child(%args);
171
172     return $window if $dont_map;
173
174     $window->map;
175     wait_for_map($window);
176     # We sync with i3 here to make sure $x->input_focus is updated.
177     sync_with_i3($x);
178     return $window;
179 }
180
181 # Thin wrapper around open_window which sets window_type to
182 # _NET_WM_WINDOW_TYPE_UTILITY to make the window floating.
183 sub open_floating_window {
184     my ($x, $args) = @_;
185     my %args = ($args ? %$args : ());
186
187     $args{window_type} = $x->atom(name => '_NET_WM_WINDOW_TYPE_UTILITY');
188
189     return open_window($x, \%args);
190 }
191
192 sub open_empty_con {
193     my ($i3) = @_;
194
195     my $reply = $i3->command('open')->recv;
196     return $reply->{id};
197 }
198
199 sub get_workspace_names {
200     my $i3 = i3(get_socket_path());
201     my $tree = $i3->get_tree->recv;
202     my @outputs = @{$tree->{nodes}};
203     my @cons;
204     for my $output (@outputs) {
205         # get the first CT_CON of each output
206         my $content = first { $_->{type} == 2 } @{$output->{nodes}};
207         @cons = (@cons, @{$content->{nodes}});
208     }
209     [ map { $_->{name} } @cons ]
210 }
211
212 sub get_unused_workspace {
213     my @names = get_workspace_names();
214     my $tmp;
215     do { $tmp = tmpnam() } while ($tmp ~~ @names);
216     $tmp
217 }
218
219 sub fresh_workspace {
220     my $unused = get_unused_workspace;
221     cmd("workspace $unused");
222     $unused
223 }
224
225 sub get_ws {
226     my ($name) = @_;
227     my $i3 = i3(get_socket_path());
228     my $tree = $i3->get_tree->recv;
229
230     my @outputs = @{$tree->{nodes}};
231     my @workspaces;
232     for my $output (@outputs) {
233         # get the first CT_CON of each output
234         my $content = first { $_->{type} == 2 } @{$output->{nodes}};
235         @workspaces = (@workspaces, @{$content->{nodes}});
236     }
237
238     # as there can only be one workspace with this name, we can safely
239     # return the first entry
240     return first { $_->{name} eq $name } @workspaces;
241 }
242
243 #
244 # returns the content (== tree, starting from the node of a workspace)
245 # of a workspace. If called in array context, also includes the focus
246 # stack of the workspace
247 #
248 sub get_ws_content {
249     my ($name) = @_;
250     my $con = get_ws($name);
251     return wantarray ? ($con->{nodes}, $con->{focus}) : $con->{nodes};
252 }
253
254 sub get_focused {
255     my ($ws) = @_;
256     my $con = get_ws($ws);
257
258     my @focused = @{$con->{focus}};
259     my $lf;
260     while (@focused > 0) {
261         $lf = $focused[0];
262         last unless defined($con->{focus});
263         @focused = @{$con->{focus}};
264         my @cons = grep { $_->{id} == $lf } (@{$con->{nodes}}, @{$con->{'floating_nodes'}});
265         $con = $cons[0];
266     }
267
268     return $lf;
269 }
270
271 sub get_dock_clients {
272     my $which = shift;
273
274     my $tree = i3(get_socket_path())->get_tree->recv;
275     my @outputs = @{$tree->{nodes}};
276     # Children of all dockareas
277     my @docked;
278     for my $output (@outputs) {
279         if (!defined($which)) {
280             @docked = (@docked, map { @{$_->{nodes}} }
281                                 grep { $_->{type} == 5 }
282                                 @{$output->{nodes}});
283         } elsif ($which eq 'top') {
284             my $first = first { $_->{type} == 5 } @{$output->{nodes}};
285             @docked = (@docked, @{$first->{nodes}});
286         } elsif ($which eq 'bottom') {
287             my @matching = grep { $_->{type} == 5 } @{$output->{nodes}};
288             my $last = $matching[-1];
289             @docked = (@docked, @{$last->{nodes}});
290         }
291     }
292     return @docked;
293 }
294
295 sub cmd {
296     i3(get_socket_path())->command(@_)->recv
297 }
298
299 sub workspace_exists {
300     my ($name) = @_;
301     ($name ~~ @{get_workspace_names()})
302 }
303
304 sub focused_ws {
305     my $i3 = i3(get_socket_path());
306     my $tree = $i3->get_tree->recv;
307     my @outputs = @{$tree->{nodes}};
308     my @cons;
309     for my $output (@outputs) {
310         # get the first CT_CON of each output
311         my $content = first { $_->{type} == 2 } @{$output->{nodes}};
312         my $first = first { $_->{fullscreen_mode} == 1 } @{$content->{nodes}};
313         return $first->{name}
314     }
315 }
316
317 #
318 # Sends an I3_SYNC ClientMessage with a random value to the root window.
319 # i3 will reply with the same value, but, due to the order of events it
320 # processes, only after all other events are done.
321 #
322 # This can be used to ensure the results of a cmd 'focus left' are pushed to
323 # X11 and that $x->input_focus returns the correct value afterwards.
324 #
325 # See also docs/testsuite for a long explanation
326 #
327 sub sync_with_i3 {
328     my ($x) = @_;
329
330     # Since we need a (mapped) window for receiving a ClientMessage, we create
331     # one on the first call of sync_with_i3. It will be re-used in all
332     # subsequent calls.
333     if (!defined($_sync_window)) {
334         $_sync_window = $x->root->create_child(
335             class => WINDOW_CLASS_INPUT_OUTPUT,
336             rect => X11::XCB::Rect->new(x => -15, y => -15, width => 10, height => 10 ),
337             override_redirect => 1,
338             background_color => '#ff0000',
339             event_mask => [ 'structure_notify' ],
340         );
341
342         $_sync_window->map;
343
344         wait_for_event 2, sub { $_[0]->{response_type} == MAP_NOTIFY };
345     }
346
347     my $root = $x->get_root_window();
348     # Generate a random number to identify this particular ClientMessage.
349     my $myrnd = int(rand(255)) + 1;
350
351     # Generate a ClientMessage, see xcb_client_message_t
352     my $msg = pack "CCSLLLLLLL",
353          CLIENT_MESSAGE, # response_type
354          32,     # format
355          0,      # sequence
356          $root,  # destination window
357          $x->atom(name => 'I3_SYNC')->id,
358
359          $_sync_window->id,    # data[0]: our own window id
360          $myrnd, # data[1]: a random value to identify the request
361          0,
362          0,
363          0;
364
365     # Send it to the root window -- since i3 uses the SubstructureRedirect
366     # event mask, it will get the ClientMessage.
367     $x->send_event(0, $root, EVENT_MASK_SUBSTRUCTURE_REDIRECT, $msg);
368
369     # now wait until the reply is here
370     return wait_for_event 2, sub {
371         my ($event) = @_;
372         # TODO: const
373         return 0 unless $event->{response_type} == 161;
374
375         my ($win, $rnd) = unpack "LL", $event->{data};
376         return ($rnd == $myrnd);
377     };
378 }
379
380 sub does_i3_live {
381     my $tree = i3(get_socket_path())->get_tree->recv;
382     my @nodes = @{$tree->{nodes}};
383     my $ok = (@nodes > 0);
384     $tester->ok($ok, 'i3 still lives');
385     return $ok;
386 }
387
388 # Tries to exit i3 gracefully (with the 'exit' cmd) or kills the PID if that fails
389 sub exit_gracefully {
390     my ($pid, $socketpath) = @_;
391     $socketpath ||= get_socket_path();
392
393     my $exited = 0;
394     eval {
395         say "Exiting i3 cleanly...";
396         i3($socketpath)->command('exit')->recv;
397         $exited = 1;
398     };
399
400     if (!$exited) {
401         kill(9, $pid) or die "could not kill i3";
402     }
403
404     if ($socketpath =~ m,^/tmp/i3-test-socket-,) {
405         unlink($socketpath);
406     }
407 }
408
409 # Gets the socket path from the I3_SOCKET_PATH atom stored on the X11 root window
410 sub get_socket_path {
411     my ($cache) = @_;
412     $cache ||= 1;
413
414     if ($cache && defined($_cached_socket_path)) {
415         return $_cached_socket_path;
416     }
417
418     my $atom = $x->atom(name => 'I3_SOCKET_PATH');
419     my $cookie = $x->get_property(0, $x->get_root_window(), $atom->id, GET_PROPERTY_TYPE_ANY, 0, 256);
420     my $reply = $x->get_property_reply($cookie->{sequence});
421     my $socketpath = $reply->{value};
422     $_cached_socket_path = $socketpath;
423     return $socketpath;
424 }
425
426 #
427 # launches a new i3 process with the given string as configuration file.
428 # useful for tests which test specific config file directives.
429 #
430 # be sure to use !NO_I3_INSTANCE! somewhere in the file to signal
431 # complete-run.pl that it should not create an instance of i3
432 #
433 sub launch_with_config {
434     my ($config, $dont_add_socket_path) = @_;
435
436     $dont_add_socket_path //= 0;
437
438     if (!defined($tmp_socket_path)) {
439         $tmp_socket_path = File::Temp::tempnam('/tmp', 'i3-test-socket-');
440     }
441
442     my ($fh, $tmpfile) = tempfile('/tmp/i3-test-config-XXXXX', UNLINK => 1);
443     say $fh $config;
444     say $fh "ipc-socket $tmp_socket_path" unless $dont_add_socket_path;
445     close($fh);
446
447     my $cv = AnyEvent->condvar;
448     my $pid = activate_i3(
449         unix_socket_path => "$tmp_socket_path-activation",
450         display => $ENV{DISPLAY},
451         configfile => $tmpfile,
452         outdir => $ENV{OUTDIR},
453         testname => $ENV{TESTNAME},
454         valgrind => $ENV{VALGRIND},
455         strace => $ENV{STRACE},
456         cv => $cv,
457     );
458
459     # blockingly wait until i3 is ready
460     $cv->recv;
461
462     # force update of the cached socket path in lib/i3test
463     get_socket_path(0);
464
465     return $pid;
466 }
467
468 package i3test::X11;
469 use parent 'X11::XCB::Connection';
470
471 sub input_focus {
472     my $self = shift;
473     i3test::sync_with_i3($self);
474
475     return $self->SUPER::input_focus(@_);
476 }
477
478 1