git.sur5r.net Git - i3/i3/blob - testcases/t/lib/i3test.pm

   1 package i3test;
   2 # vim:ts=4:sw=4:expandtab
   3
   4 use File::Temp qw(tmpnam tempfile tempdir);
   5 use Test::Builder;
   6 use X11::XCB::Rect;
   7 use X11::XCB::Window;
   8 use X11::XCB qw(:all);
   9 use AnyEvent::I3;
  10 use EV;
  11 use List::Util qw(first);
  12 use List::MoreUtils qw(lastval);
  13 use Time::HiRes qw(sleep);
  14 use Try::Tiny;
  15 use Cwd qw(abs_path);
  16 use Proc::Background;
  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_standard_window
  30     get_dock_clients
  31     cmd
  32     sync_with_i3
  33     does_i3_live
  34     exit_gracefully
  35     workspace_exists
  36     focused_ws
  37     get_socket_path
  38     launch_with_config
  39     wait_for_event
  40     wait_for_map
  41     wait_for_unmap
  42 );
  43
  44 my $tester = Test::Builder->new();
  45 my $_cached_socket_path = undef;
  46 my $_sync_window = undef;
  47 my $tmp_socket_path = undef;
  48
  49 BEGIN {
  50     my $window_count = 0;
  51     sub counter_window {
  52         return $window_count++;
  53     }
  54 }
  55
  56 sub import {
  57     my $class = shift;
  58     my $pkg = caller;
  59     eval "package $pkg;
  60 use Test::Most" . (@_ > 0 ? " qw(@_)" : "") . ";
  61 use Data::Dumper;
  62 use AnyEvent::I3;
  63 use Time::HiRes qw(sleep);
  64 use Test::Deep qw(eq_deeply cmp_deeply cmp_set cmp_bag cmp_methods useclass noclass set bag subbagof superbagof subsetof supersetof superhashof subhashof bool str arraylength Isa ignore methods regexprefonly regexpmatches num regexponly scalref reftype hashkeysonly blessed array re hash regexpref hash_each shallow array_each code arrayelementsonly arraylengthonly scalarrefonly listmethods any hashkeys isa);
  65 use v5.10;
  66 use strict;
  67 use warnings;
  68 ";
  69     @_ = ($class);
  70     goto \&Exporter::import;
  71 }
  72
  73 #
  74 # Waits for the next event and calls the given callback for every event to
  75 # determine if this is the event we are waiting for.
  76 #
  77 # Can be used to wait until a window is mapped, until a ClientMessage is
  78 # received, etc.
  79 #
  80 # wait_for_event $x, 0.25, sub { $_[0]->{response_type} == MAP_NOTIFY };
  81 #
  82 sub wait_for_event {
  83     my ($x, $timeout, $cb) = @_;
  84
  85     my $cv = AE::cv;
  86
  87     my $prep = EV::prepare sub {
  88         $x->flush;
  89     };
  90
  91     my $check = EV::check sub {
  92         while (defined(my $event = $x->poll_for_event)) {
  93             if ($cb->($event)) {
  94                 $cv->send(1);
  95                 last;
  96             }
  97         }
  98     };
  99
 100     my $watcher = EV::io $x->get_file_descriptor, EV::READ, sub {
 101         # do nothing, we only need this watcher so that EV picks up the events
 102     };
 103
 104     # Trigger timeout after $timeout seconds (can be fractional)
 105     my $timeout = AE::timer $timeout, 0, sub { warn "timeout"; $cv->send(0) };
 106
 107     my $result = $cv->recv;
 108     return $result;
 109 }
 110
 111 # thin wrapper around wait_for_event which waits for MAP_NOTIFY
 112 # make sure to include 'structure_notify' in the window’s event_mask attribute
 113 sub wait_for_map {
 114     my ($x) = @_;
 115     wait_for_event $x, 1, sub { $_[0]->{response_type} == MAP_NOTIFY };
 116 }
 117
 118 # Wrapper around wait_for_event which waits for UNMAP_NOTIFY. Also calls
 119 # sync_with_i3 to make sure i3 also picked up and processed the UnmapNotify
 120 # event.
 121 sub wait_for_unmap {
 122     my ($x) = @_;
 123     wait_for_event $x, 1, sub { $_[0]->{response_type} == UNMAP_NOTIFY };
 124     sync_with_i3($x);
 125 }
 126
 127 sub open_standard_window {
 128     my ($x, $color, $floating) = @_;
 129
 130     $color ||= '#c0c0c0';
 131
 132     # We cannot use a hashref here because create_child expands the arguments into an array
 133     my @args = (
 134         class => WINDOW_CLASS_INPUT_OUTPUT,
 135         rect => X11::XCB::Rect->new(x => 0, y => 0, width => 30, height => 30 ),
 136         background_color => $color,
 137         event_mask => [ 'structure_notify' ],
 138     );
 139
 140     if (defined($floating) && $floating) {
 141         @args = (@args, window_type => $x->atom(name => '_NET_WM_WINDOW_TYPE_UTILITY'));
 142     }
 143
 144     my $window = $x->root->create_child(@args);
 145
 146     $window->name('Window ' . counter_window());
 147     $window->map;
 148
 149     wait_for_event $x, 0.5, sub { $_[0]->{response_type} == MAP_NOTIFY };
 150
 151     return $window;
 152 }
 153
 154 sub open_empty_con {
 155     my ($i3) = @_;
 156
 157     my $reply = $i3->command('open')->recv;
 158     return $reply->{id};
 159 }
 160
 161 sub get_workspace_names {
 162     my $i3 = i3(get_socket_path());
 163     my $tree = $i3->get_tree->recv;
 164     my @outputs = @{$tree->{nodes}};
 165     my @cons;
 166     for my $output (@outputs) {
 167         # get the first CT_CON of each output
 168         my $content = first { $_->{type} == 2 } @{$output->{nodes}};
 169         @cons = (@cons, @{$content->{nodes}});
 170     }
 171     [ map { $_->{name} } @cons ]
 172 }
 173
 174 sub get_unused_workspace {
 175     my @names = get_workspace_names();
 176     my $tmp;
 177     do { $tmp = tmpnam() } while ($tmp ~~ @names);
 178     $tmp
 179 }
 180
 181 sub fresh_workspace {
 182     my $unused = get_unused_workspace;
 183     cmd("workspace $unused");
 184     $unused
 185 }
 186
 187 sub get_ws {
 188     my ($name) = @_;
 189     my $i3 = i3(get_socket_path());
 190     my $tree = $i3->get_tree->recv;
 191
 192     my @outputs = @{$tree->{nodes}};
 193     my @workspaces;
 194     for my $output (@outputs) {
 195         # get the first CT_CON of each output
 196         my $content = first { $_->{type} == 2 } @{$output->{nodes}};
 197         @workspaces = (@workspaces, @{$content->{nodes}});
 198     }
 199
 200     # as there can only be one workspace with this name, we can safely
 201     # return the first entry
 202     return first { $_->{name} eq $name } @workspaces;
 203 }
 204
 205 #
 206 # returns the content (== tree, starting from the node of a workspace)
 207 # of a workspace. If called in array context, also includes the focus
 208 # stack of the workspace
 209 #
 210 sub get_ws_content {
 211     my ($name) = @_;
 212     my $con = get_ws($name);
 213     return wantarray ? ($con->{nodes}, $con->{focus}) : $con->{nodes};
 214 }
 215
 216 sub get_focused {
 217     my ($ws) = @_;
 218     my $con = get_ws($ws);
 219
 220     my @focused = @{$con->{focus}};
 221     my $lf;
 222     while (@focused > 0) {
 223         $lf = $focused[0];
 224         last unless defined($con->{focus});
 225         @focused = @{$con->{focus}};
 226         @cons = grep { $_->{id} == $lf } (@{$con->{nodes}}, @{$con->{'floating_nodes'}});
 227         $con = $cons[0];
 228     }
 229
 230     return $lf;
 231 }
 232
 233 sub get_dock_clients {
 234     my $which = shift;
 235
 236     my $tree = i3(get_socket_path())->get_tree->recv;
 237     my @outputs = @{$tree->{nodes}};
 238     # Children of all dockareas
 239     my @docked;
 240     for my $output (@outputs) {
 241         if (!defined($which)) {
 242             @docked = (@docked, map { @{$_->{nodes}} }
 243                                 grep { $_->{type} == 5 }
 244                                 @{$output->{nodes}});
 245         } elsif ($which eq 'top') {
 246             my $first = first { $_->{type} == 5 } @{$output->{nodes}};
 247             @docked = (@docked, @{$first->{nodes}});
 248         } elsif ($which eq 'bottom') {
 249             my $last = lastval { $_->{type} == 5 } @{$output->{nodes}};
 250             @docked = (@docked, @{$last->{nodes}});
 251         }
 252     }
 253     return @docked;
 254 }
 255
 256 sub cmd {
 257     i3(get_socket_path())->command(@_)->recv
 258 }
 259
 260 sub workspace_exists {
 261     my ($name) = @_;
 262     ($name ~~ @{get_workspace_names()})
 263 }
 264
 265 sub focused_ws {
 266     my $i3 = i3(get_socket_path());
 267     my $tree = $i3->get_tree->recv;
 268     my @outputs = @{$tree->{nodes}};
 269     my @cons;
 270     for my $output (@outputs) {
 271         # get the first CT_CON of each output
 272         my $content = first { $_->{type} == 2 } @{$output->{nodes}};
 273         my $first = first { $_->{fullscreen_mode} == 1 } @{$content->{nodes}};
 274         return $first->{name}
 275     }
 276 }
 277
 278 #
 279 # Sends an I3_SYNC ClientMessage with a random value to the root window.
 280 # i3 will reply with the same value, but, due to the order of events it
 281 # processes, only after all other events are done.
 282 #
 283 # This can be used to ensure the results of a cmd 'focus left' are pushed to
 284 # X11 and that $x->input_focus returns the correct value afterwards.
 285 #
 286 # See also docs/testsuite for a long explanation
 287 #
 288 sub sync_with_i3 {
 289     my ($x) = @_;
 290
 291     # Since we need a (mapped) window for receiving a ClientMessage, we create
 292     # one on the first call of sync_with_i3. It will be re-used in all
 293     # subsequent calls.
 294     if (!defined($_sync_window)) {
 295         $_sync_window = $x->root->create_child(
 296             class => WINDOW_CLASS_INPUT_OUTPUT,
 297             rect => X11::XCB::Rect->new(x => -15, y => -15, width => 10, height => 10 ),
 298             override_redirect => 1,
 299             background_color => '#ff0000',
 300             event_mask => [ 'structure_notify' ],
 301         );
 302
 303         $_sync_window->map;
 304
 305         wait_for_event $x, 0.5, sub { $_[0]->{response_type} == MAP_NOTIFY };
 306     }
 307
 308     my $root = $x->get_root_window();
 309     # Generate a random number to identify this particular ClientMessage.
 310     my $myrnd = int(rand(255)) + 1;
 311
 312     # Generate a ClientMessage, see xcb_client_message_t
 313     my $msg = pack "CCSLLLLLLL",
 314          CLIENT_MESSAGE, # response_type
 315          32,     # format
 316          0,      # sequence
 317          $root,  # destination window
 318          $x->atom(name => 'I3_SYNC')->id,
 319
 320          $_sync_window->id,    # data[0]: our own window id
 321          $myrnd, # data[1]: a random value to identify the request
 322          0,
 323          0,
 324          0;
 325
 326     # Send it to the root window -- since i3 uses the SubstructureRedirect
 327     # event mask, it will get the ClientMessage.
 328     $x->send_event(0, $root, EVENT_MASK_SUBSTRUCTURE_REDIRECT, $msg);
 329
 330     # now wait until the reply is here
 331     return wait_for_event $x, 1, sub {
 332         my ($event) = @_;
 333         # TODO: const
 334         return 0 unless $event->{response_type} == 161;
 335
 336         my ($win, $rnd) = unpack "LL", $event->{data};
 337         return ($rnd == $myrnd);
 338     };
 339 }
 340
 341 sub does_i3_live {
 342     my $tree = i3(get_socket_path())->get_tree->recv;
 343     my @nodes = @{$tree->{nodes}};
 344     my $ok = (@nodes > 0);
 345     $tester->ok($ok, 'i3 still lives');
 346     return $ok;
 347 }
 348
 349 # Tries to exit i3 gracefully (with the 'exit' cmd) or kills the PID if that fails
 350 sub exit_gracefully {
 351     my ($pid, $socketpath) = @_;
 352     $socketpath ||= get_socket_path();
 353
 354     my $exited = 0;
 355     try {
 356         say "Exiting i3 cleanly...";
 357         i3($socketpath)->command('exit')->recv;
 358         $exited = 1;
 359     };
 360
 361     if (!$exited) {
 362         kill(9, $pid) or die "could not kill i3";
 363     }
 364 }
 365
 366 # Gets the socket path from the I3_SOCKET_PATH atom stored on the X11 root window
 367 sub get_socket_path {
 368     my ($cache) = @_;
 369     $cache ||= 1;
 370
 371     if ($cache && defined($_cached_socket_path)) {
 372         return $_cached_socket_path;
 373     }
 374
 375     my $x = X11::XCB::Connection->new;
 376     my $atom = $x->atom(name => 'I3_SOCKET_PATH');
 377     my $cookie = $x->get_property(0, $x->get_root_window(), $atom->id, GET_PROPERTY_TYPE_ANY, 0, 256);
 378     my $reply = $x->get_property_reply($cookie->{sequence});
 379     my $socketpath = $reply->{value};
 380     $_cached_socket_path = $socketpath;
 381     return $socketpath;
 382 }
 383
 384 #
 385 # launches a new i3 process with the given string as configuration file.
 386 # useful for tests which test specific config file directives.
 387 #
 388 # be sure to use !NO_I3_INSTANCE! somewhere in the file to signal
 389 # complete-run.pl that it should not create an instance of i3
 390 #
 391 sub launch_with_config {
 392     my ($config) = @_;
 393
 394     if (!defined($tmp_socket_path)) {
 395         $tmp_socket_path = File::Temp::tempnam('/tmp', 'i3-test-socket-');
 396     }
 397
 398     my ($fh, $tmpfile) = tempfile('i3-test-config-XXXXX', UNLINK => 1);
 399     say $fh $config;
 400     say $fh "ipc-socket $tmp_socket_path";
 401     close($fh);
 402
 403     # Use $ENV{LOGPATH}, gets set in complete-run.pl. We append instead of
 404     # overwrite because there might be multiple instances of i3 running during
 405     # one test case.
 406     my $i3cmd = "exec " . abs_path("../i3") . " -V -d all --disable-signalhandler -c $tmpfile >>$ENV{LOGPATH} 2>&1";
 407     my $process = Proc::Background->new($i3cmd);
 408     sleep 1.25;
 409
 410     # force update of the cached socket path in lib/i3test
 411     get_socket_path(0);
 412
 413     return $process;
 414 }
 415
 416 1