git.sur5r.net Git - i3/i3/blob - 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 List::Util qw(first);
  12 use Time::HiRes qw(sleep);
  13 use Cwd qw(abs_path);
  14 use Scalar::Util qw(blessed);
  15 use SocketActivation;
  16
  17 use v5.10;
  18
  19 # preload
  20 use Test::More ();
  21 use Data::Dumper ();
  22
  23 use Exporter ();
  24 our @EXPORT = qw(
  25     get_workspace_names
  26     get_unused_workspace
  27     fresh_workspace
  28     get_ws_content
  29     get_ws
  30     get_focused
  31     open_empty_con
  32     open_window
  33     open_floating_window
  34     get_dock_clients
  35     cmd
  36     cmp_float
  37     sync_with_i3
  38     does_i3_live
  39     exit_gracefully
  40     workspace_exists
  41     focused_ws
  42     get_socket_path
  43     launch_with_config
  44     wait_for_event
  45     wait_for_map
  46     wait_for_unmap
  47     $x
  48 );
  49
  50 my $tester = Test::Builder->new();
  51 my $_cached_socket_path = undef;
  52 my $_sync_window = undef;
  53 my $tmp_socket_path = undef;
  54
  55 our $x;
  56
  57 BEGIN {
  58     my $window_count = 0;
  59     sub counter_window {
  60         return $window_count++;
  61     }
  62 }
  63
  64 my $i3_pid;
  65 my $i3_autostart;
  66
  67 END {
  68
  69     # testcases which start i3 manually should always call exit_gracefully
  70     # on their own. Let’s see, whether they really did.
  71     if (! $i3_autostart) {
  72         return unless $i3_pid;
  73
  74         $tester->ok(undef, 'testcase called exit_gracefully()');
  75     }
  76
  77     # don't trigger SIGCHLD handler
  78     local $SIG{CHLD};
  79
  80     # From perldoc -v '$?':
  81     # Inside an "END" subroutine $? contains the value
  82     # that is going to be given to "exit()".
  83     #
  84     # Since waitpid sets $?, we need to localize it,
  85     # otherwise TAP would be misinterpreted our return status
  86     local $?;
  87
  88     # When measuring code coverage, try to exit i3 cleanly (otherwise, .gcda
  89     # files are not written)
  90     if ($ENV{COVERAGE} || $ENV{VALGRIND}) {
  91         exit_gracefully($i3_pid, "/tmp/nested-$ENV{DISPLAY}");
  92
  93     } else {
  94         kill(9, $i3_pid)
  95             or $tester->BAIL_OUT("could not kill i3");
  96
  97         waitpid $i3_pid, 0;
  98     }
  99 }
 100
 101 sub import {
 102     my ($class, %args) = @_;
 103     my $pkg = caller;
 104
 105     $i3_autostart = delete($args{i3_autostart}) // 1;
 106
 107     my $cv = launch_with_config('-default', dont_block => 1)
 108         if $i3_autostart;
 109
 110     my $test_more_args = '';
 111     $test_more_args = join(' ', 'qw(', %args, ')') if keys %args;
 112     local $@;
 113     eval << "__";
 114 package $pkg;
 115 use Test::More $test_more_args;
 116 use Data::Dumper;
 117 use AnyEvent::I3;
 118 use Time::HiRes qw(sleep);
 119 __
 120     $tester->BAIL_OUT("$@") if $@;
 121     feature->import(":5.10");
 122     strict->import;
 123     warnings->import;
 124
 125     $x ||= i3test::X11->new;
 126     $cv->recv if $i3_autostart;
 127
 128     @_ = ($class);
 129     goto \&Exporter::import;
 130 }
 131
 132 #
 133 # Waits for the next event and calls the given callback for every event to
 134 # determine if this is the event we are waiting for.
 135 #
 136 # Can be used to wait until a window is mapped, until a ClientMessage is
 137 # received, etc.
 138 #
 139 # wait_for_event $x, 0.25, sub { $_[0]->{response_type} == MAP_NOTIFY };
 140 #
 141 sub wait_for_event {
 142     my ($timeout, $cb) = @_;
 143
 144     my $cv = AE::cv;
 145
 146     $x->flush;
 147
 148     # unfortunately, there is no constant for this
 149     my $ae_read = 0;
 150
 151     my $guard = AE::io $x->get_file_descriptor, $ae_read, sub {
 152         while (defined(my $event = $x->poll_for_event)) {
 153             if ($cb->($event)) {
 154                 $cv->send(1);
 155                 last;
 156             }
 157         }
 158     };
 159
 160     # Trigger timeout after $timeout seconds (can be fractional)
 161     my $t = AE::timer $timeout, 0, sub { warn "timeout ($timeout secs)"; $cv->send(0) };
 162
 163     my $result = $cv->recv;
 164     undef $t;
 165     undef $guard;
 166     return $result;
 167 }
 168
 169 # thin wrapper around wait_for_event which waits for MAP_NOTIFY
 170 # make sure to include 'structure_notify' in the window’s event_mask attribute
 171 sub wait_for_map {
 172     my ($win) = @_;
 173     my $id = (blessed($win) && $win->isa('X11::XCB::Window')) ? $win->id : $win;
 174     wait_for_event 2, sub {
 175         $_[0]->{response_type} == MAP_NOTIFY and $_[0]->{window} == $id
 176     };
 177 }
 178
 179 # Wrapper around wait_for_event which waits for UNMAP_NOTIFY. Also calls
 180 # sync_with_i3 to make sure i3 also picked up and processed the UnmapNotify
 181 # event.
 182 sub wait_for_unmap {
 183     my ($win) = @_;
 184     # my $id = (blessed($win) && $win->isa('X11::XCB::Window')) ? $win->id : $win;
 185     wait_for_event 2, sub {
 186         $_[0]->{response_type} == UNMAP_NOTIFY # and $_[0]->{window} == $id
 187     };
 188     sync_with_i3();
 189 }
 190
 191 #
 192 # Opens a new window (see X11::XCB::Window), maps it, waits until it got mapped
 193 # and synchronizes with i3.
 194 #
 195 # set dont_map to a true value to avoid mapping
 196 #
 197 # if you want to change aspects of your window before it would be mapped,
 198 # set before_map to a coderef. $window gets passed as $_ and as first argument.
 199 #
 200 # if you set both dont_map and before_map, the coderef will be called nevertheless
 201 #
 202 #
 203 # default values:
 204 #     class => WINDOW_CLASS_INPUT_OUTPUT
 205 #     rect => [ 0, 0, 30, 30 ]
 206 #     background_color => '#c0c0c0'
 207 #     event_mask => [ 'structure_notify' ]
 208 #     name => 'Window <n>'
 209 #
 210 sub open_window {
 211     my %args = @_ == 1 ? %{$_[0]} : @_;
 212
 213     my $dont_map = delete $args{dont_map};
 214     my $before_map = delete $args{before_map};
 215
 216     $args{class} //= WINDOW_CLASS_INPUT_OUTPUT;
 217     $args{rect} //= [ 0, 0, 30, 30 ];
 218     $args{background_color} //= '#c0c0c0';
 219     $args{event_mask} //= [ 'structure_notify' ];
 220     $args{name} //= 'Window ' . counter_window();
 221
 222     my $window = $x->root->create_child(%args);
 223
 224     if ($before_map) {
 225         # TODO: investigate why _create is not needed
 226         $window->_create;
 227         $before_map->($window) for $window;
 228     }
 229
 230     return $window if $dont_map;
 231
 232     $window->map;
 233     wait_for_map($window);
 234     return $window;
 235 }
 236
 237 # Thin wrapper around open_window which sets window_type to
 238 # _NET_WM_WINDOW_TYPE_UTILITY to make the window floating.
 239 sub open_floating_window {
 240     my %args = @_ == 1 ? %{$_[0]} : @_;
 241
 242     $args{window_type} = $x->atom(name => '_NET_WM_WINDOW_TYPE_UTILITY');
 243
 244     return open_window(\%args);
 245 }
 246
 247 sub open_empty_con {
 248     my ($i3) = @_;
 249
 250     my $reply = $i3->command('open')->recv;
 251     return $reply->[0]->{id};
 252 }
 253
 254 sub get_workspace_names {
 255     my $i3 = i3(get_socket_path());
 256     my $tree = $i3->get_tree->recv;
 257     my @outputs = @{$tree->{nodes}};
 258     my @cons;
 259     for my $output (@outputs) {
 260         next if $output->{name} eq '__i3';
 261         # get the first CT_CON of each output
 262         my $content = first { $_->{type} == 2 } @{$output->{nodes}};
 263         @cons = (@cons, @{$content->{nodes}});
 264     }
 265     [ map { $_->{name} } @cons ]
 266 }
 267
 268 sub get_unused_workspace {
 269     my @names = get_workspace_names();
 270     my $tmp;
 271     do { $tmp = tmpnam() } while ($tmp ~~ @names);
 272     $tmp
 273 }
 274
 275 =head2 fresh_workspace(...)
 276
 277 Switches to an unused workspace and returns the name of that workspace.
 278
 279 Optionally switches to the specified output first.
 280
 281     my $ws = fresh_workspace;
 282
 283     # Get a fresh workspace on the second output.
 284     my $ws = fresh_workspace(output => 1);
 285
 286 =cut
 287 sub fresh_workspace {
 288     my %args = @_;
 289     if (exists($args{output})) {
 290         my $i3 = i3(get_socket_path());
 291         my $tree = $i3->get_tree->recv;
 292         my $output = first { $_->{name} eq "fake-$args{output}" }
 293                         @{$tree->{nodes}};
 294         die "BUG: Could not find output $args{output}" unless defined($output);
 295         # Get the focused workspace on that output and switch to it.
 296         my $content = first { $_->{type} == 2 } @{$output->{nodes}};
 297         my $focused = $content->{focus}->[0];
 298         my $workspace = first { $_->{id} == $focused } @{$content->{nodes}};
 299         $workspace = $workspace->{name};
 300         cmd("workspace $workspace");
 301     }
 302
 303     my $unused = get_unused_workspace;
 304     cmd("workspace $unused");
 305     $unused
 306 }
 307
 308 sub get_ws {
 309     my ($name) = @_;
 310     my $i3 = i3(get_socket_path());
 311     my $tree = $i3->get_tree->recv;
 312
 313     my @outputs = @{$tree->{nodes}};
 314     my @workspaces;
 315     for my $output (@outputs) {
 316         # get the first CT_CON of each output
 317         my $content = first { $_->{type} == 2 } @{$output->{nodes}};
 318         @workspaces = (@workspaces, @{$content->{nodes}});
 319     }
 320
 321     # as there can only be one workspace with this name, we can safely
 322     # return the first entry
 323     return first { $_->{name} eq $name } @workspaces;
 324 }
 325
 326 #
 327 # returns the content (== tree, starting from the node of a workspace)
 328 # of a workspace. If called in array context, also includes the focus
 329 # stack of the workspace
 330 #
 331 sub get_ws_content {
 332     my ($name) = @_;
 333     my $con = get_ws($name);
 334     return wantarray ? ($con->{nodes}, $con->{focus}) : $con->{nodes};
 335 }
 336
 337 sub get_focused {
 338     my ($ws) = @_;
 339     my $con = get_ws($ws);
 340
 341     my @focused = @{$con->{focus}};
 342     my $lf;
 343     while (@focused > 0) {
 344         $lf = $focused[0];
 345         last unless defined($con->{focus});
 346         @focused = @{$con->{focus}};
 347         my @cons = grep { $_->{id} == $lf } (@{$con->{nodes}}, @{$con->{'floating_nodes'}});
 348         $con = $cons[0];
 349     }
 350
 351     return $lf;
 352 }
 353
 354 sub get_dock_clients {
 355     my $which = shift;
 356
 357     my $tree = i3(get_socket_path())->get_tree->recv;
 358     my @outputs = @{$tree->{nodes}};
 359     # Children of all dockareas
 360     my @docked;
 361     for my $output (@outputs) {
 362         if (!defined($which)) {
 363             @docked = (@docked, map { @{$_->{nodes}} }
 364                                 grep { $_->{type} == 5 }
 365                                 @{$output->{nodes}});
 366         } elsif ($which eq 'top') {
 367             my $first = first { $_->{type} == 5 } @{$output->{nodes}};
 368             @docked = (@docked, @{$first->{nodes}}) if defined($first);
 369         } elsif ($which eq 'bottom') {
 370             my @matching = grep { $_->{type} == 5 } @{$output->{nodes}};
 371             my $last = $matching[-1];
 372             @docked = (@docked, @{$last->{nodes}}) if defined($last);
 373         }
 374     }
 375     return @docked;
 376 }
 377
 378 sub cmd {
 379     i3(get_socket_path())->command(@_)->recv
 380 }
 381
 382 sub workspace_exists {
 383     my ($name) = @_;
 384     ($name ~~ @{get_workspace_names()})
 385 }
 386
 387 =head2 focused_ws
 388
 389 Returns the name of the currently focused workspace.
 390
 391 =cut
 392 sub focused_ws {
 393     my $i3 = i3(get_socket_path());
 394     my $tree = $i3->get_tree->recv;
 395     my $focused = $tree->{focus}->[0];
 396     my $output = first { $_->{id} == $focused } @{$tree->{nodes}};
 397     my $content = first { $_->{type} == 2 } @{$output->{nodes}};
 398     my $first = first { $_->{fullscreen_mode} == 1 } @{$content->{nodes}};
 399     return $first->{name}
 400 }
 401
 402 #
 403 # Sends an I3_SYNC ClientMessage with a random value to the root window.
 404 # i3 will reply with the same value, but, due to the order of events it
 405 # processes, only after all other events are done.
 406 #
 407 # This can be used to ensure the results of a cmd 'focus left' are pushed to
 408 # X11 and that $x->input_focus returns the correct value afterwards.
 409 #
 410 # See also docs/testsuite for a long explanation
 411 #
 412 sub sync_with_i3 {
 413     my %args = @_ == 1 ? %{$_[0]} : @_;
 414
 415     # Since we need a (mapped) window for receiving a ClientMessage, we create
 416     # one on the first call of sync_with_i3. It will be re-used in all
 417     # subsequent calls.
 418     if (!exists($args{window_id}) &&
 419         (!defined($_sync_window) || exists($args{no_cache}))) {
 420         $_sync_window = open_window(
 421             rect => [ -15, -15, 10, 10 ],
 422             override_redirect => 1,
 423         );
 424     }
 425
 426     my $window_id = delete $args{window_id};
 427     $window_id //= $_sync_window->id;
 428
 429     my $root = $x->get_root_window();
 430     # Generate a random number to identify this particular ClientMessage.
 431     my $myrnd = int(rand(255)) + 1;
 432
 433     # Generate a ClientMessage, see xcb_client_message_t
 434     my $msg = pack "CCSLLLLLLL",
 435          CLIENT_MESSAGE, # response_type
 436          32,     # format
 437          0,      # sequence
 438          $root,  # destination window
 439          $x->atom(name => 'I3_SYNC')->id,
 440
 441          $window_id,    # data[0]: our own window id
 442          $myrnd, # data[1]: a random value to identify the request
 443          0,
 444          0,
 445          0;
 446
 447     # Send it to the root window -- since i3 uses the SubstructureRedirect
 448     # event mask, it will get the ClientMessage.
 449     $x->send_event(0, $root, EVENT_MASK_SUBSTRUCTURE_REDIRECT, $msg);
 450
 451     # now wait until the reply is here
 452     return wait_for_event 2, sub {
 453         my ($event) = @_;
 454         # TODO: const
 455         return 0 unless $event->{response_type} == 161;
 456
 457         my ($win, $rnd) = unpack "LL", $event->{data};
 458         return ($rnd == $myrnd);
 459     };
 460 }
 461
 462 sub does_i3_live {
 463     my $tree = i3(get_socket_path())->get_tree->recv;
 464     my @nodes = @{$tree->{nodes}};
 465     my $ok = (@nodes > 0);
 466     $tester->ok($ok, 'i3 still lives');
 467     return $ok;
 468 }
 469
 470 # Tries to exit i3 gracefully (with the 'exit' cmd) or kills the PID if that fails
 471 sub exit_gracefully {
 472     my ($pid, $socketpath) = @_;
 473     $socketpath ||= get_socket_path();
 474
 475     my $exited = 0;
 476     eval {
 477         say "Exiting i3 cleanly...";
 478         i3($socketpath)->command('exit')->recv;
 479         $exited = 1;
 480     };
 481
 482     if (!$exited) {
 483         kill(9, $pid)
 484             or $tester->BAIL_OUT("could not kill i3");
 485     }
 486
 487     if ($socketpath =~ m,^/tmp/i3-test-socket-,) {
 488         unlink($socketpath);
 489     }
 490
 491     waitpid $pid, 0;
 492     undef $i3_pid;
 493 }
 494
 495 # Gets the socket path from the I3_SOCKET_PATH atom stored on the X11 root window
 496 sub get_socket_path {
 497     my ($cache) = @_;
 498     $cache ||= 1;
 499
 500     if ($cache && defined($_cached_socket_path)) {
 501         return $_cached_socket_path;
 502     }
 503
 504     my $atom = $x->atom(name => 'I3_SOCKET_PATH');
 505     my $cookie = $x->get_property(0, $x->get_root_window(), $atom->id, GET_PROPERTY_TYPE_ANY, 0, 256);
 506     my $reply = $x->get_property_reply($cookie->{sequence});
 507     my $socketpath = $reply->{value};
 508     if ($socketpath eq "/tmp/nested-$ENV{DISPLAY}") {
 509         $socketpath .= '-activation';
 510     }
 511     $_cached_socket_path = $socketpath;
 512     return $socketpath;
 513 }
 514
 515 #
 516 # launches a new i3 process with the given string as configuration file.
 517 # useful for tests which test specific config file directives.
 518 sub launch_with_config {
 519     my ($config, %args) = @_;
 520
 521     $tmp_socket_path = "/tmp/nested-$ENV{DISPLAY}";
 522
 523     $args{dont_create_temp_dir} //= 0;
 524
 525     my ($fh, $tmpfile) = tempfile("i3-cfg-for-$ENV{TESTNAME}-XXXXX", UNLINK => 1);
 526
 527     if ($config ne '-default') {
 528         say $fh $config;
 529     } else {
 530         open(my $conf_fh, '<', './i3-test.config')
 531             or $tester->BAIL_OUT("could not open default config: $!");
 532         local $/;
 533         say $fh scalar <$conf_fh>;
 534     }
 535
 536     say $fh "ipc-socket $tmp_socket_path"
 537         unless $args{dont_add_socket_path};
 538
 539     close($fh);
 540
 541     my $cv = AnyEvent->condvar;
 542     $i3_pid = activate_i3(
 543         unix_socket_path => "$tmp_socket_path-activation",
 544         display => $ENV{DISPLAY},
 545         configfile => $tmpfile,
 546         outdir => $ENV{OUTDIR},
 547         testname => $ENV{TESTNAME},
 548         valgrind => $ENV{VALGRIND},
 549         strace => $ENV{STRACE},
 550         restart => $ENV{RESTART},
 551         cv => $cv,
 552         dont_create_temp_dir => $args{dont_create_temp_dir},
 553     );
 554
 555     # force update of the cached socket path in lib/i3test
 556     # as soon as i3 has started
 557     $cv->cb(sub { get_socket_path(0) });
 558
 559     return $cv if $args{dont_block};
 560
 561     # blockingly wait until i3 is ready
 562     $cv->recv;
 563
 564     return $i3_pid;
 565 }
 566
 567 # compares two floats and return true if they differ less
 568 # then 1e-6
 569 sub cmp_float {
 570   my ($a, $b) = @_;
 571
 572   return abs($a - $b) < 1e-6;
 573 }
 574
 575 package i3test::X11;
 576 use parent 'X11::XCB::Connection';
 577
 578 sub input_focus {
 579     my $self = shift;
 580     i3test::sync_with_i3();
 581
 582     return $self->SUPER::input_focus(@_);
 583 }
 584
 585 1